lisp/progmodes/ada-mode.el

   1 ;;; ada-mode.el --- major-mode for editing Ada sources
   2
   3 ;; Copyright (C) 1994, 95, 97, 98, 99, 2000, 2001
   4 ;;  Free Software Foundation, Inc.
   5
   6 ;; Author: Rolf Ebert      <ebert@inf.enst.fr>
   7 ;;      Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de>
   8 ;;      Emmanuel Briot  <briot@gnat.com>
   9 ;; Maintainer: Emmanuel Briot <briot@gnat.com>
  10 ;; Ada Core Technologies's version:   $Revision: 1.41 $
  11 ;; Keywords: languages ada
  12
  13 ;; This file is part of GNU Emacs.
  14
  15 ;; GNU Emacs is free software; you can redistribute it and/or modify
  16 ;; it under the terms of the GNU General Public License as published by
  17 ;; the Free Software Foundation; either version 2, or (at your option)
  18 ;; any later version.
  19
  20 ;; GNU Emacs is distributed in the hope that it will be useful,
  21 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  22 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23 ;; GNU General Public License for more details.
  24
  25 ;; You should have received a copy of the GNU General Public License
  26 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  27 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  28 ;; Boston, MA 02111-1307, USA.
  29
  30 ;;; Commentary:
  31 ;;; This mode is a major mode for editing Ada83 and Ada95 source code.
  32 ;;; This is a major rewrite of the file packaged with Emacs-20.  The
  33 ;;; ada-mode is composed of four lisp file, ada-mode.el, ada-xref.el,
  34 ;;; ada-prj.el and ada-stmt.el. Only this file (ada-mode.el) is
  35 ;;; completely independent from the GNU Ada compiler Gnat, distributed
  36 ;;; by Ada Core Technologies. All the other files rely heavily on
  37 ;;; features provides only by Gnat.
  38 ;;;
  39 ;;; Note: this mode will not work with Emacs 19. If you are on a VMS
  40 ;;; system, where the latest version of Emacs is 19.28, you will need
  41 ;;; another file, called ada-vms.el, that provides some required
  42 ;;; functions.
  43
  44 ;;; Usage:
  45 ;;; Emacs should enter Ada mode automatically when you load an Ada file.
  46 ;;; By default, the valid extensions for Ada files are .ads, .adb or .ada
  47 ;;; If the ada-mode does not start automatically, then simply type the
  48 ;;; following command :
  49 ;;;     M-x ada-mode
  50 ;;;
  51 ;;; By default, ada-mode is configured to take full advantage of the GNAT
  52 ;;; compiler (the menus will include the cross-referencing features,...).
  53 ;;; If you are using another compiler, you might want to set the following
  54 ;;; variable in your .emacs (Note: do not set this in the ada-mode-hook, it
  55 ;;; won't work) :
  56 ;;;    (setq ada-which-compiler 'generic)
  57 ;;;
  58 ;;; This mode requires find-file.el to be present on your system.
  59
  60 ;;; History:
  61 ;;; The first Ada mode for GNU Emacs was written by V. Broman in
  62 ;;; 1985. He based his work on the already existing Modula-2 mode.
  63 ;;; This was distributed as ada.el in versions of Emacs prior to 19.29.
  64 ;;;
  65 ;;; Lynn Slater wrote an extensive Ada mode in 1989. It consisted of
  66 ;;; several files with support for dired commands and other nice
  67 ;;; things. It is currently available from the PAL
  68 ;;; (wuarchive.wustl.edu:/languages/ada) as ada-mode-1.06a.tar.Z.
  69 ;;;
  70 ;;; The probably very first Ada mode (called electric-ada.el) was
  71 ;;; written by Steven D. Litvintchouk and Steven M. Rosen for the
  72 ;;; Gosling Emacs. L. Slater based his development on ada.el and
  73 ;;; electric-ada.el.
  74 ;;;
  75 ;;; A complete rewrite by M. Heritsch and R. Ebert has been done.
  76 ;;; Some ideas from the Ada mode mailing list have been
  77 ;;; added.  Some of the functionality of L. Slater's mode has not
  78 ;;; (yet) been recoded in this new mode.  Perhaps you prefer sticking
  79 ;;; to his version.
  80 ;;;
  81 ;;; A complete rewrite for Emacs-20 / Gnat-3.11 has been done by Ada Core
  82 ;;; Technologies. Please send bugs to  briot@gnat.com
  83
  84 ;;; Credits:
  85 ;;;   Many thanks to John McCabe <john@assen.demon.co.uk> for sending so
  86 ;;;     many patches included in this package.
  87 ;;;   Christian Egli <Christian.Egli@hcsd.hac.com>:
  88 ;;;     ada-imenu-generic-expression
  89 ;;;   Many thanks also to the following persons that have contributed one day
  90 ;;;   to the ada-mode
  91 ;;;     Philippe Waroquiers (PW) <philippe@cfmu.eurocontrol.be> in particular,
  92 ;;;     woodruff@stc.llnl.gov (John Woodruff)
  93 ;;;     jj@ddci.dk (Jesper Joergensen)
  94 ;;;     gse@ocsystems.com (Scott Evans)
  95 ;;;     comar@gnat.com (Cyrille Comar)
  96 ;;;     stephen.leake@gsfc.nasa.gov (Stephen Leake)
  97 ;;;    and others for their valuable hints.
  98
  99 ;;; Code:
 100 ;;; Note: Every function in this package is compiler-independent.
 101 ;;; The names start with  ada-
 102 ;;; The variables that the user can edit can all be modified through
 103 ;;;   the customize mode. They are sorted in alphabetical order in this
 104 ;;;   file.
 105
 106
 107 ;; this function is needed at compile time
 108 (eval-and-compile
 109   (defun ada-check-emacs-version (major minor &optional is-xemacs)
 110     "Returns t if Emacs's version is greater or equal to MAJOR.MINOR.
 111 If IS-XEMACS is non-nil, check for XEmacs instead of Emacs."
 112     (let ((xemacs-running (or (string-match "Lucid"  emacs-version)
 113                               (string-match "XEmacs" emacs-version))))
 114       (and (or (and is-xemacs xemacs-running)
 115                (not (or is-xemacs xemacs-running)))
 116            (or (> emacs-major-version major)
 117                (and (= emacs-major-version major)
 118                     (>= emacs-minor-version minor)))))))
 119
 120
 121 ;;  We create a constant for that, for efficiency only
 122 ;;  This should be evaluated both at compile time, only a runtime
 123 (eval-and-compile
 124   (defconst ada-xemacs (and (boundp 'running-xemacs)
 125                             (symbol-value 'running-xemacs))
 126     "Return t if we are using XEmacs."))
 127
 128 (unless ada-xemacs
 129   (require 'outline))
 130
 131 (eval-and-compile
 132   (condition-case nil (require 'find-file) (error nil)))
 133
 134 ;;  This call should not be made in the release that is done for the
 135 ;;  official FSF Emacs, since it does nothing useful for the latest version
 136 ;;  (require 'ada-support)
 137
 138 (defvar ada-mode-hook nil
 139   "*List of functions to call when Ada mode is invoked.
 140 This hook is automatically executed after the ada-mode is
 141 fully loaded.
 142 This is a good place to add Ada environment specific bindings.")
 143
 144 (defgroup ada nil
 145   "Major mode for editing Ada source in Emacs."
 146   :group 'languages)
 147
 148 (defcustom ada-auto-case t
 149   "*Non-nil means automatically change case of preceding word while typing.
 150 Casing is done according to `ada-case-keyword', `ada-case-identifier'
 151 and `ada-case-attribute'."
 152   :type 'boolean :group 'ada)
 153
 154 (defcustom ada-broken-decl-indent 0
 155   "*Number of columns to indent a broken declaration.
 156
 157 An example is :
 158   declare
 159      A,
 160      >>>>>B : Integer;  --  from ada-broken-decl-indent"
 161   :type 'integer :group 'ada)
 162
 163 (defcustom ada-broken-indent 2
 164   "*Number of columns to indent the continuation of a broken line.
 165
 166 An example is :
 167    My_Var : My_Type := (Field1 =>
 168                         >>>>>>>>>Value);  -- from ada-broken-indent"
 169   :type 'integer :group 'ada)
 170
 171 (defcustom ada-case-attribute 'ada-capitalize-word
 172   "*Function to call to adjust the case of Ada attributes.
 173 It may be `downcase-word', `upcase-word', `ada-loose-case-word',
 174 `ada-capitalize-word' or `ada-no-auto-case'."
 175   :type '(choice (const downcase-word)
 176                  (const upcase-word)
 177                  (const ada-capitalize-word)
 178                  (const ada-loose-case-word)
 179                  (const ada-no-auto-case))
 180   :group 'ada)
 181
 182 (defcustom ada-case-exception-file '("~/.emacs_case_exceptions")
 183   "*List of special casing exceptions dictionaries for identifiers.
 184 The first file is the one where new exceptions will be saved by Emacs
 185 when you call `ada-create-case-exception'.
 186
 187 These files should contain one word per line, that gives the casing
 188 to be used for that word in Ada files. Each line can be terminated by
 189 a comment."
 190   :type '(repeat (file))
 191   :group 'ada)
 192
 193 (defcustom ada-case-keyword 'downcase-word
 194   "*Function to call to adjust the case of an Ada keywords.
 195 It may be `downcase-word', `upcase-word', `ada-loose-case-word' or
 196 `ada-capitalize-word'."
 197   :type '(choice (const downcase-word)
 198                  (const upcase-word)
 199                  (const ada-capitalize-word)
 200                  (const ada-loose-case-word)
 201                  (const ada-no-auto-case))
 202   :group 'ada)
 203
 204 (defcustom ada-case-identifier 'ada-loose-case-word
 205   "*Function to call to adjust the case of an Ada identifier.
 206 It may be `downcase-word', `upcase-word', `ada-loose-case-word' or
 207 `ada-capitalize-word'."
 208   :type '(choice (const downcase-word)
 209                  (const upcase-word)
 210                  (const ada-capitalize-word)
 211                  (const ada-loose-case-word)
 212                  (const ada-no-auto-case))
 213   :group 'ada)
 214
 215 (defcustom ada-clean-buffer-before-saving t
 216   "*Non-nil means remove trailing spaces and untabify the buffer before saving."
 217   :type 'boolean :group 'ada)
 218
 219 (defcustom ada-indent 3
 220   "*Size of Ada indentation.
 221
 222 An example is :
 223 procedure Foo is
 224 begin
 225 >>>>>>>>>>null;  --  from ada-indent"
 226   :type 'integer  :group 'ada)
 227
 228 (defcustom ada-indent-after-return t
 229   "*Non-nil means automatically indent after RET or LFD."
 230   :type 'boolean :group 'ada)
 231
 232 (defcustom ada-indent-align-comments t
 233   "*Non-nil means align comments on previous line comments, if any.
 234 If nil, indentation is calculated as usual.
 235 Note that indentation is calculated only if `ada-indent-comment-as-code' is t.
 236
 237 For instance:
 238     A := 1;   --  A multi-line comment
 239               --  aligned if ada-indent-align-comments is t"
 240   :type 'boolean :group 'ada)
 241
 242 (defcustom ada-indent-comment-as-code t
 243   "*Non-nil means indent comment lines as code.
 244 Nil means do not auto-indent comments."
 245   :type 'boolean :group 'ada)
 246
 247 (defcustom ada-indent-is-separate t
 248   "*Non-nil means indent 'is separate' or 'is abstract' if on a single line."
 249   :type 'boolean :group 'ada)
 250
 251 (defcustom ada-indent-record-rel-type 3
 252   "*Indentation for 'record' relative to 'type' or 'use'.
 253
 254 An example is:
 255    type A is
 256    >>>>>>>>>>>record    --  from ada-indent-record-rel-type"
 257   :type 'integer :group 'ada)
 258
 259 (defcustom ada-indent-renames ada-broken-indent
 260   "*Indentation for renames relative to the matching function statement.
 261 If ada-indent-return is null or negative, the indentation is done relative to
 262 the open parenthesis (if there is no parenthesis, ada-broken-indent is used).
 263
 264 An example is:
 265    function A (B : Integer)
 266        return C;      --  from ada-indent-return
 267    >>>renames Foo;    --  from ada-indent-renames"
 268   :type 'integer :group 'ada)
 269
 270 (defcustom ada-indent-return 0
 271   "*Indentation for 'return' relative to the matching 'function' statement.
 272 If ada-indent-return is null or negative, the indentation is done relative to
 273 the open parenthesis (if there is no parenthesis, ada-broken-indent is used).
 274
 275 An example is:
 276    function A (B : Integer)
 277    >>>>>return C;       --  from ada-indent-return"
 278   :type 'integer :group 'ada)
 279
 280 (defcustom ada-indent-to-open-paren t
 281   "*Non-nil means indent according to the innermost open parenthesis."
 282   :type 'boolean :group 'ada)
 283
 284 (defcustom ada-fill-comment-prefix "-- "
 285   "*Text inserted in the first columns when filling a comment paragraph.
 286 Note: if you modify this variable, you will have to restart the ada-mode to
 287 reread this variable."
 288   :type 'string :group 'ada)
 289
 290 (defcustom ada-fill-comment-postfix " --"
 291   "*Text inserted at the end of each line when filling a comment paragraph.
 292 with `ada-fill-comment-paragraph-postfix'."
 293   :type 'string :group 'ada)
 294
 295 (defcustom ada-label-indent -4
 296   "*Number of columns to indent a label.
 297
 298 An example is:
 299 procedure Foo is
 300 begin
 301 >>>>>>>>>>>>Label:  --  from ada-label-indent"
 302   :type 'integer :group 'ada)
 303
 304 (defcustom ada-language-version 'ada95
 305   "*Do we program in `ada83' or `ada95'?"
 306   :type '(choice (const ada83) (const ada95)) :group 'ada)
 307
 308 (defcustom ada-move-to-declaration nil
 309   "*Non-nil means `ada-move-to-start' moves point to the subprogram declaration,
 310 not to 'begin'."
 311   :type 'boolean :group 'ada)
 312
 313 (defcustom ada-popup-key '[down-mouse-3]
 314   "*Key used for binding the contextual menu.
 315 If nil, no contextual menu is available."
 316   :type '(restricted-sexp :match-alternatives (stringp vectorp))
 317   :group 'ada)
 318
 319 (defcustom ada-search-directories
 320   '("." "$ADA_INCLUDE_PATH" "/usr/adainclude" "/usr/local/adainclude"
 321     "/opt/gnu/adainclude")
 322   "*List of directories to search for Ada files.
 323 See the description for the `ff-search-directories' variable.
 324 Emacs will automatically add the paths defined in your project file, and if you
 325 are using the GNAT compiler the output of the gnatls command to find where the
 326 runtime really is."
 327   :type '(repeat (choice :tag "Directory"
 328                          (const :tag "default" nil)
 329                          (directory :format "%v")))
 330   :group 'ada)
 331
 332 (defcustom ada-stmt-end-indent 0
 333   "*Number of columns to indent the end of a statement on a separate line.
 334
 335 An example is:
 336    if A = B
 337    >>>>>>>>>>>then   --  from ada-stmt-end-indent"
 338   :type 'integer :group 'ada)
 339
 340 (defcustom ada-tab-policy 'indent-auto
 341   "*Control the behavior of the TAB key.
 342 Must be one of :
 343 `indent-rigidly' : always adds ada-indent blanks at the beginning of the line.
 344 `indent-auto'    : use indentation functions in this file.
 345 `always-tab'     : do indent-relative."
 346   :type '(choice (const indent-auto)
 347                  (const indent-rigidly)
 348                  (const always-tab))
 349   :group 'ada)
 350
 351 (defcustom ada-use-indent ada-broken-indent
 352   "*Indentation for the lines in a 'use' statement.
 353
 354 An example is:
 355    use Ada.Text_IO,
 356    >>>>>Ada.Numerics;    --  from ada-use-indent"
 357   :type 'integer :group 'ada)
 358
 359 (defcustom ada-when-indent 3
 360   "*Indentation for 'when' relative to 'exception' or 'case'.
 361
 362 An example is:
 363    case A is
 364    >>>>>>>>when B =>     --  from ada-when-indent"
 365   :type 'integer :group 'ada)
 366
 367 (defcustom ada-with-indent ada-broken-indent
 368   "*Indentation for the lines in a 'with' statement.
 369
 370 An example is:
 371    with Ada.Text_IO,
 372    >>>>>Ada.Numerics;    --  from ada-with-indent"
 373   :type 'integer :group 'ada)
 374
 375 (defcustom ada-which-compiler 'gnat
 376   "*Name of the compiler to use.
 377 This will determine what features are made available through the ada-mode.
 378 The possible choices are :
 379 `gnat': Use Ada Core Technologies' Gnat compiler. Add some cross-referencing
 380     features
 381 `generic': Use a generic compiler"
 382   :type '(choice (const gnat)
 383                  (const generic))
 384   :group 'ada)
 385
 386
 387 ;;; ---- end of user configurable variables
 388 \f
 389
 390 (defvar ada-body-suffixes '(".adb")
 391   "List of possible suffixes for Ada body files.
 392 The extensions should include a `.' if needed.")
 393
 394 (defvar ada-spec-suffixes '(".ads")
 395   "List of possible suffixes for Ada spec files.
 396 The extensions should include a `.' if needed.")
 397
 398 (defvar ada-mode-menu (make-sparse-keymap "Ada")
 399   "Menu for ada-mode.")
 400
 401 (defvar ada-mode-map (make-sparse-keymap)
 402   "Local keymap used for Ada mode.")
 403
 404 (defvar ada-mode-abbrev-table nil
 405   "Local abbrev table for Ada mode.")
 406
 407 (defvar ada-mode-syntax-table nil
 408   "Syntax table to be used for editing Ada source code.")
 409
 410 (defvar ada-mode-symbol-syntax-table nil
 411   "Syntax table for Ada, where `_' is a word constituent.")
 412
 413 (eval-when-compile
 414   (defconst ada-83-string-keywords
 415     '("abort" "abs" "accept" "access" "all" "and" "array" "at" "begin"
 416       "body" "case" "constant" "declare" "delay" "delta" "digits" "do"
 417       "else" "elsif" "end" "entry" "exception" "exit" "for" "function"
 418       "generic" "goto" "if" "in" "is" "limited" "loop" "mod" "new"
 419       "not" "null" "of" "or" "others" "out" "package" "pragma" "private"
 420       "procedure" "raise" "range" "record" "rem" "renames" "return"
 421       "reverse" "select" "separate" "subtype" "task" "terminate" "then"
 422       "type" "use" "when" "while" "with" "xor")
 423     "List of Ada keywords.
 424 This variable is used to define `ada-83-keywords' and `ada-95-keywords'"))
 425
 426 (defvar ada-ret-binding nil
 427   "Variable to save key binding of RET when casing is activated.")
 428
 429 (defvar ada-case-exception '()
 430   "Alist of words (entities) that have special casing.")
 431
 432 (defvar ada-lfd-binding nil
 433   "Variable to save key binding of LFD when casing is activated.")
 434
 435 (defvar ada-other-file-alist nil
 436   "Variable used by find-file to find the name of the other package.
 437 See `ff-other-file-alist'.")
 438
 439 ;;; ---- Below are the regexp used in this package for parsing
 440
 441 (defconst ada-83-keywords
 442   (eval-when-compile
 443     (concat "\\<" (regexp-opt ada-83-string-keywords t) "\\>"))
 444   "Regular expression for looking at Ada83 keywords.")
 445
 446 (defconst ada-95-keywords
 447   (eval-when-compile
 448     (concat "\\<" (regexp-opt
 449                    (append
 450                     '("abstract" "aliased" "protected" "requeue"
 451                       "tagged" "until")
 452                     ada-83-string-keywords) t) "\\>"))
 453   "Regular expression for looking at Ada95 keywords.")
 454
 455 (defvar ada-keywords ada-95-keywords
 456   "Regular expression for looking at Ada keywords.")
 457
 458 (defconst ada-ident-re
 459   "\\(\\sw\\|[_.]\\)+"
 460   "Regexp matching Ada (qualified) identifiers.")
 461
 462 (defvar ada-procedure-start-regexp
 463   "^[ \t]*\\(procedure\\|function\\|task\\)[ \t\n]+\\(\\(\\sw\\|[_.]\\)+\\)"
 464   "Regexp used to find Ada procedures/functions.")
 465
 466 (defvar ada-package-start-regexp
 467   "^[ \t]*\\(package\\)"
 468   "Regexp used to find Ada packages.")
 469
 470
 471 ;;; ---- regexps for indentation functions
 472
 473 (defvar ada-block-start-re
 474   (eval-when-compile
 475     (concat "\\<\\(" (regexp-opt '("begin" "declare" "else"
 476                                    "exception" "generic" "loop" "or"
 477                                    "private" "select" ))
 478             "\\|\\(\\(limited\\|abstract\\|tagged\\)[ \t\n]+\\)*record\\)\\>"))
 479   "Regexp for keywords starting Ada blocks.")
 480
 481 (defvar ada-end-stmt-re
 482   (eval-when-compile
 483     (concat "\\("
 484             ";"                                        "\\|"
 485             "=>[ \t]*$"                                "\\|"
 486             "^[ \t]*separate[ \t]*(\\(\\sw\\|[_.]\\)+)"  "\\|"
 487             "\\<" (regexp-opt '("begin" "declare" "is" "do" "else" "generic"
 488                                 "loop" "private" "record" "select"
 489                                 "then abort" "then") t) "\\>"  "\\|"
 490             "^[ \t]*" (regexp-opt '("function" "package" "procedure")
 491                                   t) "\\>\\(\\sw\\|[ \t_.]\\)+\\<is\\>"        "\\|"
 492             "^[ \t]*exception\\>"
 493             "\\)")                      )
 494   "Regexp of possible ends for a non-broken statement.
 495 A new statement starts after these.")
 496
 497 (defvar ada-matching-start-re
 498   (eval-when-compile
 499     (concat "\\<"
 500             (regexp-opt
 501              '("end" "loop" "select" "begin" "case" "do"
 502                "if" "task" "package" "record" "protected") t)
 503             "\\>"))
 504   "Regexp used in ada-goto-matching-start.")
 505
 506 (defvar ada-matching-decl-start-re
 507   (eval-when-compile
 508     (concat "\\<"
 509             (regexp-opt
 510              '("is" "separate" "end" "declare" "if" "new" "begin" "generic" "when") t)
 511             "\\>"))
 512   "Regexp used in ada-goto-matching-decl-start.")
 513
 514 (defvar ada-loop-start-re
 515   "\\<\\(for\\|while\\|loop\\)\\>"
 516   "Regexp for the start of a loop.")
 517
 518 (defvar ada-subprog-start-re
 519   (eval-when-compile
 520     (concat "\\<" (regexp-opt '("accept" "entry" "function" "package" "procedure"
 521                                 "protected" "task") t) "\\>"))
 522   "Regexp for the start of a subprogram.")
 523
 524 (defvar ada-named-block-re
 525   "[ \t]*\\(\\sw\\|_\\)+[ \t]*:[^=]"
 526   "Regexp of the name of a block or loop.")
 527
 528 (defvar ada-contextual-menu-on-identifier nil
 529   "Set to true when the right mouse button was clicked on an identifier.")
 530
 531 (defvar ada-contextual-menu-last-point nil
 532   "Position of point just before displaying the menu.
 533 This is a list (point buffer).
 534 Since `ada-popup-menu' moves the point where the user clicked, the region
 535 is modified. Therefore no command from the menu knows what the user selected
 536 before displaying the contextual menu.
 537 To get the original region, restore the point to this position before
 538 calling `region-end' and `region-beginning'.
 539 Modify this variable if you want to restore the point to another position.")
 540
 541 (defvar ada-contextual-menu
 542   (if ada-xemacs
 543       '("Ada"
 544         ["Goto Declaration/Body"
 545          (ada-call-from-contextual-menu 'ada-point-and-xref)
 546          :included (and (functionp 'ada-point-and-xref)
 547                         ada-contextual-menu-on-identifier)]
 548         ["Goto Previous Reference"
 549          (ada-call-from-contextual-menu 'ada-xref-goto-previous-reference)
 550          :included (functionp 'ada-xref-goto-previous-reference)]
 551         ["List References" ada-find-references
 552          :included ada-contextual-menu-on-identifier]
 553         ["-" nil nil]
 554         ["Other File" ff-find-other-file]
 555         ["Goto Parent Unit" ada-goto-parent]
 556         )
 557
 558     (let ((map (make-sparse-keymap "Ada")))
 559       ;; The identifier part
 560       (if (equal ada-which-compiler 'gnat)
 561           (progn
 562             (define-key-after map [Ref]
 563               '(menu-item "Goto Declaration/Body"
 564                           (lambda()(interactive)
 565                             (ada-call-from-contextual-menu
 566                              'ada-point-and-xref))
 567                           :visible
 568                           (and (functionp 'ada-point-and-xref)
 569                                ada-contextual-menu-on-identifier))
 570               t)
 571             (define-key-after map [Prev]
 572               '(menu-item "Goto Previous Reference"
 573                           (lambda()(interactive)
 574                             (ada-call-from-contextual-menu
 575                              'ada-xref-goto-previous-reference))
 576                           :visible
 577                           (functionp 'ada-xref-goto-previous-reference))
 578               t)
 579             (define-key-after map [List]
 580               '(menu-item "List References"
 581                           ada-find-references
 582                           :visible ada-contextual-menu-on-identifier) t)
 583             (define-key-after map [-] '("-" nil) t)
 584             ))
 585       (define-key-after map [Other] '("Other file" . ff-find-other-file) t)
 586       (define-key-after map [Parent] '("Goto Parent Unit" . ada-goto-parent)t)
 587       map))
 588   "Defines the menu to use when the user presses the right mouse button.
 589 The variable `ada-contextual-menu-on-identifier' will be set to t before
 590 displaying the menu if point was on an identifier."
 591   )
 592
 593 \f
 594 ;;------------------------------------------------------------------
 595 ;; Support for imenu  (see imenu.el)
 596 ;;------------------------------------------------------------------
 597
 598 (defconst ada-imenu-subprogram-menu-re
 599   "^[ \t]*\\(procedure\\|function\\)[ \t\n]+\\(\\(\\sw\\|_\\)+\\)[ \t\n]*\\([ \t\n]\\|([^)]+)\\)[ \t\n]*\\(return[ \t\n]+\\(\\sw\\|[_.]\\)+[ \t\n]*\\)?is[ \t\n]")
 600
 601 (defvar ada-imenu-generic-expression
 602   (list
 603    (list nil ada-imenu-subprogram-menu-re 2)
 604    (list "*Specs*"
 605          (concat
 606           "^[ \t]*\\(procedure\\|function\\)[ \t\n]+\\(\\(\\sw\\|_\\)+\\)"
 607           "\\("
 608           "\\([ \t\n]+\\|[ \t\n]*([^)]+)\\)";; parameter list or simple space
 609           "\\([ \t\n]*return[ \t\n]+\\(\\sw\\|[_.]\\)+[ \t\n]*\\)?"
 610           "\\)?;") 2)
 611    '("*Tasks*" "^[ \t]*task[ \t]+\\(\\(body\\|type\\)[ \t]+\\)?\\(\\(\\sw\\|_\\)+\\)" 3)
 612    '("*Type Defs*" "^[ \t]*\\(sub\\)?type[ \t]+\\(\\(\\sw\\|_\\)+\\)" 2)
 613    '("*Packages*" "^[ \t]*package[ \t]+\\(\\(body[ \t]+\\)?\\(\\sw\\|[_.]\\)+\\)" 1))
 614   "Imenu generic expression for Ada mode.
 615 See `imenu-generic-expression'. This variable will create two submenus, one
 616 for type and subtype definitions, the other for subprograms declarations.
 617 The main menu will reference the bodies of the subprograms.")
 618
 619
 620 \f
 621 ;;------------------------------------------------------------
 622 ;;  Support for compile.el
 623 ;;------------------------------------------------------------
 624
 625 (defun ada-compile-mouse-goto-error ()
 626   "Mouse interface for ada-compile-goto-error."
 627   (interactive)
 628   (mouse-set-point last-input-event)
 629   (ada-compile-goto-error (point))
 630   )
 631
 632 (defun ada-compile-goto-error (pos)
 633   "Replaces `compile-goto-error' from compile.el.
 634 If POS is on a file and line location, go to this position. It adds to
 635 compile.el the capacity to go to a reference in an error message.
 636 For instance, on this line:
 637   foo.adb:61:11:  [...] in call to size declared at foo.ads:11
 638 both file locations can be clicked on and jumped to."
 639   (interactive "d")
 640   (goto-char pos)
 641
 642   (skip-chars-backward "-a-zA-Z0-9_:./\\")
 643   (cond
 644    ;;  special case: looking at a filename:line not at the beginning of a line
 645    ((and (not (bolp))
 646          (looking-at
 647           "\\([-_.a-zA-Z0-9]+\\):\\([0-9]+\\)\\(:\\([0-9]+\\)\\)?"))
 648     (let ((line (match-string 2))
 649           (error-pos (point-marker))
 650           source)
 651       (save-excursion
 652         (save-restriction
 653           (widen)
 654           ;;  Use funcall so as to prevent byte-compiler warnings
 655           (set-buffer (funcall (symbol-function 'compilation-find-file)
 656                                (point-marker) (match-string 1)
 657                                "./"))
 658           (if (stringp line)
 659               (goto-line (string-to-number line)))
 660           (setq source (point-marker))))
 661       (funcall (symbol-function 'compilation-goto-locus)
 662                (cons source error-pos))
 663       ))
 664
 665    ;; otherwise, default behavior
 666    (t
 667     (funcall (symbol-function 'compile-goto-error)))
 668    )
 669   (recenter))
 670
 671 \f
 672 ;;-------------------------------------------------------------------------
 673 ;; Grammar related function
 674 ;; The functions below work with the syntax class of the characters in an Ada
 675 ;; buffer. Two syntax tables are created, depending on whether we want '_'
 676 ;; to be considered as part of a word or not.
 677 ;; Some characters may have multiple meanings depending on the context:
 678 ;;  - ' is either the beginning of a constant character or an attribute
 679 ;;  - # is either part of a based litteral or a gnatprep statement.
 680 ;;  - " starts a string, but not if inside a constant character.
 681 ;;  - ( and ) should be ignored if inside a constant character.
 682 ;; Thus their syntax property is changed automatically, and we can still use
 683 ;; the standard Emacs functions for sexp (see `ada-in-string-p')
 684 ;;
 685 ;; On Emacs, this is done through the `syntax-table' text property. The
 686 ;; modification is done automatically each time the user as typed a new
 687 ;; character. This is already done in `font-lock-mode' (in
 688 ;; `font-lock-syntactic-keywords', so we take advantage of the existing
 689 ;; mechanism. If font-lock-mode is not activated, we do it by hand in
 690 ;; `ada-after-change-function', thanks to `ada-deactivate-properties' and
 691 ;; `ada-initialize-properties'.
 692 ;;
 693 ;; on XEmacs, the `syntax-table' property does not exist and we have to use a
 694 ;; slow advice to `parse-partial-sexp' to do the same thing.
 695 ;; When executing parse-partial-sexp, we simply modify the strings before and
 696 ;; after, so that the special constants '"', '(' and ')' do not interact
 697 ;; with parse-partial-sexp.
 698 ;; Note: this code is slow and needs to be rewritten as soon as something
 699 ;; better is available on XEmacs.
 700 ;;-------------------------------------------------------------------------
 701
 702 (defun ada-create-syntax-table ()
 703   "Create the two syntax tables use in the Ada mode.
 704 The standard table declares `_' as a symbol constituent, the second one
 705 declares it as a word constituent."
 706   (interactive)
 707   (setq ada-mode-syntax-table (make-syntax-table))
 708   (set-syntax-table  ada-mode-syntax-table)
 709
 710   ;; define string brackets (`%' is alternative string bracket, but
 711   ;; almost never used as such and throws font-lock and indentation
 712   ;; off the track.)
 713   (modify-syntax-entry ?%  "$" ada-mode-syntax-table)
 714   (modify-syntax-entry ?\" "\"" ada-mode-syntax-table)
 715
 716   (modify-syntax-entry ?:  "." ada-mode-syntax-table)
 717   (modify-syntax-entry ?\; "." ada-mode-syntax-table)
 718   (modify-syntax-entry ?&  "." ada-mode-syntax-table)
 719   (modify-syntax-entry ?\|  "." ada-mode-syntax-table)
 720   (modify-syntax-entry ?+  "." ada-mode-syntax-table)
 721   (modify-syntax-entry ?*  "." ada-mode-syntax-table)
 722   (modify-syntax-entry ?/  "." ada-mode-syntax-table)
 723   (modify-syntax-entry ?=  "." ada-mode-syntax-table)
 724   (modify-syntax-entry ?<  "." ada-mode-syntax-table)
 725   (modify-syntax-entry ?>  "." ada-mode-syntax-table)
 726   (modify-syntax-entry ?$ "." ada-mode-syntax-table)
 727   (modify-syntax-entry ?\[ "." ada-mode-syntax-table)
 728   (modify-syntax-entry ?\] "." ada-mode-syntax-table)
 729   (modify-syntax-entry ?\{ "." ada-mode-syntax-table)
 730   (modify-syntax-entry ?\} "." ada-mode-syntax-table)
 731   (modify-syntax-entry ?. "." ada-mode-syntax-table)
 732   (modify-syntax-entry ?\\ "." ada-mode-syntax-table)
 733   (modify-syntax-entry ?\' "." ada-mode-syntax-table)
 734
 735   ;; a single hyphen is punctuation, but a double hyphen starts a comment
 736   (modify-syntax-entry ?-  ". 12" ada-mode-syntax-table)
 737
 738   ;; See the comment above on grammar related function for the special
 739   ;; setup for '#'.
 740   (if ada-xemacs
 741       (modify-syntax-entry ?#  "<" ada-mode-syntax-table)
 742     (modify-syntax-entry ?#  "$" ada-mode-syntax-table))
 743
 744   ;; and \f and \n end a comment
 745   (modify-syntax-entry ?\f  ">   " ada-mode-syntax-table)
 746   (modify-syntax-entry ?\n  ">   " ada-mode-syntax-table)
 747
 748   ;; define what belongs in Ada symbols
 749   (modify-syntax-entry ?_ "_" ada-mode-syntax-table)
 750
 751   ;; define parentheses to match
 752   (modify-syntax-entry ?\( "()" ada-mode-syntax-table)
 753   (modify-syntax-entry ?\) ")(" ada-mode-syntax-table)
 754
 755   (setq ada-mode-symbol-syntax-table (copy-syntax-table ada-mode-syntax-table))
 756   (modify-syntax-entry ?_ "w" ada-mode-symbol-syntax-table)
 757   )
 758
 759 ;;  Support of special characters in XEmacs (see the comments at the beginning
 760 ;;  of the section on Grammar related functions).
 761
 762 (if ada-xemacs
 763     (defadvice parse-partial-sexp (around parse-partial-sexp-protect-constants)
 764       "Handles special character constants and gnatprep statements."
 765       (let (change)
 766         (if (< to from)
 767             (let ((tmp from))
 768               (setq from to  to tmp)))
 769         (save-excursion
 770           (goto-char from)
 771           (while (re-search-forward "'\\([(\")#]\\)'" to t)
 772             (setq change (cons (list (match-beginning 1)
 773                                      1
 774                                      (match-string 1))
 775                                change))
 776             (replace-match "'A'"))
 777           (goto-char from)
 778           (while (re-search-forward "\\(#[0-9a-fA-F]*#\\)" to t)
 779             (setq change (cons (list (match-beginning 1)
 780                                      (length (match-string 1))
 781                                      (match-string 1))
 782                                change))
 783             (replace-match (make-string (length (match-string 1)) ?@))))
 784         ad-do-it
 785         (save-excursion
 786           (while change
 787             (goto-char (caar change))
 788             (delete-char (cadar change))
 789             (insert (caddar change))
 790             (setq change (cdr change)))))))
 791
 792 (defun ada-deactivate-properties ()
 793   "Deactivate ada-mode's properties handling.
 794 This would be a duplicate of font-lock if both are used at the same time."
 795   (remove-hook 'after-change-functions 'ada-after-change-function t))
 796
 797 (defun ada-initialize-properties ()
 798   "Initialize some special text properties in the whole buffer.
 799 In particular, character constants are said to be strings, #...# are treated
 800 as numbers instead of gnatprep comments."
 801   (save-excursion
 802     (save-restriction
 803       (widen)
 804       (goto-char (point-min))
 805       (while (re-search-forward "'.'" nil t)
 806         (add-text-properties (match-beginning 0) (match-end 0)
 807                              '(syntax-table ("'" . ?\"))))
 808       (goto-char (point-min))
 809       (while (re-search-forward "^[ \t]*#" nil t)
 810         (add-text-properties (match-beginning 0) (match-end 0)
 811                              '(syntax-table (11 . 10))))
 812       (set-buffer-modified-p nil)
 813
 814       ;;  Setting this only if font-lock is not set won't work
 815       ;;  if the user activates or deactivates font-lock-mode,
 816       ;;  but will make things faster most of the time
 817       (make-local-hook 'after-change-functions)
 818       (add-hook 'after-change-functions 'ada-after-change-function nil t)
 819       )))
 820
 821 (defun ada-after-change-function (beg end old-len)
 822   "Called when the region between BEG and END was changed in the buffer.
 823 OLD-LEN indicates what the length of the replaced text was."
 824   (let ((inhibit-point-motion-hooks t)
 825         (eol (point)))
 826     (save-excursion
 827       (save-match-data
 828         (beginning-of-line)
 829         (remove-text-properties (point) eol '(syntax-table nil))
 830         (while (re-search-forward "'.'" eol t)
 831           (add-text-properties (match-beginning 0) (match-end 0)
 832                                '(syntax-table ("'" . ?\"))))
 833         (beginning-of-line)
 834         (if (looking-at "^[ \t]*#")
 835             (add-text-properties (match-beginning 0) (match-end 0)
 836                                  '(syntax-table (11 . 10))))
 837         ))))
 838
 839 ;;------------------------------------------------------------------
 840 ;;  Testing the grammatical context
 841 ;;------------------------------------------------------------------
 842
 843 (defsubst ada-in-comment-p (&optional parse-result)
 844   "Returns t if inside a comment."
 845   (nth 4 (or parse-result
 846              (parse-partial-sexp
 847               (save-excursion (beginning-of-line) (point)) (point)))))
 848
 849 (defsubst ada-in-string-p (&optional parse-result)
 850   "Returns t if point is inside a string.
 851 If parse-result is non-nil, use is instead of calling parse-partial-sexp."
 852   (nth 3 (or parse-result
 853              (parse-partial-sexp
 854               (save-excursion (beginning-of-line) (point)) (point)))))
 855
 856 (defsubst ada-in-string-or-comment-p (&optional parse-result)
 857   "Returns t if inside a comment or string."
 858   (setq parse-result (or parse-result
 859                          (parse-partial-sexp
 860                           (save-excursion (beginning-of-line) (point)) (point))))
 861   (or (ada-in-string-p parse-result) (ada-in-comment-p parse-result)))
 862
 863
 864 ;;------------------------------------------------------------------
 865 ;; Contextual menus
 866 ;; The Ada-mode comes with contextual menus, bound by default to the right
 867 ;; mouse button.
 868 ;; Add items to this menu by modifying `ada-contextual-menu'. Note that the
 869 ;; variable `ada-contextual-menu-on-identifier' is set automatically to t
 870 ;; if the mouse button was pressed on an identifier.
 871 ;;------------------------------------------------------------------
 872
 873 (defun ada-call-from-contextual-menu (function)
 874   "Execute FUNCTION when called from the contextual menu.
 875 It forces Emacs to change the cursor position."
 876   (interactive)
 877   (funcall function)
 878   (setq ada-contextual-menu-last-point
 879         (list (point) (current-buffer))))
 880
 881 (defun ada-popup-menu (position)
 882   "Pops up a contextual menu, depending on where the user clicked.
 883 POSITION is the location the mouse was clicked on.
 884 Sets `ada-contextual-menu-last-point' to the current position before
 885 displaying the menu. When a function from the menu is called, the point is
 886 where the mouse button was clicked."
 887   (interactive "e")
 888
 889   ;;  declare this as a local variable, so that the function called
 890   ;;  in the contextual menu does not hide the region in
 891   ;;  transient-mark-mode.
 892   (let ((deactivate-mark nil))
 893     (setq ada-contextual-menu-last-point
 894          (list (point) (current-buffer)))
 895     (mouse-set-point last-input-event)
 896
 897     (setq ada-contextual-menu-on-identifier
 898           (and (char-after)
 899                (or (= (char-syntax (char-after)) ?w)
 900                    (= (char-after) ?_))
 901                (not (ada-in-string-or-comment-p))
 902                (save-excursion (skip-syntax-forward "w")
 903                                (not (ada-after-keyword-p)))
 904                ))
 905     (let (choice)
 906       (if ada-xemacs
 907           (setq choice (funcall (symbol-function 'popup-menu)
 908                                 ada-contextual-menu))
 909         (setq choice (x-popup-menu position ada-contextual-menu)))
 910       (if choice
 911           (funcall (lookup-key ada-contextual-menu (vector (car choice))))))
 912     (set-buffer (cadr ada-contextual-menu-last-point))
 913     (goto-char (car ada-contextual-menu-last-point))
 914     ))
 915
 916
 917 ;;------------------------------------------------------------------
 918 ;; Misc functions
 919 ;;------------------------------------------------------------------
 920
 921 ;;;###autoload
 922 (defun ada-add-extensions (spec body)
 923   "Define SPEC and BODY as being valid extensions for Ada files.
 924 Going from body to spec with `ff-find-other-file' used these
 925 extensions.
 926 SPEC and BODY are two regular expressions that must match against the file
 927 name"
 928   (let* ((reg (concat (regexp-quote body) "$"))
 929          (tmp (assoc reg ada-other-file-alist)))
 930     (if tmp
 931         (setcdr tmp (list (cons spec (cadr tmp))))
 932       (add-to-list 'ada-other-file-alist (list reg (list spec)))))
 933
 934   (let* ((reg (concat (regexp-quote spec) "$"))
 935          (tmp (assoc reg ada-other-file-alist)))
 936     (if tmp
 937         (setcdr tmp (list (cons body (cadr tmp))))
 938       (add-to-list 'ada-other-file-alist (list reg (list body)))))
 939
 940   (add-to-list 'auto-mode-alist (cons spec 'ada-mode))
 941   (add-to-list 'auto-mode-alist (cons body 'ada-mode))
 942
 943   (add-to-list 'ada-spec-suffixes spec)
 944   (add-to-list 'ada-body-suffixes body)
 945
 946   ;; Support for speedbar (Specifies that we want to see these files in
 947   ;; speedbar)
 948   (condition-case nil
 949       (progn
 950         (require 'speedbar)
 951         (funcall (symbol-function 'speedbar-add-supported-extension)
 952                  spec)
 953         (funcall (symbol-function 'speedbar-add-supported-extension)
 954                  body)))
 955   )
 956
 957
 958 ;;;###autoload
 959 (defun ada-mode ()
 960   "Ada mode is the major mode for editing Ada code.
 961
 962 Bindings are as follows: (Note: 'LFD' is control-j.)
 963
 964  Indent line                                          '\\[ada-tab]'
 965  Indent line, insert newline and indent the new line. '\\[newline-and-indent]'
 966
 967  Re-format the parameter-list point is in             '\\[ada-format-paramlist]'
 968  Indent all lines in region                           '\\[ada-indent-region]'
 969
 970  Adjust case of identifiers and keywords in region    '\\[ada-adjust-case-region]'
 971  Adjust case of identifiers and keywords in buffer    '\\[ada-adjust-case-buffer]'
 972
 973  Fill comment paragraph, justify and append postfix   '\\[fill-paragraph]'
 974
 975  Next func/proc/task '\\[ada-next-procedure]'  Previous func/proc/task '\\[ada-previous-procedure]'
 976  Next package        '\\[ada-next-package]'  Previous package        '\\[ada-previous-package]'
 977
 978  Goto matching start of current 'end ...;'            '\\[ada-move-to-start]'
 979  Goto end of current block                            '\\[ada-move-to-end]'
 980
 981 Comments are handled using standard GNU Emacs conventions, including:
 982  Start a comment                                      '\\[indent-for-comment]'
 983  Comment region                                       '\\[comment-region]'
 984  Uncomment region                                     '\\[ada-uncomment-region]'
 985  Continue comment on next line                        '\\[indent-new-comment-line]'
 986
 987 If you use imenu.el:
 988  Display index-menu of functions & procedures         '\\[imenu]'
 989
 990 If you use find-file.el:
 991  Switch to other file (Body <-> Spec)                 '\\[ff-find-other-file]'
 992                                                    or '\\[ff-mouse-find-other-file]
 993  Switch to other file in other window                 '\\[ada-ff-other-window]'
 994                                                    or '\\[ff-mouse-find-other-file-other-window]
 995  If you use this function in a spec and no body is available, it gets created with body stubs.
 996
 997 If you use ada-xref.el:
 998  Goto declaration:          '\\[ada-point-and-xref]' on the identifier
 999                          or '\\[ada-goto-declaration]' with point on the identifier
1000  Complete identifier:       '\\[ada-complete-identifier]'."
1001
1002   (interactive)
1003   (kill-all-local-variables)
1004
1005   (set (make-local-variable 'require-final-newline) t)
1006
1007   (make-local-variable 'comment-start)
1008   (if ada-fill-comment-prefix
1009       (setq comment-start ada-fill-comment-prefix)
1010     (setq comment-start "-- "))
1011
1012   ;;  Set the paragraph delimiters so that one can select a whole block
1013   ;;  simply with M-h
1014   (set (make-local-variable 'paragraph-start) "[ \t\n\f]*$")
1015   (set (make-local-variable 'paragraph-separate) "[ \t\n\f]*$")
1016
1017   ;; comment end must be set because it may hold a wrong value if
1018   ;; this buffer had been in another mode before. RE
1019   (set (make-local-variable 'comment-end) "")
1020
1021   ;; used by autofill and indent-new-comment-line
1022   (set (make-local-variable 'comment-start-skip) "---*[ \t]*")
1023
1024   ;; used by autofill to break a comment line and continue it on another line.
1025   ;; The reason we need this one is that the default behavior does not work
1026   ;; correctly with the definition of paragraph-start above when the comment
1027   ;; is right after a multi-line subprogram declaration (the comments are
1028   ;; aligned under the latest parameter, not under the declaration start).
1029   (set (make-local-variable 'comment-line-break-function)
1030        (lambda (&optional soft) (let ((fill-prefix nil))
1031                                   (indent-new-comment-line soft))))
1032
1033   (set (make-local-variable 'indent-line-function)
1034        'ada-indent-current-function)
1035
1036   (set (make-local-variable 'comment-column) 40)
1037
1038   ;;  Emacs 20.3 defines a comment-padding to insert spaces between
1039   ;;  the comment and the text. We do not want any, this is already
1040   ;;  included in comment-start
1041   (unless ada-xemacs
1042     (progn
1043       (if (ada-check-emacs-version 20 3)
1044           (progn
1045             (set (make-local-variable 'parse-sexp-ignore-comments) t)
1046             (set (make-local-variable 'comment-padding) 0)))
1047       (set (make-local-variable 'parse-sexp-lookup-properties) t)
1048       ))
1049
1050   (setq case-fold-search t)
1051   (if (boundp 'imenu-case-fold-search)
1052       (setq imenu-case-fold-search t))
1053
1054   (set (make-local-variable 'fill-paragraph-function)
1055        'ada-fill-comment-paragraph)
1056
1057   (set (make-local-variable 'imenu-generic-expression)
1058        ada-imenu-generic-expression)
1059
1060   ;;  Support for compile.el
1061   ;;  We just substitute our own functions to go to the error.
1062   (add-hook 'compilation-mode-hook
1063             (lambda()
1064               (setq compile-auto-highlight 40)
1065               (define-key compilation-minor-mode-map [mouse-2]
1066                 'ada-compile-mouse-goto-error)
1067               (define-key compilation-minor-mode-map "\C-c\C-c"
1068                 'ada-compile-goto-error)
1069               (define-key compilation-minor-mode-map "\C-m"
1070                 'ada-compile-goto-error)
1071               ))
1072
1073   ;;  font-lock support :
1074   ;;  We need to set some properties for XEmacs, and define some variables
1075   ;;  for Emacs
1076
1077   (if ada-xemacs
1078       ;;  XEmacs
1079       (put 'ada-mode 'font-lock-defaults
1080            '(ada-font-lock-keywords
1081              nil t ((?\_ . "w") (?# . ".")) beginning-of-line))
1082     ;;  Emacs
1083     (set (make-local-variable 'font-lock-defaults)
1084          '(ada-font-lock-keywords
1085            nil t
1086            ((?\_ . "w") (?# . "."))
1087            beginning-of-line
1088            (font-lock-syntactic-keywords . ada-font-lock-syntactic-keywords)))
1089     )
1090
1091   ;; Set up support for find-file.el.
1092   (set (make-variable-buffer-local 'ff-other-file-alist)
1093        'ada-other-file-alist)
1094   (set (make-variable-buffer-local 'ff-search-directories)
1095        'ada-search-directories)
1096   (setq ff-post-load-hooks    'ada-set-point-accordingly
1097         ff-file-created-hooks 'ada-make-body)
1098   (add-hook 'ff-pre-load-hooks 'ada-which-function-are-we-in)
1099
1100   ;; Some special constructs for find-file.el
1101   ;; We do not need to add the construction for 'with', which is in the
1102   ;; standard find-file.el
1103   (make-local-variable 'ff-special-constructs)
1104
1105   ;; Go to the parent package :
1106   (add-to-list 'ff-special-constructs
1107                (cons (eval-when-compile
1108                        (concat "^\\(private[ \t]\\)?[ \t]*package[ \t]+"
1109                                "\\(body[ \t]+\\)?"
1110                                "\\(\\(\\sw\\|[_.]\\)+\\)\\.\\(\\sw\\|_\\)+[ \t\n]+is"))
1111                      (lambda ()
1112                        (setq fname (ff-get-file
1113                                     ada-search-directories
1114                                     (ada-make-filename-from-adaname
1115                                      (match-string 3))
1116                                     ada-spec-suffixes)))))
1117   ;; Another special construct for find-file.el : when in a separate clause,
1118   ;; go to the correct package.
1119   (add-to-list 'ff-special-constructs
1120                (cons "^separate[ \t\n]*(\\(\\(\\sw\\|[_.]\\)+\\))"
1121                      (lambda ()
1122                        (setq fname (ff-get-file
1123                                     ada-search-directories
1124                                     (ada-make-filename-from-adaname
1125                                      (match-string 1))
1126                                     ada-spec-suffixes)))))
1127   ;; Another special construct, that redefines the one in find-file.el. The
1128   ;; old one can handle only one possible type of extension for Ada files
1129   ;;  remove from the list the standard "with..." that is put by find-file.el,
1130   ;;  since it uses the old ada-spec-suffix variable
1131   ;; This one needs to replace the standard one defined in find-file.el (with
1132   ;;  Emacs <= 20.4), since that one uses the old variable ada-spec-suffix
1133   (let ((old-construct
1134          (assoc "^with[ \t]+\\([a-zA-Z0-9_\\.]+\\)" ff-special-constructs))
1135         (new-cdr
1136          (lambda ()
1137            (setq fname (ff-get-file
1138                         ada-search-directories
1139                         (ada-make-filename-from-adaname
1140                          (match-string 1))
1141                         ada-spec-suffixes)))))
1142     (if old-construct
1143         (setcdr old-construct new-cdr)
1144       (add-to-list 'ff-special-constructs
1145                    (cons "^with[ \t]+\\([a-zA-Z0-9_\\.]+\\)"
1146                          new-cdr))))
1147
1148   ;;  Support for outline-minor-mode
1149   (set (make-local-variable 'outline-regexp)
1150        "\\([ \t]*\\(procedure\\|function\\|package\\|if\\|while\\|for\\|declare\\|case\\|end\\|begin\\|loop\\)\\|--\\)")
1151   (set (make-local-variable 'outline-level) 'ada-outline-level)
1152
1153   ;;  Support for imenu : We want a sorted index
1154   (setq imenu-sort-function 'imenu--sort-by-name)
1155
1156   ;;  Support for which-function-mode is provided in ada-support (support
1157   ;;  for nested subprograms)
1158
1159   ;;  Set up the contextual menu
1160   (if ada-popup-key
1161       (define-key ada-mode-map ada-popup-key 'ada-popup-menu))
1162
1163   ;;  Support for Abbreviations (the user still need to "M-x abbrev-mode"
1164   (define-abbrev-table 'ada-mode-abbrev-table ())
1165   (setq local-abbrev-table ada-mode-abbrev-table)
1166
1167   ;;  Support for indent-new-comment-line (Especially for XEmacs)
1168   (setq comment-multi-line nil)
1169   (defconst comment-indent-function (lambda () comment-column))
1170
1171   (setq major-mode 'ada-mode)
1172   (setq mode-name "Ada")
1173
1174   (use-local-map ada-mode-map)
1175
1176   (if ada-xemacs
1177       (funcall (symbol-function 'easy-menu-add)
1178                ada-mode-menu ada-mode-map))
1179
1180   (set-syntax-table ada-mode-syntax-table)
1181
1182   (if ada-clean-buffer-before-saving
1183       (progn
1184         ;; remove all spaces at the end of lines in the whole buffer.
1185         (add-hook 'local-write-file-hooks 'delete-trailing-whitespace)
1186         ;; convert all tabs to the correct number of spaces.
1187         (add-hook 'local-write-file-hooks
1188                   (lambda () (untabify (point-min) (point-max))))))
1189
1190   (run-hooks 'ada-mode-hook)
1191
1192   ;;  Run this after the hook to give the users a chance to activate
1193   ;;  font-lock-mode
1194
1195   (unless ada-xemacs
1196     (progn
1197       (ada-initialize-properties)
1198       (make-local-hook 'font-lock-mode-hook)
1199       (add-hook 'font-lock-mode-hook 'ada-deactivate-properties nil t)))
1200
1201   ;; the following has to be done after running the ada-mode-hook
1202   ;; because users might want to set the values of these variable
1203   ;; inside the hook (MH)
1204
1205   (cond ((eq ada-language-version 'ada83)
1206          (setq ada-keywords ada-83-keywords))
1207         ((eq ada-language-version 'ada95)
1208          (setq ada-keywords ada-95-keywords)))
1209
1210   (if ada-auto-case
1211       (ada-activate-keys-for-case)))
1212
1213 \f
1214 ;;-----------------------------------------------------------------
1215 ;;                      auto-casing
1216 ;; Since Ada is case-insensitive, the Ada-mode provides an extensive set of
1217 ;; functions to auto-case identifiers, keywords, ...
1218 ;; The basic rules for autocasing are defined through the variables
1219 ;; `ada-case-attribute', `ada-case-keyword' and `ada-case-identifier'. These
1220 ;; are references to the functions that will do the actual casing.
1221 ;;
1222 ;; However, in most cases, the user will want to define some exceptions to
1223 ;; these casing rules. This is done through a list of files, that contain
1224 ;; one word per line. These files are stored in `ada-case-exception-file'.
1225 ;; For backward compatibility, this variable can also be a string.
1226 ;;-----------------------------------------------------------------
1227
1228 (defun ada-create-case-exception (&optional word)
1229   "Defines WORD as an exception for the casing system.
1230 If WORD is not given, then the current word in the buffer is used instead.
1231 The new words is added to the first file in `ada-case-exception-file'.
1232 The standard casing rules will no longer apply to this word."
1233   (interactive)
1234   (let ((previous-syntax-table (syntax-table))
1235         (exception-list '())
1236         file-name
1237         )
1238
1239     (cond ((stringp ada-case-exception-file)
1240            (setq file-name ada-case-exception-file))
1241           ((listp ada-case-exception-file)
1242            (setq file-name (car ada-case-exception-file)))
1243           (t
1244            (error "No exception file specified")))
1245
1246     (set-syntax-table ada-mode-symbol-syntax-table)
1247     (unless word
1248       (save-excursion
1249         (skip-syntax-backward "w")
1250         (setq word (buffer-substring-no-properties
1251                     (point) (save-excursion (forward-word 1) (point))))))
1252
1253     ;;  Reread the exceptions file, in case it was modified by some other,
1254     ;;  and to keep the end-of-line comments that may exist in it.
1255     (if (file-readable-p (expand-file-name file-name))
1256         (let ((buffer (current-buffer)))
1257           (find-file (expand-file-name file-name))
1258           (set-syntax-table ada-mode-symbol-syntax-table)
1259           (widen)
1260           (goto-char (point-min))
1261           (while (not (eobp))
1262             (add-to-list 'exception-list
1263                          (list
1264                           (buffer-substring-no-properties
1265                            (point) (save-excursion (forward-word 1) (point)))
1266                           (buffer-substring-no-properties
1267                            (save-excursion (forward-word 1) (point))
1268                            (save-excursion (end-of-line) (point)))
1269                           t))
1270             (forward-line 1))
1271           (kill-buffer nil)
1272           (set-buffer buffer)))
1273
1274     ;;  If the word is already in the list, even with a different casing
1275     ;;  we simply want to replace it.
1276     (if (and (not (equal exception-list '()))
1277              (assoc-ignore-case word exception-list))
1278         (setcar (assoc-ignore-case word exception-list)
1279                 word)
1280       (add-to-list 'exception-list (list word "" t))
1281       )
1282
1283     (if (and (not (equal ada-case-exception '()))
1284              (assoc-ignore-case word ada-case-exception))
1285         (setcar (assoc-ignore-case word ada-case-exception)
1286                 word)
1287       (add-to-list 'ada-case-exception (cons word t))
1288       )
1289
1290     ;;  Save the list in the file
1291     (find-file (expand-file-name file-name))
1292     (erase-buffer)
1293     (mapcar (lambda (x) (insert (car x) (nth 1 x) "\n"))
1294             (sort exception-list
1295                   (lambda(a b) (string< (car a) (car b)))))
1296     (save-buffer)
1297     (kill-buffer nil)
1298     (set-syntax-table previous-syntax-table)
1299     ))
1300
1301 (defun ada-case-read-exceptions-from-file (file-name)
1302   "Read the content of the casing exception file FILE-NAME."
1303   (if (file-readable-p (expand-file-name file-name))
1304       (let ((buffer (current-buffer)))
1305         (find-file (expand-file-name file-name))
1306         (set-syntax-table ada-mode-symbol-syntax-table)
1307         (widen)
1308         (goto-char (point-min))
1309         (while (not (eobp))
1310
1311           ;; If the item is already in the list, even with an other casing,
1312           ;; do not add it again. This way, the user can easily decide which
1313           ;; priority should be applied to each casing exception
1314           (let ((word (buffer-substring-no-properties
1315                        (point) (save-excursion (forward-word 1) (point)))))
1316             (unless (assoc-ignore-case word ada-case-exception)
1317               (add-to-list 'ada-case-exception (cons word t))))
1318
1319           (forward-line 1))
1320         (kill-buffer nil)
1321         (set-buffer buffer)))
1322   )
1323
1324 (defun ada-case-read-exceptions ()
1325   "Read all the casing exception files from `ada-case-exception-file'."
1326   (interactive)
1327
1328   ;;  Reinitialize the casing exception list
1329   (setq ada-case-exception '())
1330
1331   (cond ((stringp ada-case-exception-file)
1332          (ada-case-read-exceptions-from-file ada-case-exception-file))
1333
1334         ((listp ada-case-exception-file)
1335          (mapcar 'ada-case-read-exceptions-from-file
1336                  ada-case-exception-file))))
1337
1338 (defun ada-adjust-case-identifier ()
1339   "Adjust case of the previous identifier.
1340 The auto-casing is done according to the value of `ada-case-identifier' and
1341 the exceptions defined in `ada-case-exception-file'."
1342   (interactive)
1343   (if (or (equal ada-case-exception '())
1344           (equal (char-after) ?_))
1345       (funcall ada-case-identifier -1)
1346
1347     (progn
1348       (let ((end   (point))
1349             (start (save-excursion (skip-syntax-backward "w")
1350                                    (point)))
1351             match)
1352         ;;  If we have an exception, replace the word by the correct casing
1353         (if (setq match (assoc-ignore-case (buffer-substring start end)
1354                                            ada-case-exception))
1355
1356             (progn
1357               (delete-region start end)
1358               (insert (car match)))
1359
1360           ;;  Else simply re-case the word
1361           (funcall ada-case-identifier -1))))))
1362
1363 (defun ada-after-keyword-p ()
1364   "Returns t if cursor is after a keyword that is not an attribute."
1365   (save-excursion
1366     (forward-word -1)
1367     (and (not (and (char-before)
1368                    (or (= (char-before) ?_)
1369                        (= (char-before) ?'))));; unless we have a _ or '
1370          (looking-at (concat ada-keywords "[^_]")))))
1371
1372 (defun ada-adjust-case (&optional force-identifier)
1373   "Adjust the case of the word before the just typed character.
1374 If FORCE-IDENTIFIER is non-nil then also adjust keyword as identifier."
1375   (forward-char -1)
1376   (if (and (> (point) 1)
1377            ;;  or if at the end of a character constant
1378            (not (and (eq (char-after) ?')
1379                      (eq (char-before (1- (point))) ?')))
1380            ;;  or if the previous character was not part of a word
1381            (eq (char-syntax (char-before)) ?w)
1382            ;;  if in a string or a comment
1383            (not (ada-in-string-or-comment-p))
1384            )
1385       (if (save-excursion
1386             (forward-word -1)
1387             (or (= (point) (point-min))
1388                 (backward-char 1))
1389             (= (char-after) ?'))
1390           (funcall ada-case-attribute -1)
1391         (if (and
1392              (not force-identifier)     ; (MH)
1393              (ada-after-keyword-p))
1394             (funcall ada-case-keyword -1)
1395           (ada-adjust-case-identifier))))
1396   (forward-char 1)
1397   )
1398
1399 (defun ada-adjust-case-interactive (arg)
1400   "Adjust the case of the previous word, and process the character just typed.
1401 ARG is the prefix the user entered with \C-u."
1402   (interactive "P")
1403
1404   (if ada-auto-case
1405       (let ((lastk last-command-char)
1406             (previous-syntax-table (syntax-table)))
1407
1408         (unwind-protect
1409             (progn
1410               (set-syntax-table ada-mode-symbol-syntax-table)
1411               (cond ((or (eq lastk ?\n)
1412                          (eq lastk ?\r))
1413                      ;; horrible kludge
1414                      (insert " ")
1415                      (ada-adjust-case)
1416                      ;; horrible dekludge
1417                      (delete-backward-char 1)
1418                      ;; some special keys and their bindings
1419                      (cond
1420                       ((eq lastk ?\n)
1421                        (funcall ada-lfd-binding))
1422                       ((eq lastk ?\r)
1423                        (funcall ada-ret-binding))))
1424                     ((eq lastk ?\C-i) (ada-tab))
1425                     ;; Else just insert the character
1426               ((self-insert-command (prefix-numeric-value arg))))
1427               ;; if there is a keyword in front of the underscore
1428               ;; then it should be part of an identifier (MH)
1429               (if (eq lastk ?_)
1430                   (ada-adjust-case t)
1431                 (ada-adjust-case))
1432               )
1433           ;; Restore the syntax table
1434           (set-syntax-table previous-syntax-table))
1435         )
1436
1437     ;; Else, no auto-casing
1438     (cond
1439      ((eq last-command-char ?\n)
1440       (funcall ada-lfd-binding))
1441      ((eq last-command-char ?\r)
1442       (funcall ada-ret-binding))
1443      (t
1444       (self-insert-command (prefix-numeric-value arg))))
1445     ))
1446
1447 (defun ada-activate-keys-for-case ()
1448   "Modifies the key bindings for all the keys that should readjust the casing."
1449   (interactive)
1450   ;; Save original key-bindings to allow swapping ret/lfd
1451   ;; when casing is activated.
1452   ;; The 'or ...' is there to be sure that the value will not
1453   ;; be changed again when Ada mode is called more than once
1454   (or ada-ret-binding    (setq ada-ret-binding (key-binding "\C-M")))
1455   (or ada-lfd-binding    (setq ada-lfd-binding (key-binding "\C-j")))
1456
1457   ;; Call case modifying function after certain keys.
1458   (mapcar (function (lambda(key) (define-key
1459                                    ada-mode-map
1460                                    (char-to-string key)
1461                                    'ada-adjust-case-interactive)))
1462           '( ?` ?_ ?# ?% ?& ?* ?( ?) ?- ?= ?+
1463                 ?| ?\; ?: ?' ?\" ?< ?, ?. ?> ?/ ?\n 32 ?\r )))
1464
1465 (defun ada-loose-case-word (&optional arg)
1466   "Upcase first letter and letters following `_' in the following word.
1467 No other letter is modified.
1468 ARG is ignored, and is there for compatibility with `capitalize-word' only."
1469   (interactive)
1470   (save-excursion
1471     (let ((end   (save-excursion (skip-syntax-forward  "w") (point)))
1472           (first t))
1473       (skip-syntax-backward "w")
1474       (while (and (or first (search-forward "_" end t))
1475                   (< (point) end))
1476         (and first
1477              (setq first nil))
1478         (insert-char (upcase (following-char)) 1)
1479         (delete-char 1)))))
1480
1481 (defun ada-no-auto-case (&optional arg)
1482   "Does nothing.
1483 This function can be used for the auto-casing variables in the ada-mode, to
1484 adapt to unusal auto-casing schemes. Since it does nothing, you can for
1485 instance use it for `ada-case-identifier' if you don't want any special
1486 auto-casing for identifiers, whereas keywords have to be lower-cased.
1487 See also `ada-auto-case' to disable auto casing altogether."
1488   )
1489
1490 (defun ada-capitalize-word (&optional arg)
1491   "Upcase first letter and letters following '_', lower case other letters.
1492 ARG is ignored, and is there for compatibility with `capitalize-word' only."
1493   (interactive)
1494   (let ((end   (save-excursion (skip-syntax-forward  "w") (point)))
1495         (begin (save-excursion (skip-syntax-backward "w") (point))))
1496     (modify-syntax-entry ?_ "_")
1497     (capitalize-region begin end)
1498     (modify-syntax-entry ?_ "w")))
1499
1500 (defun ada-adjust-case-region (from to)
1501   "Adjusts the case of all words in the region between FROM and TO.
1502 Attention: This function might take very long for big regions !"
1503   (interactive "*r")
1504   (let ((begin nil)
1505         (end nil)
1506         (keywordp nil)
1507         (attribp nil)
1508         (previous-syntax-table (syntax-table)))
1509     (message "Adjusting case ...")
1510     (unwind-protect
1511         (save-excursion
1512           (set-syntax-table ada-mode-symbol-syntax-table)
1513           (goto-char to)
1514           ;;
1515           ;; loop: look for all identifiers, keywords, and attributes
1516           ;;
1517           (while (re-search-backward "\\<\\(\\sw+\\)\\>" from t)
1518             (setq end (match-end 1))
1519             (setq attribp
1520                  (and (> (point) from)
1521                       (save-excursion
1522                         (forward-char -1)
1523                         (setq attribp (looking-at "'.[^']")))))
1524             (or
1525              ;; do nothing if it is a string or comment
1526              (ada-in-string-or-comment-p)
1527              (progn
1528                ;;
1529                ;; get the identifier or keyword or attribute
1530                ;;
1531                (setq begin (point))
1532                (setq keywordp (looking-at ada-keywords))
1533                (goto-char end)
1534                ;;
1535                ;; casing according to user-option
1536                ;;
1537                (if attribp
1538                    (funcall ada-case-attribute -1)
1539                  (if keywordp
1540                      (funcall ada-case-keyword -1)
1541                    (ada-adjust-case-identifier)))
1542                (goto-char begin))))
1543           (message "Adjusting case ... Done"))
1544       (set-syntax-table previous-syntax-table))))
1545
1546 (defun ada-adjust-case-buffer ()
1547   "Adjusts the case of all words in the whole buffer.
1548 ATTENTION: This function might take very long for big buffers !"
1549   (interactive "*")
1550   (ada-adjust-case-region (point-min) (point-max)))
1551
1552 \f
1553 ;;--------------------------------------------------------------
1554 ;; Format Parameter Lists
1555 ;; Some special algorithms are provided to indent the parameter lists in
1556 ;; subprogram declarations. This is done in two steps:
1557 ;;  - First parses the parameter list. The returned list has the following
1558 ;;    format:
1559 ;;     ( (<Param_Name> in? out? access? <Type_Name> <Default_Expression>)
1560 ;;       ... )
1561 ;;    This is done in `ada-scan-paramlist'.
1562 ;;  - Delete and recreate the parameter list in function
1563 ;;    `ada-insert-paramlist'.
1564 ;; Both steps are called from `ada-format-paramlist'.
1565 ;; Note: Comments inside the parameter list are lost.
1566 ;;       The syntax has to be correct, or the reformating will fail.
1567 ;;--------------------------------------------------------------
1568
1569 (defun ada-format-paramlist ()
1570   "Reformats the parameter list point is in."
1571   (interactive)
1572   (let ((begin nil)
1573         (end nil)
1574         (delend nil)
1575         (paramlist nil)
1576         (previous-syntax-table (syntax-table)))
1577     (unwind-protect
1578         (progn
1579           (set-syntax-table ada-mode-symbol-syntax-table)
1580
1581           ;; check if really inside parameter list
1582           (or (ada-in-paramlist-p)
1583               (error "not in parameter list"))
1584
1585           ;; find start of current parameter-list
1586           (ada-search-ignore-string-comment
1587            (concat ada-subprog-start-re "\\|\\<body\\>" ) t nil)
1588           (down-list 1)
1589           (backward-char 1)
1590           (setq begin (point))
1591
1592           ;; find end of parameter-list
1593           (forward-sexp 1)
1594           (setq delend (point))
1595           (delete-char -1)
1596           (insert "\n")
1597
1598           ;; find end of last parameter-declaration
1599           (forward-comment -1000)
1600           (setq end (point))
1601
1602           ;; build a list of all elements of the parameter-list
1603           (setq paramlist (ada-scan-paramlist (1+ begin) end))
1604
1605           ;; delete the original parameter-list
1606           (delete-region begin  delend)
1607
1608           ;; insert the new parameter-list
1609           (goto-char begin)
1610           (ada-insert-paramlist paramlist))
1611
1612       ;; restore syntax-table
1613       (set-syntax-table previous-syntax-table)
1614       )))
1615
1616 (defun ada-scan-paramlist (begin end)
1617   "Scan the parameter list found in between BEGIN and END.
1618 Returns the equivalent internal parameter list."
1619   (let ((paramlist (list))
1620         (param (list))
1621         (notend t)
1622         (apos nil)
1623         (epos nil)
1624         (semipos nil)
1625         (match-cons nil))
1626
1627     (goto-char begin)
1628
1629     ;; loop until end of last parameter
1630     (while notend
1631
1632       ;; find first character of parameter-declaration
1633       (ada-goto-next-non-ws)
1634       (setq apos (point))
1635
1636       ;; find last character of parameter-declaration
1637       (if (setq match-cons
1638                (ada-search-ignore-string-comment "[ \t\n]*;" nil end t))
1639           (progn
1640             (setq epos (car match-cons))
1641             (setq semipos (cdr match-cons)))
1642         (setq epos end))
1643
1644       ;; read name(s) of parameter(s)
1645       (goto-char apos)
1646       (looking-at "\\(\\(\\sw\\|[_, \t\n]\\)*\\(\\sw\\|_\\)\\)[ \t\n]*:[^=]")
1647
1648       (setq param (list (match-string 1)))
1649       (ada-search-ignore-string-comment ":" nil epos t 'search-forward)
1650
1651       ;; look for 'in'
1652       (setq apos (point))
1653       (setq param
1654            (append param
1655                    (list
1656                     (consp
1657                      (ada-search-ignore-string-comment
1658                       "in" nil epos t 'word-search-forward)))))
1659
1660       ;; look for 'out'
1661       (goto-char apos)
1662       (setq param
1663            (append param
1664                    (list
1665                     (consp
1666                      (ada-search-ignore-string-comment
1667                       "out" nil epos t 'word-search-forward)))))
1668
1669       ;; look for 'access'
1670       (goto-char apos)
1671       (setq param
1672            (append param
1673                    (list
1674                     (consp
1675                      (ada-search-ignore-string-comment
1676                       "access" nil epos t 'word-search-forward)))))
1677
1678       ;; skip 'in'/'out'/'access'
1679       (goto-char apos)
1680       (ada-goto-next-non-ws)
1681       (while (looking-at "\\<\\(in\\|out\\|access\\)\\>")
1682         (forward-word 1)
1683         (ada-goto-next-non-ws))
1684
1685       ;; read type of parameter
1686       ;; We accept spaces in the name, since some software like Rose
1687       ;; generates something like: "A : B 'Class"
1688       (looking-at "\\<\\(\\sw\\|[_.' \t]\\)+\\>")
1689       (setq param
1690            (append param
1691                    (list (match-string 0))))
1692
1693       ;; read default-expression, if there is one
1694       (goto-char (setq apos (match-end 0)))
1695       (setq param
1696            (append param
1697                    (list
1698                     (if (setq match-cons
1699                              (ada-search-ignore-string-comment
1700                               ":=" nil epos t 'search-forward))
1701                         (buffer-substring (car match-cons) epos)
1702                       nil))))
1703
1704       ;; add this parameter-declaration to the list
1705       (setq paramlist (append paramlist (list param)))
1706
1707       ;; check if it was the last parameter
1708       (if (eq epos end)
1709           (setq notend nil)
1710         (goto-char semipos))
1711       )
1712     (reverse paramlist)))
1713
1714 (defun ada-insert-paramlist (paramlist)
1715   "Inserts a formatted PARAMLIST in the buffer."
1716   (let ((i (length paramlist))
1717         (parlen 0)
1718         (typlen 0)
1719         (inp nil)
1720         (outp nil)
1721         (accessp nil)
1722         (column nil)
1723         (firstcol nil))
1724
1725     ;; loop until last parameter
1726     (while (not (zerop i))
1727       (setq i (1- i))
1728
1729       ;; get max length of parameter-name
1730       (setq parlen (max parlen (length (nth 0 (nth i paramlist)))))
1731
1732       ;; get max length of type-name
1733       (setq typlen (max typlen (length (nth 4 (nth i paramlist)))))
1734
1735       ;; is there any 'in' ?
1736       (setq inp (or inp (nth 1 (nth i paramlist))))
1737
1738       ;; is there any 'out' ?
1739       (setq outp (or outp (nth 2 (nth i paramlist))))
1740
1741       ;; is there any 'access' ?
1742       (setq accessp (or accessp (nth 3 (nth i paramlist))))
1743       )
1744
1745     ;; does paramlist already start on a separate line ?
1746     (if (save-excursion
1747           (re-search-backward "^.\\|[^ \t]" nil t)
1748           (looking-at "^."))
1749         ;; yes => re-indent it
1750         (progn
1751           (ada-indent-current)
1752           (save-excursion
1753             (if (looking-at "\\(is\\|return\\)")
1754                 (replace-match " \\1"))))
1755
1756       ;; no => insert it where we are after removing any whitespace
1757       (fixup-whitespace)
1758       (save-excursion
1759         (cond
1760          ((looking-at "[ \t]*\\(\n\\|;\\)")
1761           (replace-match "\\1"))
1762          ((looking-at "[ \t]*\\(is\\|return\\)")
1763           (replace-match " \\1"))))
1764       (insert " "))
1765
1766     (insert "(")
1767     (ada-indent-current)
1768
1769     (setq firstcol (current-column))
1770     (setq i (length paramlist))
1771
1772     ;; loop until last parameter
1773     (while (not (zerop i))
1774       (setq i (1- i))
1775       (setq column firstcol)
1776
1777       ;; insert parameter-name, space and colon
1778       (insert (nth 0 (nth i paramlist)))
1779       (indent-to (+ column parlen 1))
1780       (insert ": ")
1781       (setq column (current-column))
1782
1783       ;; insert 'in' or space
1784       (if (nth 1 (nth i paramlist))
1785           (insert "in ")
1786         (if (and
1787              (or inp
1788                  accessp)
1789              (not (nth 3 (nth i paramlist))))
1790             (insert "   ")))
1791
1792       ;; insert 'out' or space
1793       (if (nth 2 (nth i paramlist))
1794           (insert "out ")
1795         (if (and
1796              (or outp
1797                  accessp)
1798              (not (nth 3 (nth i paramlist))))
1799             (insert "    ")))
1800
1801       ;; insert 'access'
1802       (if (nth 3 (nth i paramlist))
1803           (insert "access "))
1804
1805       (setq column (current-column))
1806
1807       ;; insert type-name and, if necessary, space and default-expression
1808       (insert (nth 4 (nth i paramlist)))
1809       (if (nth 5 (nth i paramlist))
1810           (progn
1811             (indent-to (+ column typlen 1))
1812             (insert (nth 5 (nth i paramlist)))))
1813
1814       ;; check if it was the last parameter
1815       (if (zerop i)
1816           (insert ")")
1817         ;; no => insert ';' and newline and indent
1818         (insert ";")
1819         (newline)
1820         (indent-to firstcol))
1821       )
1822
1823     ;; if anything follows, except semicolon, newline, is or return
1824     ;; put it in a new line and indent it
1825     (unless (looking-at "[ \t]*\\(;\\|\n\\|is\\|return\\)")
1826       (ada-indent-newline-indent))
1827     ))
1828
1829
1830 \f
1831 ;;;----------------------------------------------------------------
1832 ;;  Indentation Engine
1833 ;;  All indentations are indicated as a two-element string:
1834 ;;     - position of reference in the buffer
1835 ;;     - offset to indent from this position (can also be a symbol or a list
1836 ;;       that are evaluated)
1837 ;;  Thus the total indentation for a line is the column number of the reference
1838 ;;  position plus whatever value the evaluation of the second element provides.
1839 ;;  This mechanism is used so that the ada-mode can "explain" how the
1840 ;;  indentation was calculated, by showing which variables were used.
1841 ;;
1842 ;;  The indentation itself is done in only one pass: first we try to guess in
1843 ;;  what context we are by looking at the following keyword or punctuation
1844 ;;  sign. If nothing remarkable is found, just try to guess the indentation
1845 ;;  based on previous lines.
1846 ;;
1847 ;;  The relevant functions for indentation are:
1848 ;;  - `ada-indent-region': Re-indent a region of text
1849 ;;  - `ada-justified-indent-current': Re-indent the current line and shows the
1850 ;;    calculation that were done
1851 ;;  - `ada-indent-current': Re-indent the current line
1852 ;;  - `ada-get-current-indent': Calculate the indentation for the current line,
1853 ;;    based on the context (see above).
1854 ;;  - `ada-get-indent-*': Calculate the indentation in a specific context.
1855 ;;    For efficiency, these functions do not check they are in the correct
1856 ;;    context.
1857 ;;;----------------------------------------------------------------
1858
1859 (defun ada-indent-region (beg end)
1860   "Indent the region between BEG end END."
1861   (interactive "*r")
1862   (goto-char beg)
1863   (let ((block-done 0)
1864         (lines-remaining (count-lines beg end))
1865         (msg (format "%%4d out of %4d lines remaining ..."
1866                      (count-lines beg end)))
1867         (endmark (copy-marker end)))
1868     ;; catch errors while indenting
1869     (while (< (point) endmark)
1870       (if (> block-done 39)
1871           (progn
1872             (setq lines-remaining (- lines-remaining block-done)
1873                   block-done     0)
1874             (message msg lines-remaining)))
1875       (if (= (char-after) ?\n) nil
1876         (ada-indent-current))
1877       (forward-line 1)
1878       (setq block-done      (1+ block-done)))
1879     (message "indenting ... done")))
1880
1881 (defun ada-indent-newline-indent ()
1882   "Indents the current line, inserts a newline and then indents the new line."
1883   (interactive "*")
1884   (ada-indent-current)
1885   (newline)
1886   (ada-indent-current))
1887
1888 (defun ada-indent-newline-indent-conditional ()
1889   "Insert a newline and indent it.
1890 The original line is indented first if `ada-indent-after-return' is non-nil.
1891 This function is intended to be bound to the \C-m and \C-j keys."
1892   (interactive "*")
1893   (if ada-indent-after-return (ada-indent-current))
1894   (newline)
1895   (ada-indent-current))
1896
1897 (defun ada-justified-indent-current ()
1898   "Indent the current line and explains how the calculation was done."
1899   (interactive)
1900
1901   (let ((cur-indent (ada-indent-current)))
1902
1903     (message nil)
1904     (if (equal (cdr cur-indent) '(0))
1905         (message "same indentation")
1906       (message (mapconcat (lambda(x)
1907                             (cond
1908                              ((symbolp x)
1909                               (symbol-name x))
1910                              ((numberp x)
1911                               (number-to-string x))
1912                              ((listp x)
1913                               (concat "- " (symbol-name (cadr x))))
1914                              ))
1915                           (cdr cur-indent)
1916                           " + ")))
1917     (save-excursion
1918       (goto-char (car cur-indent))
1919       (sit-for 1))))
1920
1921 (defun ada-batch-reformat ()
1922   "Re-indent and re-case all the files found on the command line.
1923 This function should be used from the Unix/Windows command line, with a
1924 command like:
1925   emacs -batch -l ada-mode -f ada-batch-reformat file1 file2 ..."
1926
1927   (while command-line-args-left
1928     (let ((source (car command-line-args-left)))
1929       (message (concat "formating " source))
1930       (find-file source)
1931       (ada-indent-region (point-min) (point-max))
1932       (ada-adjust-case-buffer)
1933       (write-file source))
1934     (setq command-line-args-left (cdr command-line-args-left)))
1935   (message "Done")
1936   (kill-emacs 0))
1937
1938 (defsubst ada-goto-previous-word ()
1939   "Moves point to the beginning of the previous word of Ada code.
1940 Returns the new position of point or nil if not found."
1941   (ada-goto-next-word t))
1942
1943 (defun ada-indent-current ()
1944   "Indent current line as Ada code.
1945 Returns the calculation that was done, including the reference point and the
1946 offset."
1947   (interactive)
1948   (let ((previous-syntax-table (syntax-table))
1949         (orgpoint (point-marker))
1950         cur-indent tmp-indent
1951         prev-indent)
1952
1953     (unwind-protect
1954         (progn
1955           (set-syntax-table ada-mode-symbol-syntax-table)
1956
1957           ;;  This need to be done here so that the advice is not always
1958           ;;  activated (this might interact badly with other modes)
1959           (if ada-xemacs
1960               (ad-activate 'parse-partial-sexp t))
1961
1962           (save-excursion
1963             (setq cur-indent
1964
1965                  ;; Not First line in the buffer ?
1966                  (if (save-excursion (zerop (forward-line -1)))
1967                      (progn
1968                        (back-to-indentation)
1969                        (ada-get-current-indent))
1970
1971                    ;; first line in the buffer
1972                    (list (point-min) 0))))
1973
1974           ;; Evaluate the list to get the column to indent to
1975           ;; prev-indent contains the column to indent to
1976           (if cur-indent
1977               (setq prev-indent (save-excursion (goto-char (car cur-indent))
1978                                                 (current-column))
1979                     tmp-indent (cdr cur-indent))
1980             (setq prev-indent 0  tmp-indent '()))
1981
1982           (while (not (null tmp-indent))
1983             (cond
1984              ((numberp (car tmp-indent))
1985               (setq prev-indent (+ prev-indent (car tmp-indent))))
1986              (t
1987               (setq prev-indent (+ prev-indent (eval (car tmp-indent)))))
1988              )
1989             (setq tmp-indent (cdr tmp-indent)))
1990
1991           ;; only re-indent if indentation is different then the current
1992           (if (= (save-excursion (back-to-indentation) (current-column)) prev-indent)
1993               nil
1994             (beginning-of-line)
1995             (delete-horizontal-space)
1996             (indent-to prev-indent))
1997           ;;
1998           ;; restore position of point
1999           ;;
2000           (goto-char orgpoint)
2001           (if (< (current-column) (current-indentation))
2002               (back-to-indentation)))
2003
2004       ;; restore syntax-table
2005       (set-syntax-table previous-syntax-table)
2006       (if ada-xemacs
2007           (ad-deactivate 'parse-partial-sexp))
2008       )
2009
2010     cur-indent
2011     ))
2012
2013 (defun ada-get-current-indent ()
2014   "Return the indentation to use for the current line."
2015   (let (column
2016         pos
2017         match-cons
2018         result
2019         (orgpoint (save-excursion
2020                     (beginning-of-line)
2021                     (forward-comment -10000)
2022                     (forward-line 1)
2023                     (point))))
2024
2025     (setq result
2026     (cond
2027
2028      ;;-----------------------------
2029      ;; in open parenthesis, but not in parameter-list
2030      ;;-----------------------------
2031
2032      ((and ada-indent-to-open-paren
2033            (not (ada-in-paramlist-p))
2034            (setq column (ada-in-open-paren-p)))
2035
2036       ;; check if we have something like this  (Table_Component_Type =>
2037       ;;                                          Source_File_Record)
2038       (save-excursion
2039         (if (and (skip-chars-backward " \t")
2040                  (= (char-before) ?\n)
2041                  (not (forward-comment -10000))
2042                  (= (char-before) ?>))
2043             ;; ??? Could use a different variable
2044             (list column 'ada-broken-indent)
2045           (list column 0))))
2046
2047      ;;---------------------------
2048      ;;   at end of buffer
2049      ;;---------------------------
2050
2051      ((not (char-after))
2052       (ada-indent-on-previous-lines nil orgpoint orgpoint))
2053
2054      ;;---------------------------
2055      ;;  starting with e
2056      ;;---------------------------
2057
2058      ((= (char-after) ?e)
2059       (cond
2060
2061        ;; -------  end  ------
2062
2063        ((looking-at "end\\>")
2064         (let ((label 0)
2065               limit)
2066           (save-excursion
2067             (ada-goto-matching-start 1)
2068
2069             ;;
2070             ;; found 'loop' => skip back to 'while' or 'for'
2071             ;;                 if 'loop' is not on a separate line
2072             ;; Stop the search for 'while' and 'for' when a ';' is encountered.
2073             ;;
2074             (if (save-excursion
2075                   (beginning-of-line)
2076                   (looking-at ".+\\<loop\\>"))
2077                 (progn
2078                   (save-excursion
2079                     (setq limit (car (ada-search-ignore-string-comment ";" t))))
2080                   (if (save-excursion
2081                         (and
2082                          (setq match-cons
2083                               (ada-search-ignore-string-comment ada-loop-start-re t limit))
2084                          (not (looking-at "\\<loop\\>"))))
2085                       (progn
2086                         (goto-char (car match-cons))
2087                         (save-excursion
2088                           (beginning-of-line)
2089                           (if (looking-at ada-named-block-re)
2090                               (setq label (- ada-label-indent))))))))
2091
2092             (list (+ (save-excursion (back-to-indentation) (point)) label) 0))))
2093
2094        ;; ------  exception  ----
2095
2096        ((looking-at "exception\\>")
2097         (save-excursion
2098           (ada-goto-matching-start 1)
2099           (list (save-excursion (back-to-indentation) (point)) 0)))
2100
2101        ;; else
2102
2103        ((looking-at "else\\>")
2104         (if (save-excursion  (ada-goto-previous-word)
2105                              (looking-at "\\<or\\>"))
2106             (ada-indent-on-previous-lines nil orgpoint orgpoint)
2107           (save-excursion
2108             (ada-goto-matching-start 1 nil t)
2109             (list (progn (back-to-indentation) (point)) 0))))
2110
2111        ;; elsif
2112
2113        ((looking-at "elsif\\>")
2114         (save-excursion
2115           (ada-goto-matching-start 1 nil t)
2116           (list (progn (back-to-indentation) (point)) 0)))
2117
2118        ))
2119
2120      ;;---------------------------
2121      ;;  starting with w (when)
2122      ;;---------------------------
2123
2124      ((and (= (char-after) ?w)
2125            (looking-at "when\\>"))
2126       (save-excursion
2127         (ada-goto-matching-start 1)
2128         (list (save-excursion (back-to-indentation) (point))
2129               'ada-when-indent)))
2130
2131      ;;---------------------------
2132      ;;   starting with t (then)
2133      ;;---------------------------
2134
2135      ((and (= (char-after) ?t)
2136            (looking-at "then\\>"))
2137       (if (save-excursion (ada-goto-previous-word)
2138                           (looking-at "and\\>"))
2139           (ada-indent-on-previous-lines nil orgpoint orgpoint)
2140         (save-excursion
2141           ;;  Select has been added for the statement: "select ... then abort"
2142           (ada-search-ignore-string-comment
2143            "\\<\\(elsif\\|if\\|select\\)\\>" t nil)
2144           (list (progn (back-to-indentation) (point))
2145                 'ada-stmt-end-indent))))
2146
2147      ;;---------------------------
2148      ;;   starting with l (loop)
2149      ;;---------------------------
2150
2151      ((and (= (char-after) ?l)
2152            (looking-at "loop\\>"))
2153       (setq pos (point))
2154       (save-excursion
2155         (goto-char (match-end 0))
2156         (ada-goto-stmt-start)
2157         (if (looking-at "\\<\\(loop\\|if\\)\\>")
2158             (ada-indent-on-previous-lines nil orgpoint orgpoint)
2159           (unless (looking-at ada-loop-start-re)
2160             (ada-search-ignore-string-comment ada-loop-start-re
2161                                               nil pos))
2162           (if (looking-at "\\<loop\\>")
2163               (ada-indent-on-previous-lines nil orgpoint orgpoint)
2164             (list (progn (back-to-indentation) (point)) 'ada-stmt-end-indent)))))
2165
2166      ;;---------------------------
2167      ;;   starting with b (begin)
2168      ;;---------------------------
2169
2170      ((and (= (char-after) ?b)
2171            (looking-at "begin\\>"))
2172       (save-excursion
2173         (if (ada-goto-matching-decl-start t)
2174             (list (progn (back-to-indentation) (point)) 0)
2175           (ada-indent-on-previous-lines nil orgpoint orgpoint))))
2176
2177      ;;---------------------------
2178      ;;   starting with i (is)
2179      ;;---------------------------
2180
2181      ((and (= (char-after) ?i)
2182            (looking-at "is\\>"))
2183
2184       (if (and ada-indent-is-separate
2185                (save-excursion
2186                  (goto-char (match-end 0))
2187                  (ada-goto-next-non-ws (save-excursion (end-of-line)
2188                                                        (point)))
2189                  (looking-at "\\<abstract\\>\\|\\<separate\\>")))
2190           (save-excursion
2191             (ada-goto-stmt-start)
2192             (list (progn (back-to-indentation) (point)) 'ada-indent))
2193         (save-excursion
2194           (ada-goto-stmt-start)
2195           (list (progn (back-to-indentation) (point)) 'ada-stmt-end-indent))))
2196
2197      ;;---------------------------
2198      ;;  starting with r (record, return, renames)
2199      ;;---------------------------
2200
2201      ((= (char-after) ?r)
2202
2203       (cond
2204
2205        ;; ----- record ------
2206
2207        ((looking-at "record\\>")
2208         (save-excursion
2209           (ada-search-ignore-string-comment
2210            "\\<\\(type\\|use\\)\\>" t nil)
2211           (if (looking-at "\\<use\\>")
2212               (ada-search-ignore-string-comment "for" t nil nil 'word-search-backward))
2213           (list (progn (back-to-indentation) (point)) 'ada-indent-record-rel-type)))
2214
2215        ;; ----- return or renames ------
2216
2217        ((looking-at "re\\(turn\\|names\\)\\>")
2218         (save-excursion
2219           (let ((var 'ada-indent-return))
2220             ;;  If looking at a renames, skip the 'return' statement too
2221             (if (looking-at "renames")
2222                 (let (pos)
2223                   (save-excursion
2224                     (setq pos (ada-search-ignore-string-comment ";\\|return\\>" t)))
2225                   (if (and pos
2226                            (= (char-after (car pos)) ?r))
2227                       (goto-char (car pos)))
2228                   (setq var 'ada-indent-renames)))
2229
2230             (forward-comment -1000)
2231             (if (= (char-before) ?\))
2232                 (forward-sexp -1)
2233               (forward-word -1))
2234
2235             ;; If there is a parameter list, and we have a function declaration
2236             ;; or a access to subprogram declaration
2237             (let ((num-back 1))
2238               (if (and (= (char-after) ?\()
2239                        (save-excursion
2240                          (or (progn
2241                                (backward-word 1)
2242                                (looking-at "function\\>"))
2243                              (progn
2244                                (backward-word 1)
2245                                (setq num-back 2)
2246                                (looking-at "function\\>")))))
2247
2248                   ;; The indentation depends of the value of ada-indent-return
2249                   (if (<= (eval var) 0)
2250                       (list (point) (list '- var))
2251                     (list (progn (backward-word num-back) (point))
2252                           var))
2253
2254                 ;; Else there is no parameter list, but we have a function
2255                 ;; Only do something special if the user want to indent
2256                 ;; relative to the "function" keyword
2257                 (if (and (> (eval var) 0)
2258                          (save-excursion (forward-word -1)
2259                                          (looking-at "function\\>")))
2260                     (list (progn (forward-word -1) (point)) var)
2261
2262                   ;; Else...
2263                   (ada-indent-on-previous-lines nil orgpoint orgpoint)))))))
2264        ))
2265
2266      ;;--------------------------------
2267      ;;   starting with 'o' or 'p'
2268      ;;   'or'      as statement-start
2269      ;;   'private' as statement-start
2270      ;;--------------------------------
2271
2272      ((and (or (= (char-after) ?o)
2273                (= (char-after) ?p))
2274            (or (ada-looking-at-semi-or)
2275                (ada-looking-at-semi-private)))
2276       (save-excursion
2277         (ada-goto-matching-start 1)
2278         (list (progn (back-to-indentation) (point)) 0)))
2279
2280      ;;--------------------------------
2281      ;;   starting with 'd'  (do)
2282      ;;--------------------------------
2283
2284      ((and (= (char-after) ?d)
2285            (looking-at "do\\>"))
2286       (save-excursion
2287         (ada-goto-stmt-start)
2288         (list (progn (back-to-indentation) (point)) 'ada-stmt-end-indent)))
2289
2290      ;;--------------------------------
2291      ;;   starting with '-'  (comment)
2292      ;;--------------------------------
2293
2294      ((= (char-after) ?-)
2295       (if ada-indent-comment-as-code
2296
2297           ;;  Indent comments on previous line comments if required
2298           ;;  We must use a search-forward (even if the code is more complex),
2299           ;;  since we want to find the beginning of the comment.
2300           (let (pos)
2301
2302             (if (and ada-indent-align-comments
2303                      (save-excursion
2304                        (forward-line -1)
2305                        (beginning-of-line)
2306                        (while (and (not pos)
2307                                    (search-forward "--"
2308                                                     (save-excursion
2309                                                       (end-of-line) (point))
2310                                                     t))
2311                          (unless (ada-in-string-p)
2312                            (setq pos (point))))
2313                        pos))
2314                 (list (- pos 2) 0)
2315
2316             ;;  Else always on previous line
2317             (ada-indent-on-previous-lines nil orgpoint orgpoint)))
2318
2319         ;; Else same indentation as the previous line
2320         (list (save-excursion (back-to-indentation) (point)) 0)))
2321
2322      ;;--------------------------------
2323      ;;   starting with '#'  (preprocessor line)
2324      ;;--------------------------------
2325
2326      ((and (= (char-after) ?#)
2327            (equal ada-which-compiler 'gnat)
2328            (looking-at "#[ \t]*\\(if\\|els\\(e\\|if\\)\\|end[ \t]*if\\)"))
2329       (list (save-excursion (beginning-of-line) (point)) 0))
2330
2331      ;;--------------------------------
2332      ;;   starting with ')' (end of a parameter list)
2333      ;;--------------------------------
2334
2335      ((and (not (eobp)) (= (char-after) ?\)))
2336       (save-excursion
2337         (forward-char 1)
2338         (backward-sexp 1)
2339         (list (point) 0)))
2340
2341      ;;---------------------------------
2342      ;; new/abstract/separate
2343      ;;---------------------------------
2344
2345      ((looking-at "\\(new\\|abstract\\|separate\\)\\>")
2346       (ada-indent-on-previous-lines nil orgpoint orgpoint))
2347
2348      ;;---------------------------------
2349      ;; package/function/procedure
2350      ;;---------------------------------
2351
2352      ((and (or (= (char-after) ?p) (= (char-after) ?f))
2353            (looking-at "\\<\\(package\\|function\\|procedure\\)\\>"))
2354       (save-excursion
2355         ;;  Go up until we find either a generic section, or the end of the
2356         ;;  previous subprogram/package
2357         (let (found)
2358           (while (and (not found)
2359                       (ada-search-ignore-string-comment
2360              "\\<\\(generic\\|end\\|begin\\|package\\|procedure\\|function\\)\\>" t))
2361
2362             ;;  avoid "with procedure"... in generic parts
2363             (save-excursion
2364               (forward-word -1)
2365               (setq found (not (looking-at "with"))))))
2366
2367         (if (looking-at "generic")
2368             (list (progn (back-to-indentation) (point)) 0)
2369           (ada-indent-on-previous-lines nil orgpoint orgpoint))))
2370
2371      ;;---------------------------------
2372      ;; label
2373      ;;---------------------------------
2374
2375      ((looking-at "\\(\\sw\\|_\\)+[ \t\n]*:[^=]")
2376       (if (ada-in-decl-p)
2377           (ada-indent-on-previous-lines nil orgpoint orgpoint)
2378         (append (ada-indent-on-previous-lines nil orgpoint orgpoint)
2379                 '(ada-label-indent))))
2380
2381      ))
2382
2383     ;;---------------------------------
2384     ;; Other syntaxes
2385     ;;---------------------------------
2386     (or result (ada-indent-on-previous-lines nil orgpoint orgpoint))))
2387
2388 (defun ada-indent-on-previous-lines (&optional nomove orgpoint initial-pos)
2389   "Calculate the indentation for the new line after ORGPOINT.
2390 The result list is based on the previous lines in the buffer.
2391 If NOMOVE is nil, moves point to the beginning of the current statement.
2392 if INITIAL-POS is non-nil, moves point to INITIAL-POS before calculation."
2393   (if initial-pos
2394       (goto-char initial-pos))
2395   (let ((oldpoint (point)))
2396
2397     ;; Is inside a parameter-list ?
2398     (if (ada-in-paramlist-p)
2399         (ada-get-indent-paramlist)
2400
2401       ;; move to beginning of current statement
2402       (unless nomove
2403         (ada-goto-stmt-start))
2404
2405       ;; no beginning found => don't change indentation
2406       (if (and (eq oldpoint (point))
2407                (not nomove))
2408           (ada-get-indent-nochange)
2409
2410         (cond
2411          ;;
2412          ((and
2413            ada-indent-to-open-paren
2414            (ada-in-open-paren-p))
2415           (ada-get-indent-open-paren))
2416          ;;
2417          ((looking-at "end\\>")
2418           (ada-get-indent-end orgpoint))
2419          ;;
2420          ((looking-at ada-loop-start-re)
2421           (ada-get-indent-loop orgpoint))
2422          ;;
2423          ((looking-at ada-subprog-start-re)
2424           (ada-get-indent-subprog orgpoint))
2425          ;;
2426          ((looking-at ada-block-start-re)
2427           (ada-get-indent-block-start orgpoint))
2428          ;;
2429          ((looking-at "\\(sub\\)?type\\>")
2430           (ada-get-indent-type orgpoint))
2431          ;;
2432          ;; "then" has to be included in the case of "select...then abort"
2433          ;; statements, since (goto-stmt-start) at the beginning of
2434          ;; the current function would leave the cursor on that position
2435          ((looking-at "\\(\\(els\\)?if\\>\\)\\|then abort\\\>")
2436           (ada-get-indent-if orgpoint))
2437          ;;
2438          ((looking-at "case\\>")
2439           (ada-get-indent-case orgpoint))
2440          ;;
2441          ((looking-at "when\\>")
2442           (ada-get-indent-when orgpoint))
2443          ;;
2444          ((looking-at "\\(\\sw\\|_\\)+[ \t\n]*:[^=]")
2445           (ada-get-indent-label orgpoint))
2446          ;;
2447          ((looking-at "separate\\>")
2448           (ada-get-indent-nochange))
2449          ;;
2450          ((looking-at "with\\>\\|use\\>")
2451           ;;  Are we still in that statement, or are we in fact looking at
2452           ;;  the previous one ?
2453           (if (save-excursion (search-forward ";" oldpoint t))
2454               (list (progn (back-to-indentation) (point)) 0)
2455             (list (point) (if (looking-at "with")
2456                               'ada-with-indent
2457                             'ada-use-indent))))
2458          ;;
2459          (t
2460           (ada-get-indent-noindent orgpoint)))))
2461     ))
2462
2463 (defun ada-get-indent-open-paren ()
2464   "Calculates the indentation when point is behind an unclosed parenthesis."
2465   (list (ada-in-open-paren-p) 0))
2466
2467 (defun ada-get-indent-nochange ()
2468   "Return the current indentation of the previous line."
2469   (save-excursion
2470     (forward-line -1)
2471     (back-to-indentation)
2472     (list (point) 0)))
2473
2474 (defun ada-get-indent-paramlist ()
2475   "Calculates the indentation when point is inside a parameter list."
2476   (save-excursion
2477     (ada-search-ignore-string-comment "[^ \t\n]" t nil t)
2478     (cond
2479      ;; in front of the first parameter
2480      ((= (char-after) ?\()
2481       (goto-char (match-end 0))
2482       (list (point) 0))
2483
2484      ;; in front of another parameter
2485      ((= (char-after) ?\;)
2486       (goto-char (cdr (ada-search-ignore-string-comment "(\\|;" t nil t)))
2487       (ada-goto-next-non-ws)
2488       (list (point) 0))
2489
2490      ;; inside a parameter declaration
2491      (t
2492       (goto-char (cdr (ada-search-ignore-string-comment "(\\|;" t nil t)))
2493       (ada-goto-next-non-ws)
2494       (list (point) 'ada-broken-indent)))))
2495
2496 (defun ada-get-indent-end (orgpoint)
2497   "Calculates the indentation when point is just before an end_statement.
2498 ORGPOINT is the limit position used in the calculation."
2499   (let ((defun-name nil)
2500         (indent nil))
2501
2502     ;; is the line already terminated by ';' ?
2503     (if (save-excursion
2504           (ada-search-ignore-string-comment ";" nil orgpoint nil
2505                                             'search-forward))
2506
2507         ;; yes, look what's following 'end'
2508         (progn
2509           (forward-word 1)
2510           (ada-goto-next-non-ws)
2511           (cond
2512            ((looking-at "\\<\\(loop\\|select\\|if\\|case\\)\\>")
2513             (save-excursion (ada-check-matching-start (match-string 0)))
2514             (list (save-excursion (back-to-indentation) (point)) 0))
2515
2516            ;;
2517            ;; loop/select/if/case/record/select
2518            ;;
2519            ((looking-at "\\<record\\>")
2520             (save-excursion
2521               (ada-check-matching-start (match-string 0))
2522               ;;  we are now looking at the matching "record" statement
2523               (forward-word 1)
2524               (ada-goto-stmt-start)
2525               ;;  now on the matching type declaration, or use clause
2526               (unless (looking-at "\\(for\\|type\\)\\>")
2527                 (ada-search-ignore-string-comment "\\<type\\>" t))
2528               (list (progn (back-to-indentation) (point)) 0)))
2529            ;;
2530            ;; a named block end
2531            ;;
2532            ((looking-at ada-ident-re)
2533             (setq defun-name (match-string 0))
2534             (save-excursion
2535               (ada-goto-matching-start 0)
2536               (ada-check-defun-name defun-name))
2537             (list (progn (back-to-indentation) (point)) 0))
2538            ;;
2539            ;; a block-end without name
2540            ;;
2541            ((= (char-after) ?\;)
2542             (save-excursion
2543               (ada-goto-matching-start 0)
2544               (if (looking-at "\\<begin\\>")
2545                   (progn
2546                     (setq indent (list (point) 0))
2547                     (if (ada-goto-matching-decl-start t)
2548                         (list (progn (back-to-indentation) (point)) 0)
2549                       indent)))))
2550            ;;
2551            ;; anything else - should maybe signal an error ?
2552            ;;
2553            (t
2554             (list (save-excursion (back-to-indentation) (point))
2555                   'ada-broken-indent))))
2556
2557       (list (save-excursion (back-to-indentation) (point))
2558             'ada-broken-indent))))
2559
2560 (defun ada-get-indent-case (orgpoint)
2561   "Calculates the indentation when point is just before a case statement.
2562 ORGPOINT is the limit position used in the calculation."
2563   (let ((match-cons nil)
2564         (opos (point)))
2565     (cond
2566      ;;
2567      ;; case..is..when..=>
2568      ;;
2569      ((save-excursion
2570         (setq match-cons (and
2571                           ;; the `=>' must be after the keyword `is'.
2572                           (ada-search-ignore-string-comment
2573                            "is" nil orgpoint nil 'word-search-forward)
2574                           (ada-search-ignore-string-comment
2575                            "[ \t\n]+=>" nil orgpoint))))
2576       (save-excursion
2577         (goto-char (car match-cons))
2578         (unless (ada-search-ignore-string-comment "when" t opos)
2579           (error "missing 'when' between 'case' and '=>'"))
2580         (list (save-excursion (back-to-indentation) (point)) 'ada-indent)))
2581      ;;
2582      ;; case..is..when
2583      ;;
2584      ((save-excursion
2585         (setq match-cons (ada-search-ignore-string-comment
2586                           "when" nil orgpoint nil 'word-search-forward)))
2587       (goto-char (cdr match-cons))
2588       (list (save-excursion (back-to-indentation) (point)) 'ada-broken-indent))
2589      ;;
2590      ;; case..is
2591      ;;
2592      ((save-excursion
2593         (setq match-cons (ada-search-ignore-string-comment
2594                           "is" nil orgpoint nil 'word-search-forward)))
2595       (list (save-excursion (back-to-indentation) (point)) 'ada-when-indent))
2596      ;;
2597      ;; incomplete case
2598      ;;
2599      (t
2600       (list (save-excursion (back-to-indentation) (point))
2601             'ada-broken-indent)))))
2602
2603 (defun ada-get-indent-when (orgpoint)
2604   "Calculates the indentation when point is just before a when statement.
2605 ORGPOINT is the limit position used in the calculation."
2606   (let ((cur-indent (save-excursion (back-to-indentation) (point))))
2607     (if (ada-search-ignore-string-comment "[ \t\n]*=>" nil orgpoint)
2608         (list cur-indent 'ada-indent)
2609       (list cur-indent 'ada-broken-indent))))
2610
2611 (defun ada-get-indent-if (orgpoint)
2612   "Calculates the indentation when point is just before an if statement.
2613 ORGPOINT is the limit position used in the calculation."
2614   (let ((cur-indent (save-excursion (back-to-indentation) (point)))
2615         (match-cons nil))
2616     ;;
2617     ;; Move to the correct then (ignore all "and then")
2618     ;;
2619     (while (and (setq match-cons (ada-search-ignore-string-comment
2620                                   "\\<\\(then\\|and[ \t]*then\\)\\>"
2621                                   nil orgpoint))
2622                 (= (char-after (car match-cons)) ?a)))
2623     ;; If "then" was found (we are looking at it)
2624     (if match-cons
2625         (progn
2626           ;;
2627           ;; 'then' first in separate line ?
2628           ;; => indent according to 'then',
2629           ;; => else indent according to 'if'
2630           ;;
2631           (if (save-excursion
2632                 (back-to-indentation)
2633                 (looking-at "\\<then\\>"))
2634               (setq cur-indent (save-excursion (back-to-indentation) (point))))
2635           ;; skip 'then'
2636           (forward-word 1)
2637           (list cur-indent 'ada-indent))
2638
2639       (list cur-indent 'ada-broken-indent))))
2640
2641 (defun ada-get-indent-block-start (orgpoint)
2642   "Calculates the indentation when point is at the start of a block.
2643 ORGPOINT is the limit position used in the calculation."
2644   (let ((pos nil))
2645     (cond
2646      ((save-excursion
2647         (forward-word 1)
2648         (setq pos (ada-goto-next-non-ws orgpoint)))
2649       (goto-char pos)
2650       (save-excursion
2651         (ada-indent-on-previous-lines t orgpoint)))
2652
2653      ;; nothing follows the block-start
2654      (t
2655       (list (save-excursion (back-to-indentation) (point)) 'ada-indent)))))
2656
2657 (defun ada-get-indent-subprog (orgpoint)
2658   "Calculates the indentation when point is just before a subprogram.
2659 ORGPOINT is the limit position used in the calculation."
2660   (let ((match-cons nil)
2661         (cur-indent (save-excursion (back-to-indentation) (point)))
2662         (foundis nil))
2663     ;;
2664     ;; is there an 'is' in front of point ?
2665     ;;
2666     (if (save-excursion
2667           (setq match-cons
2668                (ada-search-ignore-string-comment
2669                 "\\<\\(is\\|do\\)\\>" nil orgpoint)))
2670         ;;
2671         ;; yes, then skip to its end
2672         ;;
2673         (progn
2674           (setq foundis t)
2675           (goto-char (cdr match-cons)))
2676       ;;
2677       ;; no, then goto next non-ws, if there is one in front of point
2678       ;;
2679       (progn
2680         (unless (ada-goto-next-non-ws orgpoint)
2681           (goto-char orgpoint))))
2682
2683     (cond
2684      ;;
2685      ;; nothing follows 'is'
2686      ;;
2687      ((and
2688        foundis
2689        (save-excursion
2690          (not (ada-search-ignore-string-comment
2691                "[^ \t\n]" nil orgpoint t))))
2692       (list cur-indent 'ada-indent))
2693      ;;
2694      ;; is abstract/separate/new ...
2695      ;;
2696      ((and
2697        foundis
2698        (save-excursion
2699          (setq match-cons
2700               (ada-search-ignore-string-comment
2701                "\\<\\(separate\\|new\\|abstract\\)\\>"
2702                nil orgpoint))))
2703       (goto-char (car match-cons))
2704       (ada-search-ignore-string-comment ada-subprog-start-re t)
2705       (ada-get-indent-noindent orgpoint))
2706      ;;
2707      ;; something follows 'is'
2708      ;;
2709      ((and
2710        foundis
2711        (save-excursion (setq match-cons (ada-goto-next-non-ws orgpoint)))
2712        (goto-char match-cons)
2713        (ada-indent-on-previous-lines t orgpoint)))
2714      ;;
2715      ;; no 'is' but ';'
2716      ;;
2717      ((save-excursion
2718         (ada-search-ignore-string-comment ";" nil orgpoint nil 'search-forward))
2719       (list cur-indent 0))
2720      ;;
2721      ;; no 'is' or ';'
2722      ;;
2723      (t
2724       (list cur-indent 'ada-broken-indent)))))
2725
2726 (defun ada-get-indent-noindent (orgpoint)
2727   "Calculates the indentation when point is just before a 'noindent stmt'.
2728 ORGPOINT is the limit position used in the calculation."
2729   (let ((label 0))
2730     (save-excursion
2731       (beginning-of-line)
2732
2733       (cond
2734
2735        ;;  This one is called when indenting a line preceded by a multi-line
2736        ;;  subprogram declaration (in that case, we are at this point inside
2737        ;;  the parameter declaration list)
2738        ((ada-in-paramlist-p)
2739         (ada-previous-procedure)
2740         (list (save-excursion (back-to-indentation) (point)) 0))
2741
2742        ;;  This one is called when indenting the second line of a multi-line
2743        ;;  declaration section, in a declare block or a record declaration
2744        ((looking-at "[ \t]*\\(\\sw\\|_\\)*[ \t]*,[ \t]*$")
2745         (list (save-excursion (back-to-indentation) (point))
2746               'ada-broken-decl-indent))
2747
2748        ;;  This one is called in every over case when indenting a line at the
2749        ;;  top level
2750        (t
2751         (if (looking-at ada-named-block-re)
2752             (setq label (- ada-label-indent))
2753
2754           (let (p)
2755
2756             ;;  "with private" or "null record" cases
2757             (if (or (save-excursion
2758                       (and (ada-search-ignore-string-comment "\\<private\\>" nil orgpoint)
2759                            (setq p (point))
2760                            (save-excursion (forward-char -7);; skip back "private"
2761                                            (ada-goto-previous-word)
2762                                            (looking-at "with"))))
2763                     (save-excursion
2764                       (and (ada-search-ignore-string-comment "\\<record\\>" nil orgpoint)
2765                            (setq p (point))
2766                            (save-excursion (forward-char -6);; skip back "record"
2767                                            (ada-goto-previous-word)
2768                                            (looking-at "null")))))
2769                 (progn
2770                   (goto-char p)
2771                   (re-search-backward "\\<\\(type\\|subtype\\)\\>" nil t)
2772                   (list (save-excursion (back-to-indentation) (point)) 0)))))
2773         (if (save-excursion
2774               (ada-search-ignore-string-comment ";" nil orgpoint nil
2775                                                 'search-forward))
2776             (list (+ (save-excursion (back-to-indentation) (point)) label) 0)
2777           (list (+ (save-excursion (back-to-indentation) (point)) label)
2778                 'ada-broken-indent)))))))
2779
2780 (defun ada-get-indent-label (orgpoint)
2781   "Calculates the indentation when before a label or variable declaration.
2782 ORGPOINT is the limit position used in the calculation."
2783   (let ((match-cons nil)
2784         (cur-indent (save-excursion (back-to-indentation) (point))))
2785     (ada-search-ignore-string-comment ":" nil)
2786     (cond
2787      ;; loop label
2788      ((save-excursion
2789         (setq match-cons (ada-search-ignore-string-comment
2790                           ada-loop-start-re nil orgpoint)))
2791       (goto-char (car match-cons))
2792       (ada-get-indent-loop orgpoint))
2793
2794      ;; declare label
2795      ((save-excursion
2796         (setq match-cons (ada-search-ignore-string-comment
2797                           "\\<declare\\|begin\\>" nil orgpoint)))
2798       (goto-char (car match-cons))
2799       (list (save-excursion (back-to-indentation) (point)) 'ada-indent))
2800
2801      ;; variable declaration
2802      ((ada-in-decl-p)
2803       (if (save-excursion
2804             (ada-search-ignore-string-comment ";" nil orgpoint))
2805           (list cur-indent 0)
2806         (list cur-indent 'ada-broken-indent)))
2807
2808      ;; nothing follows colon
2809      (t
2810       (list cur-indent '(- ada-label-indent))))))
2811
2812 (defun ada-get-indent-loop (orgpoint)
2813   "Calculates the indentation when just before a loop or a for ... use.
2814 ORGPOINT is the limit position used in the calculation."
2815   (let ((match-cons nil)
2816         (pos (point))
2817
2818         ;; If looking at a named block, skip the label
2819         (label (save-excursion
2820                  (beginning-of-line)
2821                  (if (looking-at ada-named-block-re)
2822                      (- ada-label-indent)
2823                    0))))
2824
2825     (cond
2826
2827      ;;
2828      ;; statement complete
2829      ;;
2830      ((save-excursion
2831         (ada-search-ignore-string-comment ";" nil orgpoint nil
2832                                           'search-forward))
2833       (list (+ (save-excursion (back-to-indentation) (point)) label) 0))
2834      ;;
2835      ;; simple loop
2836      ;;
2837      ((looking-at "loop\\>")
2838       (setq pos (ada-get-indent-block-start orgpoint))
2839       (if (equal label 0)
2840           pos
2841         (list (+ (car pos) label) (cdr pos))))
2842
2843      ;;
2844      ;; 'for'- loop (or also a for ... use statement)
2845      ;;
2846      ((looking-at "for\\>")
2847       (cond
2848        ;;
2849        ;; for ... use
2850        ;;
2851        ((save-excursion
2852           (and
2853            (goto-char (match-end 0))
2854            (ada-goto-next-non-ws orgpoint)
2855            (forward-word 1)
2856            (if (= (char-after) ?') (forward-word 1) t)
2857            (ada-goto-next-non-ws orgpoint)
2858            (looking-at "\\<use\\>")
2859            ;;
2860            ;; check if there is a 'record' before point
2861            ;;
2862            (progn
2863              (setq match-cons (ada-search-ignore-string-comment
2864                                "record" nil orgpoint nil 'word-search-forward))
2865              t)))
2866         (if match-cons
2867             (goto-char (car match-cons)))
2868         (list (save-excursion (back-to-indentation) (point)) 'ada-indent))
2869        ;;
2870        ;; for..loop
2871        ;;
2872        ((save-excursion
2873           (setq match-cons (ada-search-ignore-string-comment
2874                             "loop" nil orgpoint nil 'word-search-forward)))
2875         (goto-char (car match-cons))
2876         ;;
2877         ;; indent according to 'loop', if it's first in the line;
2878         ;; otherwise to 'for'
2879         ;;
2880         (unless (save-excursion
2881                   (back-to-indentation)
2882                   (looking-at "\\<loop\\>"))
2883           (goto-char pos))
2884         (list (+ (save-excursion (back-to-indentation) (point)) label)
2885               'ada-indent))
2886        ;;
2887        ;; for-statement is broken
2888        ;;
2889        (t
2890         (list (+ (save-excursion (back-to-indentation) (point)) label)
2891               'ada-broken-indent))))
2892
2893      ;;
2894      ;; 'while'-loop
2895      ;;
2896      ((looking-at "while\\>")
2897       ;;
2898       ;; while..loop ?
2899       ;;
2900       (if (save-excursion
2901             (setq match-cons (ada-search-ignore-string-comment
2902                               "loop" nil orgpoint nil 'word-search-forward)))
2903
2904           (progn
2905             (goto-char (car match-cons))
2906             ;;
2907             ;; indent according to 'loop', if it's first in the line;
2908             ;; otherwise to 'while'.
2909             ;;
2910             (unless (save-excursion
2911                       (back-to-indentation)
2912                       (looking-at "\\<loop\\>"))
2913               (goto-char pos))
2914             (list (+ (save-excursion (back-to-indentation) (point)) label)
2915                   'ada-indent))
2916
2917         (list (+ (save-excursion (back-to-indentation) (point)) label)
2918               'ada-broken-indent))))))
2919
2920 (defun ada-get-indent-type (orgpoint)
2921   "Calculates the indentation when before a type statement.
2922 ORGPOINT is the limit position used in the calculation."
2923   (let ((match-dat nil))
2924     (cond
2925      ;;
2926      ;; complete record declaration
2927      ;;
2928      ((save-excursion
2929         (and
2930          (setq match-dat (ada-search-ignore-string-comment
2931                           "end" nil orgpoint nil 'word-search-forward))
2932          (ada-goto-next-non-ws)
2933          (looking-at "\\<record\\>")
2934          (forward-word 1)
2935          (ada-goto-next-non-ws)
2936          (= (char-after) ?\;)))
2937       (goto-char (car match-dat))
2938       (list (save-excursion (back-to-indentation) (point)) 0))
2939      ;;
2940      ;; record type
2941      ;;
2942      ((save-excursion
2943         (setq match-dat (ada-search-ignore-string-comment
2944                          "record" nil orgpoint nil 'word-search-forward)))
2945       (goto-char (car match-dat))
2946       (list (save-excursion (back-to-indentation) (point)) 'ada-indent))
2947      ;;
2948      ;; complete type declaration
2949      ;;
2950      ((save-excursion
2951         (ada-search-ignore-string-comment ";" nil orgpoint nil
2952                                           'search-forward))
2953       (list (save-excursion (back-to-indentation) (point)) 0))
2954      ;;
2955      ;; "type ... is", but not "type ... is ...", which is broken
2956      ;;
2957      ((save-excursion
2958         (and
2959          (ada-search-ignore-string-comment "is" nil orgpoint nil
2960                                            'word-search-forward)
2961          (not (ada-goto-next-non-ws orgpoint))))
2962       (list (save-excursion (back-to-indentation) (point)) 'ada-broken-indent))
2963      ;;
2964      ;; broken statement
2965      ;;
2966      (t
2967       (list (save-excursion (back-to-indentation) (point))
2968             'ada-broken-indent)))))
2969
2970 \f
2971 ;; -----------------------------------------------------------
2972 ;; -- searching and matching
2973 ;; -----------------------------------------------------------
2974
2975 (defun ada-goto-stmt-start ()
2976   "Moves point to the beginning of the statement that point is in or after.
2977 Returns the new position of point.
2978 As a special case, if we are looking at a closing parenthesis, skip to the
2979 open parenthesis."
2980   (let ((match-dat nil)
2981         (orgpoint (point)))
2982
2983     (setq match-dat (ada-search-prev-end-stmt))
2984     (if match-dat
2985
2986         ;;
2987         ;; found a previous end-statement => check if anything follows
2988         ;;
2989         (unless (looking-at "declare")
2990           (progn
2991             (unless (save-excursion
2992                       (goto-char (cdr match-dat))
2993                       (ada-goto-next-non-ws orgpoint))
2994               ;;
2995               ;; nothing follows => it's the end-statement directly in
2996               ;;                    front of point => search again
2997               ;;
2998               (setq match-dat (ada-search-prev-end-stmt)))
2999             ;;
3000             ;; if found the correct end-statement => goto next non-ws
3001             ;;
3002             (if match-dat
3003                 (goto-char (cdr match-dat)))
3004             (ada-goto-next-non-ws)
3005             ))
3006
3007       ;;
3008       ;; no previous end-statement => we are at the beginning of the
3009       ;;                              accessible part of the buffer
3010       ;;
3011       (progn
3012         (goto-char (point-min))
3013         ;;
3014         ;; skip to the very first statement, if there is one
3015           ;;
3016         (unless (ada-goto-next-non-ws orgpoint)
3017           (goto-char orgpoint))))
3018     (point)))
3019
3020
3021 (defun ada-search-prev-end-stmt ()
3022   "Moves point to previous end-statement.
3023 Returns a cons cell whose car is the beginning and whose cdr the end of the
3024 match."
3025   (let ((match-dat nil)
3026         (found nil))
3027
3028     ;; search until found or beginning-of-buffer
3029     (while
3030         (and
3031          (not found)
3032          (setq match-dat (ada-search-ignore-string-comment
3033                           ada-end-stmt-re t)))
3034
3035       (goto-char (car match-dat))
3036       (unless (ada-in-open-paren-p)
3037         (if (and (looking-at
3038                   "\\<\\(record\\|loop\\|select\\|else\\|then\\)\\>")
3039                  (save-excursion
3040                    (ada-goto-previous-word)
3041                    (looking-at "\\<\\(end\\|or\\|and\\)\\>[ \t]*[^;]")))
3042             (forward-word -1)
3043
3044           (save-excursion
3045             (goto-char (cdr match-dat))
3046             (ada-goto-next-non-ws)
3047             (looking-at "(")
3048             ;;  words that can go after an 'is'
3049             (unless (looking-at
3050                      (eval-when-compile
3051                        (concat "\\<"
3052                                (regexp-opt '("separate" "access" "array"
3053                                              "abstract" "new") t)
3054                                "\\>\\|(")))
3055               (setq found t))))
3056         ))
3057
3058     (if found
3059         match-dat
3060       nil)))
3061
3062
3063 (defun ada-goto-next-non-ws (&optional limit)
3064   "Skips white spaces, newlines and comments to next non-ws character.
3065 Stop the search at LIMIT.
3066 Do not call this function from within a string."
3067   (unless limit
3068     (setq limit (point-max)))
3069   (while (and (<= (point) limit)
3070               (progn (forward-comment 10000)
3071                      (if (and (not (eobp))
3072                               (save-excursion (forward-char 1)
3073                                               (ada-in-string-p)))
3074                          (progn (forward-sexp 1) t)))))
3075   (if (< (point) limit)
3076       (point)
3077     nil)
3078   )
3079
3080
3081 (defun ada-goto-stmt-end (&optional limit)
3082   "Moves point to the end of the statement that point is in or before.
3083 Returns the new position of point or nil if not found.
3084 Stop the search at LIMIT."
3085   (if (ada-search-ignore-string-comment ada-end-stmt-re nil limit)
3086       (point)
3087     nil))
3088
3089
3090 (defun ada-goto-next-word (&optional backward)
3091   "Moves point to the beginning of the next word of Ada code.
3092 If BACKWARD is non-nil, jump to the beginning of the previous word.
3093 Returns the new position of point or nil if not found."
3094   (let ((match-cons nil)
3095         (orgpoint (point))
3096         (old-syntax (char-to-string (char-syntax ?_))))
3097     (modify-syntax-entry ?_ "w")
3098     (unless backward
3099       (skip-syntax-forward "w"))
3100     (if (setq match-cons
3101              (if backward
3102                  (ada-search-ignore-string-comment "\\w" t nil t)
3103                (ada-search-ignore-string-comment "\\w" nil nil t)))
3104         ;;
3105         ;; move to the beginning of the word found
3106         ;;
3107         (progn
3108           (goto-char (car match-cons))
3109           (skip-syntax-backward "w")
3110           (point))
3111       ;;
3112       ;; if not found, restore old position of point
3113       ;;
3114       (goto-char orgpoint)
3115       'nil)
3116     (modify-syntax-entry ?_ old-syntax))
3117   )
3118
3119
3120 (defun ada-check-matching-start (keyword)
3121   "Signals an error if matching block start is not KEYWORD.
3122 Moves point to the matching block start."
3123   (ada-goto-matching-start 0)
3124   (unless (looking-at (concat "\\<" keyword "\\>"))
3125     (error "matching start is not '%s'" keyword)))
3126
3127
3128 (defun ada-check-defun-name (defun-name)
3129   "Checks if the name of the matching defun really is DEFUN-NAME.
3130 Assumes point to be already positioned by 'ada-goto-matching-start'.
3131 Moves point to the beginning of the declaration."
3132
3133   ;; named block without a `declare'
3134   (if (save-excursion
3135         (ada-goto-previous-word)
3136         (looking-at (concat "\\<" defun-name "\\> *:")))
3137       t                                 ; do nothing
3138     ;;
3139     ;; 'accept' or 'package' ?
3140     ;;
3141     (unless (looking-at ada-subprog-start-re)
3142       (ada-goto-matching-decl-start))
3143     ;;
3144     ;; 'begin' of 'procedure'/'function'/'task' or 'declare'
3145     ;;
3146     (save-excursion
3147       ;;
3148       ;; a named 'declare'-block ?
3149       ;;
3150       (if (looking-at "\\<declare\\>")
3151           (ada-goto-stmt-start)
3152         ;;
3153         ;; no, => 'procedure'/'function'/'task'/'protected'
3154         ;;
3155         (progn
3156           (forward-word 2)
3157           (backward-word 1)
3158           ;;
3159           ;; skip 'body' 'type'
3160           ;;
3161           (if (looking-at "\\<\\(body\\|type\\)\\>")
3162               (forward-word 1))
3163           (forward-sexp 1)
3164           (backward-sexp 1)))
3165       ;;
3166       ;; should be looking-at the correct name
3167       ;;
3168       (unless (looking-at (concat "\\<" defun-name "\\>"))
3169         (error "matching defun has different name: %s"
3170                (buffer-substring (point)
3171                                  (progn (forward-sexp 1) (point))))))))
3172
3173 (defun ada-goto-matching-decl-start (&optional noerror recursive)
3174   "Moves point to the matching declaration start of the current 'begin'.
3175 If NOERROR is non-nil, it only returns nil if no match was found."
3176   (let ((nest-count 1)
3177         (first (not recursive))
3178         (count-generic nil)
3179         (stop-at-when nil)
3180         )
3181
3182     ;;  Ignore "when" most of the time, except if we are looking at the
3183     ;;  beginning of a block (structure:  case .. is
3184     ;;                                    when ... =>
3185     ;;                                       begin ...
3186     ;;                                       exception ... )
3187     (if (looking-at "begin")
3188         (setq stop-at-when t))
3189
3190     (if (or
3191          (looking-at "\\<\\(package\\|procedure\\|function\\)\\>")
3192          (save-excursion
3193            (ada-search-ignore-string-comment
3194             "\\<\\(package\\|procedure\\|function\\|generic\\)\\>" t)
3195            (looking-at "generic")))
3196         (setq count-generic t))
3197
3198     ;; search backward for interesting keywords
3199     (while (and
3200             (not (zerop nest-count))
3201             (ada-search-ignore-string-comment ada-matching-decl-start-re t))
3202       ;;
3203       ;; calculate nest-depth
3204       ;;
3205       (cond
3206        ;;
3207        ((looking-at "end")
3208         (ada-goto-matching-start 1 noerror)
3209
3210         ;;  In some case, two begin..end block can follow each other closely,
3211         ;;  which we have to detect, as in
3212         ;;     procedure P is
3213         ;;        procedure Q is
3214         ;;        begin
3215         ;;        end;
3216         ;;     begin    --  here we should go to procedure, not begin
3217         ;;     end
3218
3219         (if (looking-at "begin")
3220             (let ((loop-again t))
3221               (save-excursion
3222                 (while loop-again
3223                   ;;  If begin was just there as the beginning of a block
3224                   ;;  (with no declare) then do nothing, otherwise just
3225                   ;;  register that we have to find the statement that
3226                   ;;  required the begin
3227
3228                   (ada-search-ignore-string-comment
3229                    "\\<\\(declare\\|begin\\|end\\|procedure\\|function\\|task\\|package\\)\\>"
3230                    t)
3231
3232                   (if (looking-at "end")
3233                       (ada-goto-matching-decl-start noerror t)
3234
3235                     (setq loop-again nil)
3236                     (unless (looking-at "begin")
3237                       (setq nest-count (1+ nest-count))))
3238                   ))
3239               )))
3240        ;;
3241        ((looking-at "generic")
3242         (if count-generic
3243             (progn
3244               (setq first nil)
3245               (setq nest-count (1- nest-count)))))
3246        ;;
3247        ((looking-at "if")
3248         (save-excursion
3249           (forward-word -1)
3250           (unless (looking-at "\\<end[ \t\n]*if\\>")
3251             (progn
3252               (setq nest-count (1- nest-count))
3253               (setq first nil)))))
3254
3255        ;;
3256        ((looking-at "declare\\|generic")
3257         (setq nest-count (1- nest-count))
3258         (setq first nil))
3259        ;;
3260        ((looking-at "is")
3261         ;; check if it is only a type definition, but not a protected
3262         ;; type definition, which should be handled like a procedure.
3263         (if (or (looking-at "is[ \t]+<>")
3264                 (save-excursion
3265                   (forward-comment -10000)
3266                   (forward-char -1)
3267
3268                   ;; Detect if we have a closing parenthesis (Could be
3269                   ;; either the end of subprogram parameters or (<>)
3270                   ;; in a type definition
3271                   (if (= (char-after) ?\))
3272                       (progn
3273                         (forward-char 1)
3274                         (backward-sexp 1)
3275                         (forward-comment -10000)
3276                         ))
3277                   (skip-chars-backward "a-zA-Z0-9_.'")
3278                   (ada-goto-previous-word)
3279                   (and
3280                    (looking-at "\\<\\(sub\\)?type\\>")
3281                    (save-match-data
3282                      (ada-goto-previous-word)
3283                      (not (looking-at "\\<protected\\>"))))
3284                   ))                    ; end of `or'
3285             (goto-char (match-beginning 0))
3286           (progn
3287             (setq nest-count (1- nest-count))
3288             (setq first nil))))
3289
3290        ;;
3291        ((looking-at "new")
3292         (if (save-excursion
3293               (ada-goto-previous-word)
3294               (looking-at "is"))
3295             (goto-char (match-beginning 0))))
3296        ;;
3297        ((and first
3298              (looking-at "begin"))
3299         (setq nest-count 0))
3300        ;;
3301        ((looking-at "when")
3302         (if stop-at-when
3303             (setq nest-count (1- nest-count)))
3304         (setq first nil))
3305        ;;
3306        (t
3307         (setq nest-count (1+ nest-count))
3308         (setq first nil)))
3309
3310       );; end of loop
3311
3312     ;; check if declaration-start is really found
3313     (if (and
3314          (zerop nest-count)
3315          (if (looking-at "is")
3316              (ada-search-ignore-string-comment ada-subprog-start-re t)
3317            (looking-at "declare\\|generic")))
3318         t
3319       (if noerror nil
3320         (error "no matching proc/func/task/declare/package/protected")))
3321     ))
3322
3323 (defun ada-goto-matching-start (&optional nest-level noerror gotothen)
3324   "Moves point to the beginning of a block-start.
3325 Which block depends on the value of NEST-LEVEL, which defaults to zero. If
3326 NOERROR is non-nil, it only returns nil if no matching start was found.
3327 If GOTOTHEN is non-nil, point moves to the 'then' following 'if'."
3328   (let ((nest-count (if nest-level nest-level 0))
3329         (found nil)
3330         (pos nil))
3331
3332     ;;
3333     ;; search backward for interesting keywords
3334     ;;
3335     (while (and
3336             (not found)
3337             (ada-search-ignore-string-comment ada-matching-start-re t))
3338
3339       (unless (and (looking-at "\\<record\\>")
3340                    (save-excursion
3341                      (forward-word -1)
3342                      (looking-at "\\<null\\>")))
3343         (progn
3344           ;;
3345           ;; calculate nest-depth
3346           ;;
3347           (cond
3348            ;; found block end => increase nest depth
3349            ((looking-at "end")
3350             (setq nest-count (1+ nest-count)))
3351
3352            ;; found loop/select/record/case/if => check if it starts or
3353            ;; ends a block
3354            ((looking-at "loop\\|select\\|record\\|case\\|if")
3355             (setq pos (point))
3356             (save-excursion
3357               ;;
3358               ;; check if keyword follows 'end'
3359               ;;
3360               (ada-goto-previous-word)
3361               (if (looking-at "\\<end\\>[ \t]*[^;]")
3362                   ;; it ends a block => increase nest depth
3363                   (progn
3364                     (setq nest-count (1+ nest-count))
3365                     (setq pos (point)))
3366                 ;; it starts a block => decrease nest depth
3367                 (setq nest-count (1- nest-count))))
3368             (goto-char pos))
3369
3370            ;; found package start => check if it really is a block
3371            ((looking-at "package")
3372             (save-excursion
3373               ;; ignore if this is just a renames statement
3374               (let ((current (point))
3375                     (pos (ada-search-ignore-string-comment
3376                           "\\<\\(is\\|renames\\|;\\)\\>" nil)))
3377                 (if pos
3378                     (goto-char (car pos))
3379                   (error (concat
3380                           "No matching 'is' or 'renames' for 'package' at"
3381                           " line "
3382                           (number-to-string (count-lines (point-min)
3383                                                          (1+ current)))))))
3384               (unless (looking-at "renames")
3385                 (progn
3386                   (forward-word 1)
3387                   (ada-goto-next-non-ws)
3388                   ;; ignore it if it is only a declaration with 'new'
3389                   (if (not (looking-at "\\<\\(new\\|separate\\)\\>"))
3390                       (setq nest-count (1- nest-count)))))))
3391            ;; found task start => check if it has a body
3392            ((looking-at "task")
3393             (save-excursion
3394               (forward-word 1)
3395               (ada-goto-next-non-ws)
3396               (cond
3397                ((looking-at "\\<body\\>"))
3398                ((looking-at "\\<type\\>")
3399                 ;;  In that case, do nothing if there is a "is"
3400                 (forward-word 2);; skip "type"
3401                 (ada-goto-next-non-ws);; skip type name
3402
3403                 ;; Do nothing if we are simply looking at a simple
3404                 ;; "task type name;" statement with no block
3405                 (unless (looking-at ";")
3406                   (progn
3407                     ;; Skip the parameters
3408                     (if (looking-at "(")
3409                         (ada-search-ignore-string-comment ")" nil))
3410                     (let ((tmp (ada-search-ignore-string-comment
3411                                 "\\<\\(is\\|;\\)\\>" nil)))
3412                       (if tmp
3413                           (progn
3414                             (goto-char (car tmp))
3415                             (if (looking-at "is")
3416                                 (setq nest-count (1- nest-count)))))))))
3417                (t
3418                 ;; Check if that task declaration had a block attached to
3419                 ;; it (i.e do nothing if we have just "task name;")
3420                 (unless (progn (forward-word 1)
3421                                (looking-at "[ \t]*;"))
3422                   (setq nest-count (1- nest-count)))))))
3423            ;; all the other block starts
3424            (t
3425             (setq nest-count (1- nest-count)))) ; end of 'cond'
3426
3427           ;; match is found, if nest-depth is zero
3428           ;;
3429           (setq found (zerop nest-count))))) ; end of loop
3430
3431     (if found
3432         ;;
3433         ;; match found => is there anything else to do ?
3434         ;;
3435         (progn
3436           (cond
3437            ;;
3438            ;; found 'if' => skip to 'then', if it's on a separate line
3439            ;;                               and GOTOTHEN is non-nil
3440            ;;
3441            ((and
3442              gotothen
3443              (looking-at "if")
3444              (save-excursion
3445                (ada-search-ignore-string-comment "then" nil nil nil
3446                                                  'word-search-forward)
3447                (back-to-indentation)
3448                (looking-at "\\<then\\>")))
3449             (goto-char (match-beginning 0)))
3450            ;;
3451            ;; found 'do' => skip back to 'accept'
3452            ;;
3453            ((looking-at "do")
3454             (unless (ada-search-ignore-string-comment "accept" t nil nil
3455                                                       'word-search-backward)
3456               (error "missing 'accept' in front of 'do'"))))
3457           (point))
3458
3459       (if noerror
3460           nil
3461         (error "no matching start")))))
3462
3463
3464 (defun ada-goto-matching-end (&optional nest-level noerror)
3465   "Moves point to the end of a block.
3466 Which block depends on the value of NEST-LEVEL, which defaults to zero.
3467 If NOERROR is non-nil, it only returns nil if found no matching start."
3468   (let ((nest-count (if nest-level nest-level 0))
3469         (found nil))
3470
3471     ;;
3472     ;; search forward for interesting keywords
3473     ;;
3474     (while (and
3475             (not found)
3476             (ada-search-ignore-string-comment
3477              (eval-when-compile
3478                (concat "\\<"
3479                        (regexp-opt '("end" "loop" "select" "begin" "case"
3480                                      "if" "task" "package" "record" "do") t)
3481                        "\\>")) nil))
3482
3483       ;;
3484       ;; calculate nest-depth
3485       ;;
3486       (backward-word 1)
3487       (cond
3488        ;; found block end => decrease nest depth
3489        ((looking-at "\\<end\\>")
3490         (setq nest-count (1- nest-count))
3491         ;; skip the following keyword
3492         (if (progn
3493               (skip-chars-forward "end")
3494               (ada-goto-next-non-ws)
3495               (looking-at "\\<\\(loop\\|select\\|record\\|case\\|if\\)\\>"))
3496             (forward-word 1)))
3497        ;; found package start => check if it really starts a block
3498        ((looking-at "\\<package\\>")
3499         (ada-search-ignore-string-comment "is" nil nil nil
3500                                           'word-search-forward)
3501         (ada-goto-next-non-ws)
3502         ;; ignore and skip it if it is only a 'new' package
3503         (if (looking-at "\\<new\\>")
3504             (goto-char (match-end 0))
3505           (setq nest-count (1+ nest-count))))
3506        ;; all the other block starts
3507        (t
3508         (setq nest-count (1+ nest-count))
3509         (forward-word 1)))              ; end of 'cond'
3510
3511       ;; match is found, if nest-depth is zero
3512       ;;
3513       (setq found (zerop nest-count)))  ; end of loop
3514
3515     (if found
3516         t
3517       (if noerror
3518           nil
3519         (error "no matching end")))
3520     ))
3521
3522
3523 (defun ada-search-ignore-string-comment
3524   (search-re &optional backward limit paramlists search-func)
3525   "Regexp-search for SEARCH-RE, ignoring comments, strings.
3526 If PARAMLISTS is nil, ignore parameter lists. Returns a cons cell of
3527 begin and end of match data or nil, if not found.
3528 The search is done using SEARCH-FUNC, which should search backward if
3529 BACKWARD is non-nil, forward otherwise. SEARCH-FUNC can be optimized in case
3530 we are searching for a constant string.
3531 The search stops at pos LIMIT.
3532 Point is moved at the beginning of the search-re."
3533   (let (found
3534         begin
3535         end
3536         parse-result
3537         (previous-syntax-table (syntax-table)))
3538
3539     (unless search-func
3540       (setq search-func (if backward 're-search-backward 're-search-forward)))
3541
3542     ;;
3543     ;; search until found or end-of-buffer
3544     ;; We have to test that we do not look further than limit
3545     ;;
3546     (set-syntax-table ada-mode-symbol-syntax-table)
3547     (while (and (not found)
3548                 (or (not limit)
3549                     (or (and backward (<= limit (point)))
3550                         (>= limit (point))))
3551                 (funcall search-func search-re limit 1))
3552       (setq begin (match-beginning 0))
3553       (setq end (match-end 0))
3554
3555       (setq parse-result (parse-partial-sexp
3556                           (save-excursion (beginning-of-line) (point))
3557                           (point)))
3558
3559       (cond
3560        ;;
3561        ;; If inside a string, skip it (and the following comments)
3562        ;;
3563        ((ada-in-string-p parse-result)
3564         (if ada-xemacs
3565             (search-backward "\"" nil t)
3566           (goto-char (nth 8 parse-result)))
3567         (unless backward (forward-sexp 1)))
3568        ;;
3569        ;; If inside a comment, skip it (and the following comments)
3570        ;; There is a special code for comments at the end of the file
3571        ;;
3572        ((ada-in-comment-p parse-result)
3573         (if ada-xemacs
3574             (progn
3575               (forward-line 1)
3576               (beginning-of-line)
3577               (forward-comment -1))
3578           (goto-char (nth 8 parse-result)))
3579         (unless backward
3580           ;;  at the end of the file, it is not possible to skip a comment
3581           ;;  so we just go at the end of the line
3582           (if (forward-comment 1)
3583               (progn
3584                 (forward-comment 1000)
3585                 (beginning-of-line))
3586             (end-of-line))))
3587        ;;
3588        ;; directly in front of a comment => skip it, if searching forward
3589        ;;
3590        ((and (= (char-after begin) ?-) (= (char-after (1+ begin)) ?-))
3591         (unless backward (progn (forward-char -1) (forward-comment 1000))))
3592
3593        ;;
3594        ;; found a parameter-list but should ignore it => skip it
3595        ;;
3596        ((and (not paramlists) (ada-in-paramlist-p))
3597         (if backward
3598             (search-backward "(" nil t)
3599           (search-forward ")" nil t)))
3600        ;;
3601        ;; found what we were looking for
3602        ;;
3603        (t
3604         (setq found t))))               ; end of loop
3605
3606     (set-syntax-table previous-syntax-table)
3607
3608     (if found
3609         (cons begin end)
3610       nil)))
3611
3612 ;; -------------------------------------------------------
3613 ;; --  Testing the position of the cursor
3614 ;; -------------------------------------------------------
3615
3616 (defun ada-in-decl-p ()
3617   "Returns t if point is inside a declarative part.
3618 Assumes point to be at the end of a statement."
3619   (or (ada-in-paramlist-p)
3620       (save-excursion
3621         (ada-goto-matching-decl-start t))))
3622
3623
3624 (defun ada-looking-at-semi-or ()
3625   "Returns t if looking-at an 'or' following a semicolon."
3626   (save-excursion
3627     (and (looking-at "\\<or\\>")
3628          (progn
3629            (forward-word 1)
3630            (ada-goto-stmt-start)
3631            (looking-at "\\<or\\>")))))
3632
3633
3634 (defun ada-looking-at-semi-private ()
3635   "Returns t if looking at the start of a private section in a package.
3636 Returns nil if the private is part of the package name, as in
3637 'private package A is...' (this can only happen at top level)."
3638   (save-excursion
3639     (and (looking-at "\\<private\\>")
3640          (not (looking-at "\\<private[ \t]*\\(package\\|generic\\)"))
3641
3642          ;;  Make sure this is the start of a private section (ie after
3643          ;;  a semicolon or just after the package declaration, but not
3644          ;;  after a 'type ... is private' or 'is new ... with private'
3645          (progn (forward-comment -1000)
3646                 (or (= (char-before) ?\;)
3647                     (and (forward-word -3)
3648                          (looking-at "\\<package\\>")))))))
3649
3650
3651 (defun ada-in-paramlist-p ()
3652   "Returns t if point is inside a parameter-list."
3653   (save-excursion
3654     (and
3655      (ada-search-ignore-string-comment "(\\|)" t nil t)
3656      ;; inside parentheses ?
3657      (= (char-after) ?\()
3658
3659      ;; We could be looking at two things here:
3660      ;;  operator definition:   function "." (
3661      ;;  subprogram definition: procedure .... (
3662      ;; Let's skip back over the first one
3663      (progn
3664        (skip-syntax-backward " ")
3665        (if (= (char-before) ?\")
3666            (backward-char 3)
3667          (backward-word 1))
3668        t)
3669
3670      ;; and now over the second one
3671      (backward-word 1)
3672
3673      ;; We should ignore the case when the reserved keyword is in a
3674      ;; comment (for instance, when we have:
3675      ;;    -- .... package
3676      ;;    Test (A)
3677      ;; we should return nil
3678
3679      (not (ada-in-string-or-comment-p))
3680
3681      ;; right keyword two words before parenthesis ?
3682      ;; Type is in this list because of discriminants
3683      (looking-at (eval-when-compile
3684                    (concat "\\<\\("
3685                            "procedure\\|function\\|body\\|"
3686                            "task\\|entry\\|accept\\|"
3687                            "access[ \t]+procedure\\|"
3688                            "access[ \t]+function\\|"
3689                            "pragma\\|"
3690                            "type\\)\\>"))))))
3691
3692 (defun ada-search-ignore-complex-boolean (regexp backwardp)
3693   "Like `ada-search-ignore-string-comment', except that it also ignores
3694 boolean expressions 'and then' and 'or else'."
3695   (let (result)
3696   (while (and (setq result (ada-search-ignore-string-comment regexp backwardp))
3697               (save-excursion (forward-word -1)
3698                               (looking-at "and then\\|or else"))))
3699   result))
3700
3701 (defun ada-in-open-paren-p ()
3702   "Returns the position of the first non-ws behind the last unclosed
3703 parenthesis, or nil."
3704   (save-excursion
3705     (let ((parse (parse-partial-sexp
3706                   (point)
3707                   (or (car (ada-search-ignore-complex-boolean
3708                             "\\<\\(;\\|is\\|then\\|loop\\|begin\\|else\\)\\>"
3709                             t))
3710                       (point-min)))))
3711
3712       (if (nth 1 parse)
3713           (progn
3714             (goto-char (1+ (nth 1 parse)))
3715             (skip-chars-forward " \t")
3716             (point))))))
3717
3718 \f
3719 ;; -----------------------------------------------------------
3720 ;; --  Behavior Of TAB Key
3721 ;; -----------------------------------------------------------
3722
3723 (defun ada-tab ()
3724   "Do indenting or tabbing according to `ada-tab-policy'.
3725 In Transient Mark mode, if the mark is active, operate on the contents
3726 of the region.  Otherwise, operates only on the current line."
3727   (interactive)
3728   (cond ((eq ada-tab-policy 'indent-rigidly) (ada-tab-hard))
3729         ((eq ada-tab-policy 'indent-auto)
3730          ;;  transient-mark-mode and mark-active are not defined in XEmacs
3731          (if (or (and ada-xemacs (funcall (symbol-function 'region-active-p)))
3732                  (and (not ada-xemacs)
3733                       (symbol-value 'transient-mark-mode)
3734                       (symbol-value 'mark-active)))
3735              (ada-indent-region (region-beginning) (region-end))
3736            (ada-indent-current)))
3737         ((eq ada-tab-policy 'always-tab) (error "not implemented"))
3738         ))
3739
3740 (defun ada-untab (arg)
3741   "Delete leading indenting according to `ada-tab-policy'."
3742   (interactive "P")
3743   (cond ((eq ada-tab-policy 'indent-rigidly) (ada-untab-hard))
3744         ((eq ada-tab-policy 'indent-auto) (error "not implemented"))
3745         ((eq ada-tab-policy 'always-tab) (error "not implemented"))
3746         ))
3747
3748 (defun ada-indent-current-function ()
3749   "Ada mode version of the indent-line-function."
3750   (interactive "*")
3751   (let ((starting-point (point-marker)))
3752     (beginning-of-line)
3753     (ada-tab)
3754     (if (< (point) starting-point)
3755         (goto-char starting-point))
3756     (set-marker starting-point nil)
3757     ))
3758
3759 (defun ada-tab-hard ()
3760   "Indent current line to next tab stop."
3761   (interactive)
3762   (save-excursion
3763     (beginning-of-line)
3764     (insert-char ?  ada-indent))
3765   (if (save-excursion (= (point) (progn (beginning-of-line) (point))))
3766       (forward-char ada-indent)))
3767
3768 (defun ada-untab-hard ()
3769   "indent current line to previous tab stop."
3770   (interactive)
3771   (let  ((bol (save-excursion (progn (beginning-of-line) (point))))
3772          (eol (save-excursion (progn (end-of-line) (point)))))
3773     (indent-rigidly bol eol  (- 0 ada-indent))))
3774
3775
3776 \f
3777 ;; ------------------------------------------------------------
3778 ;; --  Miscellaneous
3779 ;; ------------------------------------------------------------
3780
3781 (defun ada-gnat-style ()
3782   "Clean up comments, `(' and `,' for GNAT style checking switch."
3783   (interactive)
3784   (save-excursion
3785     (goto-char (point-min))
3786     (while (re-search-forward "--[ \t]*\\([^-]\\)" nil t)
3787       (replace-match "--  \\1"))
3788     (goto-char (point-min))
3789     (while (re-search-forward "\\>(" nil t)
3790       (replace-match " ("))
3791     (goto-char (point-min))
3792     (while (re-search-forward "([ \t]+" nil t)
3793       (replace-match "("))
3794     (goto-char (point-min))
3795     (while (re-search-forward ")[ \t]+)" nil t)
3796       (replace-match "))"))
3797     (goto-char (point-min))
3798     (while (re-search-forward "\\>:" nil t)
3799       (replace-match " :"))
3800     (goto-char (point-min))
3801     (while (re-search-forward ",\\<" nil t)
3802       (replace-match ", "))
3803     (goto-char (point-min))
3804     (while (re-search-forward "[ \t]*\\.\\.[ \t]*" nil t)
3805       (replace-match " .. "))
3806     (goto-char (point-min))
3807     (while (re-search-forward "[ \t]*\\([-:+*/]\\)[ \t]*" nil t)
3808       (if (not (ada-in-string-or-comment-p))
3809           (progn
3810             (forward-char -1)
3811             (cond
3812              ((looking-at "/=")
3813               (replace-match " /= "))
3814              ((looking-at ":=")
3815               (replace-match ":= "))
3816              ((not (looking-at "--"))
3817               (replace-match " \\1 ")))
3818             (forward-char 2))))
3819     ))
3820
3821
3822 \f
3823 ;; -------------------------------------------------------------
3824 ;; --  Moving To Procedures/Packages/Statements
3825 ;; -------------------------------------------------------------
3826
3827 (defun ada-move-to-start ()
3828   "Moves point to the matching start of the current Ada structure."
3829   (interactive)
3830   (let ((pos (point))
3831         (previous-syntax-table (syntax-table)))
3832     (unwind-protect
3833         (progn
3834           (set-syntax-table ada-mode-symbol-syntax-table)
3835
3836           (message "searching for block start ...")
3837           (save-excursion
3838             ;;
3839             ;; do nothing if in string or comment or not on 'end ...;'
3840             ;;            or if an error occurs during processing
3841             ;;
3842             (or
3843              (ada-in-string-or-comment-p)
3844              (and (progn
3845                     (or (looking-at "[ \t]*\\<end\\>")
3846                         (backward-word 1))
3847                     (or (looking-at "[ \t]*\\<end\\>")
3848                         (backward-word 1))
3849                     (or (looking-at "[ \t]*\\<end\\>")
3850                         (error "not on end ...;")))
3851                   (ada-goto-matching-start 1)
3852                   (setq pos (point))
3853
3854                   ;;
3855                   ;; on 'begin' => go on, according to user option
3856                   ;;
3857                   ada-move-to-declaration
3858                   (looking-at "\\<begin\\>")
3859                   (ada-goto-matching-decl-start)
3860                   (setq pos (point))))
3861
3862             )                           ; end of save-excursion
3863
3864           ;; now really move to the found position
3865           (goto-char pos)
3866           (message "searching for block start ... done"))
3867
3868       ;; restore syntax-table
3869       (set-syntax-table previous-syntax-table))))
3870
3871 (defun ada-move-to-end ()
3872   "Moves point to the matching end of the block around point.
3873 Moves to 'begin' if in a declarative part."
3874   (interactive)
3875   (let ((pos (point))
3876         (previous-syntax-table (syntax-table)))
3877     (unwind-protect
3878         (progn
3879           (set-syntax-table ada-mode-symbol-syntax-table)
3880
3881           (message "searching for block end ...")
3882           (save-excursion
3883
3884             (forward-char 1)
3885             (cond
3886              ;; directly on 'begin'
3887              ((save-excursion
3888                 (ada-goto-previous-word)
3889                 (looking-at "\\<begin\\>"))
3890               (ada-goto-matching-end 1))
3891              ;; on first line of defun declaration
3892              ((save-excursion
3893                 (and (ada-goto-stmt-start)
3894                      (looking-at "\\<function\\>\\|\\<procedure\\>" )))
3895               (ada-search-ignore-string-comment "begin" nil nil nil
3896                                                 'word-search-forward))
3897              ;; on first line of task declaration
3898              ((save-excursion
3899                 (and (ada-goto-stmt-start)
3900                      (looking-at "\\<task\\>" )
3901                      (forward-word 1)
3902                      (ada-goto-next-non-ws)
3903                      (looking-at "\\<body\\>")))
3904               (ada-search-ignore-string-comment "begin" nil nil nil
3905                                                 'word-search-forward))
3906              ;; accept block start
3907              ((save-excursion
3908                 (and (ada-goto-stmt-start)
3909                      (looking-at "\\<accept\\>" )))
3910               (ada-goto-matching-end 0))
3911              ;; package start
3912              ((save-excursion
3913                 (and (ada-goto-matching-decl-start t)
3914                      (looking-at "\\<package\\>")))
3915               (ada-goto-matching-end 1))
3916              ;; inside a 'begin' ... 'end' block
3917              ((save-excursion
3918                 (ada-goto-matching-decl-start t))
3919               (ada-search-ignore-string-comment "begin" nil nil nil
3920                                                 'word-search-forward))
3921              ;; (hopefully ;-) everything else
3922              (t
3923               (ada-goto-matching-end 1)))
3924             (setq pos (point))
3925             )
3926
3927           ;; now really move to the position found
3928           (goto-char pos)
3929           (message "searching for block end ... done"))
3930
3931       ;; restore syntax-table
3932       (set-syntax-table previous-syntax-table))))
3933
3934 (defun ada-next-procedure ()
3935   "Moves point to next procedure."
3936   (interactive)
3937   (end-of-line)
3938   (if (re-search-forward ada-procedure-start-regexp nil t)
3939       (goto-char (match-beginning 1))
3940     (error "No more functions/procedures/tasks")))
3941
3942 (defun ada-previous-procedure ()
3943   "Moves point to previous procedure."
3944   (interactive)
3945   (beginning-of-line)
3946   (if (re-search-backward ada-procedure-start-regexp nil t)
3947       (goto-char (match-beginning 1))
3948     (error "No more functions/procedures/tasks")))
3949
3950 (defun ada-next-package ()
3951   "Moves point to next package."
3952   (interactive)
3953   (end-of-line)
3954   (if (re-search-forward ada-package-start-regexp nil t)
3955       (goto-char (match-beginning 1))
3956     (error "No more packages")))
3957
3958 (defun ada-previous-package ()
3959   "Moves point to previous package."
3960   (interactive)
3961   (beginning-of-line)
3962   (if (re-search-backward ada-package-start-regexp nil t)
3963       (goto-char (match-beginning 1))
3964     (error "No more packages")))
3965
3966 \f
3967 ;; ------------------------------------------------------------
3968 ;; --  Define keymap and menus for Ada
3969 ;; -------------------------------------------------------------
3970
3971 (defun ada-create-keymap ()
3972   "Create the keymap associated with the Ada mode."
3973
3974   ;; Indentation and Formatting
3975   (define-key ada-mode-map "\C-j"     'ada-indent-newline-indent-conditional)
3976   (define-key ada-mode-map "\C-m"     'ada-indent-newline-indent-conditional)
3977   (define-key ada-mode-map "\t"       'ada-tab)
3978   (define-key ada-mode-map "\C-c\t"   'ada-justified-indent-current)
3979   (define-key ada-mode-map "\C-c\C-l" 'ada-indent-region)
3980   (if ada-xemacs
3981       (define-key ada-mode-map '(shift tab)    'ada-untab)
3982     (define-key ada-mode-map [S-tab]    'ada-untab))
3983   (define-key ada-mode-map "\C-c\C-f" 'ada-format-paramlist)
3984   ;; We don't want to make meta-characters case-specific.
3985
3986   ;; Movement
3987   (define-key ada-mode-map "\M-\C-e"  'ada-next-procedure)
3988   (define-key ada-mode-map "\M-\C-a"  'ada-previous-procedure)
3989   (define-key ada-mode-map "\C-c\C-a" 'ada-move-to-start)
3990   (define-key ada-mode-map "\C-c\C-e" 'ada-move-to-end)
3991
3992   ;; Compilation
3993   (unless (lookup-key ada-mode-map "\C-c\C-c")
3994     (define-key ada-mode-map "\C-c\C-c" 'compile))
3995
3996   ;; Casing
3997   (define-key ada-mode-map "\C-c\C-b" 'ada-adjust-case-buffer)
3998   (define-key ada-mode-map "\C-c\C-t" 'ada-case-read-exceptions)
3999   (define-key ada-mode-map "\C-c\C-y" 'ada-create-case-exception)
4000
4001   ;; On XEmacs, you can easily specify whether DEL should deletes
4002   ;; one character forward or one character backward. Take this into
4003   ;; account
4004   (if (boundp 'delete-key-deletes-forward)
4005       (define-key ada-mode-map [backspace] 'backward-delete-char-untabify)
4006     (define-key ada-mode-map "\177" 'backward-delete-char-untabify))
4007
4008   ;; Make body
4009   (define-key ada-mode-map "\C-c\C-n" 'ada-make-subprogram-body)
4010
4011   ;; Use predefined function of Emacs19 for comments (RE)
4012   (define-key ada-mode-map "\C-c;"    'comment-region)
4013   (define-key ada-mode-map "\C-c:"    'ada-uncomment-region)
4014   )
4015
4016
4017 (defun ada-create-menu ()
4018   "Create the ada menu as shown in the menu bar.
4019 This function is designed to be extensible, so that each compiler-specific file
4020 can add its own items."
4021   ;;  Note that the separators must have different length in the submenus
4022   (autoload 'easy-menu-define "easymenu")
4023
4024   (let ((m      '("Ada"
4025                   ("Help"   ["Ada Mode" (info "ada-mode") t])))
4026         (option '(["Auto Casing" (setq ada-auto-case (not ada-auto-case))
4027                    :style toggle :selected ada-auto-case]
4028                   ["Auto Indent After Return"
4029                    (setq ada-indent-after-return (not ada-indent-after-return))
4030                    :style toggle :selected ada-indent-after-return]))
4031         (goto   '(["Next compilation error"  next-error t]
4032                   ["Previous Package" ada-previous-package t]
4033                   ["Next Package" ada-next-package t]
4034                   ["Previous Procedure" ada-previous-procedure t]
4035                   ["Next Procedure" ada-next-procedure t]
4036                   ["Goto Start Of Statement" ada-move-to-start t]
4037                   ["Goto End Of Statement" ada-move-to-end t]
4038                   ["-" nil nil]
4039                   ["Other File" ff-find-other-file t]
4040                   ["Other File Other Window" ada-ff-other-window t]))
4041         (edit   '(["Indent Line"  ada-indent-current-function t]
4042                   ["Justify Current Indentation" ada-justified-indent-current t]
4043                   ["Indent Lines in Selection" ada-indent-region t]
4044                   ["Indent Lines in File" (ada-indent-region (point-min) (point-max)) t]
4045                   ["Format Parameter List" ada-format-paramlist t]
4046                   ["-" nil nil]
4047                   ["Comment Selection" comment-region t]
4048                   ["Uncomment Selection" ada-uncomment-region t]
4049                   ["--" nil nil]
4050                   ["Fill Comment Paragraph" fill-paragraph t]
4051                   ["Fill Comment Paragraph Justify" ada-fill-comment-paragraph-justify t]
4052                   ["Fill Comment Paragraph Postfix" ada-fill-comment-paragraph-postfix t]
4053                   ["---" nil nil]
4054                   ["Adjust Case Selection"  ada-adjust-case-region t]
4055                   ["Adjust Case Buffer"     ada-adjust-case-buffer t]
4056                   ["Create Case Exception"  ada-create-case-exception t]
4057                   ["Reload Case Exceptions" ada-case-read-exceptions t]
4058                   ["----" nil nil]
4059                   ["Make body for subprogram" ada-make-subprogram-body t]))
4060
4061         )
4062
4063     ;; Option menu present only if in Ada mode
4064     (setq m (append m (list (append (list "Options"
4065                                           (if ada-xemacs :included  :visible)
4066                                           '(string= mode-name "Ada"))
4067                                     option))))
4068
4069     ;; Customize menu always present
4070     (setq m (append m '(["Customize" (customize-group 'ada)
4071                          (>= emacs-major-version 20)])))
4072
4073     ;; Goto and Edit menus present only if in Ada mode
4074     (setq m (append m (list (append (list "Goto"
4075                                           (if ada-xemacs :included :visible)
4076                                           '(string= mode-name "Ada"))
4077                                     goto)
4078                             (append (list "Edit"
4079                                           (if ada-xemacs :included :visible)
4080                                           '(string= mode-name "Ada"))
4081                                     edit))))
4082
4083     (easy-menu-define ada-mode-menu ada-mode-map "Menu keymap for Ada mode" m)
4084     (if ada-xemacs
4085         (progn
4086           (easy-menu-add ada-mode-menu ada-mode-map)
4087           (define-key ada-mode-map [menu-bar] ada-mode-menu)
4088           (setq mode-popup-menu (cons "Ada mode" ada-mode-menu)))
4089       )
4090     ))
4091
4092 \f
4093 ;; -------------------------------------------------------
4094 ;;     Commenting/Uncommenting code
4095 ;;  The following two calls are provided to enhance the standard
4096 ;;  comment-region function, which only allows uncommenting if the
4097 ;;  comment is at the beginning of a line. If the line have been re-indented,
4098 ;;  we are unable to use comment-region, which makes no sense.
4099 ;;
4100 ;;  In addition, we provide an interface to the standard comment handling
4101 ;;  function for justifying the comments.
4102 ;; -------------------------------------------------------
4103
4104 (defadvice comment-region (before ada-uncomment-anywhere)
4105   (if (and arg
4106            (< arg 0)
4107            (string= mode-name "Ada"))
4108       (save-excursion
4109         (let ((cs (concat "^[ \t]*" (regexp-quote comment-start))))
4110           (goto-char beg)
4111           (while (re-search-forward cs end t)
4112             (replace-match comment-start))
4113           ))))
4114
4115 (defun ada-uncomment-region (beg end &optional arg)
4116   "Delete `comment-start' at the beginning of a line in the region."
4117   (interactive "r\nP")
4118
4119   ;;  This advice is not needed anymore with Emacs21. However, for older
4120   ;;  versions, as well as for XEmacs, we still need to enable it.
4121   (if (or (<= emacs-major-version 20) (boundp 'running-xemacs))
4122       (progn
4123         (ad-activate 'comment-region)
4124         (comment-region beg end (- (or arg 1)))
4125         (ad-deactivate 'comment-region))
4126     (comment-region beg end (list (- (or arg 1))))))
4127
4128 (defun ada-fill-comment-paragraph-justify ()
4129   "Fills current comment paragraph and justifies each line as well."
4130   (interactive)
4131   (ada-fill-comment-paragraph 'full))
4132
4133 (defun ada-fill-comment-paragraph-postfix ()
4134   "Fills current comment paragraph and justifies each line as well.
4135 Adds `ada-fill-comment-postfix' at the end of each line."
4136   (interactive)
4137   (ada-fill-comment-paragraph 'full t))
4138
4139 (defun ada-fill-comment-paragraph (&optional justify postfix)
4140   "Fills the current comment paragraph.
4141 If JUSTIFY is non-nil, each line is justified as well.
4142 If POSTFIX and JUSTIFY are  non-nil, `ada-fill-comment-postfix' is appended
4143 to each filled and justified line.
4144 The paragraph is indented on the first line."
4145   (interactive "P")
4146
4147   ;; check if inside comment or just in front a comment
4148   (if (and (not (ada-in-comment-p))
4149            (not (looking-at "[ \t]*--")))
4150       (error "not inside comment"))
4151
4152   (let* ((indent)
4153          (from)
4154          (to)
4155          (opos             (point-marker))
4156
4157          ;; Sets this variable to nil, otherwise it prevents
4158          ;; fill-region-as-paragraph to work on Emacs <= 20.2
4159          (parse-sexp-lookup-properties nil)
4160
4161          fill-prefix
4162          (fill-column (current-fill-column)))
4163
4164     ;;  Find end of paragraph
4165     (back-to-indentation)
4166     (while (and (not (eobp)) (looking-at "--[ \t]*[^ \t\n]"))
4167       (forward-line 1)
4168
4169       ;;  If we were at the last line in the buffer, create a dummy empty
4170       ;;  line at the end of the buffer.
4171       (if (eolp)
4172           (insert "\n")
4173         (back-to-indentation)))
4174     (beginning-of-line)
4175     (setq to (point-marker))
4176     (goto-char opos)
4177
4178     ;;  Find beginning of paragraph
4179     (back-to-indentation)
4180     (while (and (not (bobp)) (looking-at "--[ \t]*[^ \t\n]"))
4181       (forward-line -1)
4182       (back-to-indentation))
4183
4184     ;;  We want one line to above the first one, unless we are at the beginning
4185     ;;  of the buffer
4186     (unless (bobp)
4187       (forward-line 1))
4188     (beginning-of-line)
4189     (setq from (point-marker))
4190
4191     ;;  Calculate the indentation we will need for the paragraph
4192     (back-to-indentation)
4193     (setq indent (current-column))
4194     ;;  unindent the first line of the paragraph
4195     (delete-region from (point))
4196
4197     ;;  Remove the old postfixes
4198     (goto-char from)
4199     (while (re-search-forward "--\n" to t)
4200       (replace-match "\n"))
4201
4202     ;;  Remove the old prefixes (so that the number of spaces after -- is not
4203     ;;  relevant), except on the first one since `fill-region-as-paragraph'
4204     ;;  would not put it back on the first line.
4205     (goto-char (+ from 2))
4206     (while (re-search-forward "^-- *" to t)
4207       (replace-match " "))
4208
4209     (goto-char (1- to))
4210     (setq to (point-marker))
4211
4212     ;;  Indent and justify the paragraph
4213     (setq fill-prefix ada-fill-comment-prefix)
4214     (set-left-margin from to indent)
4215     (if postfix
4216         (setq fill-column (- fill-column (length ada-fill-comment-postfix))))
4217
4218     (fill-region-as-paragraph from to justify)
4219
4220     ;;  Add the postfixes if required
4221     (if postfix
4222         (save-restriction
4223           (goto-char from)
4224           (narrow-to-region from to)
4225           (while (not (eobp))
4226             (end-of-line)
4227             (insert-char ?  (- fill-column (current-column)))
4228             (insert ada-fill-comment-postfix)
4229             (forward-line))
4230           ))
4231
4232     ;;  In Emacs <= 20.2 and XEmacs <=20.4, there is a bug, and a newline is
4233     ;;  inserted at the end. Delete it
4234     (if (or ada-xemacs
4235             (<= emacs-major-version 19)
4236             (and (= emacs-major-version 20)
4237                  (<= emacs-minor-version 2)))
4238         (progn
4239           (goto-char to)
4240           (end-of-line)
4241           (delete-char 1)))
4242
4243     (goto-char opos)))
4244
4245
4246 ;; ---------------------------------------------------
4247 ;;    support for find-file.el
4248 ;; These functions are used by find-file to guess the file names from
4249 ;; unit names, and to find the other file (spec or body) from the current
4250 ;; file (body or spec).
4251 ;; It is also used to find in which function we are, so as to put the
4252 ;; cursor at the correct position.
4253 ;; Standard Ada does not force any relation between unit names and file names,
4254 ;; so some of these functions can only be a good approximation. However, they
4255 ;; are also overriden in `ada-xref'.el when we know that the user is using
4256 ;; GNAT.
4257 ;; ---------------------------------------------------
4258
4259 ;; Overriden when we work with GNAT, to use gnatkrunch
4260 (defun ada-make-filename-from-adaname (adaname)
4261   "Determine the filename in which ADANAME is found.
4262 This is a generic function, independent from any compiler."
4263   (while (string-match "\\." adaname)
4264     (setq adaname (replace-match "-" t t adaname)))
4265   (downcase adaname)
4266   )
4267
4268 (defun ada-other-file-name ()
4269   "Return the name of the other file.
4270 The name returned is the body if current-buffer is the spec, or the spec
4271 otherwise."
4272
4273   (let ((is-spec nil)
4274         (is-body nil)
4275         (suffixes ada-spec-suffixes)
4276         (name  (buffer-file-name)))
4277
4278     ;;  Guess whether we have a spec or a body, and get the basename of the
4279     ;;  file. Since the extension may not start with '.', we can not use
4280     ;;  file-name-extension
4281     (while (and (not is-spec)
4282                 suffixes)
4283       (if (string-match (concat "\\(.*\\)" (car suffixes) "$") name)
4284           (setq is-spec t
4285                 name    (match-string 1 name)))
4286       (setq suffixes (cdr suffixes)))
4287
4288     (if (not is-spec)
4289         (progn
4290           (setq suffixes ada-body-suffixes)
4291           (while (and (not is-body)
4292                       suffixes)
4293             (if (string-match (concat "\\(.*\\)" (car suffixes) "$") name)
4294                 (setq is-body t
4295                       name    (match-string 1 name)))
4296             (setq suffixes (cdr suffixes)))))
4297
4298     ;;  If this wasn't in either list, return name itself
4299     (if (not (or is-spec is-body))
4300         name
4301
4302       ;;  Else find the other possible names
4303       (if is-spec
4304           (setq suffixes ada-body-suffixes)
4305         (setq suffixes ada-spec-suffixes))
4306       (setq is-spec name)
4307
4308       (while suffixes
4309         (if (file-exists-p (concat name (car suffixes)))
4310             (setq is-spec (concat name (car suffixes))))
4311         (setq suffixes (cdr suffixes)))
4312
4313       is-spec)))
4314
4315 (defun ada-which-function-are-we-in ()
4316   "Return the name of the function whose definition/declaration point is in.
4317 Redefines the function `ff-which-function-are-we-in'."
4318   (setq ff-function-name nil)
4319   (save-excursion
4320     (end-of-line);;  make sure we get the complete name
4321     (if (or (re-search-backward ada-procedure-start-regexp nil t)
4322             (re-search-backward ada-package-start-regexp nil t))
4323         (setq ff-function-name (match-string 0)))
4324     ))
4325
4326
4327 (defvar ada-last-which-function-line -1
4328   "Last on which ada-which-function was called")
4329 (defvar ada-last-which-function-subprog 0
4330   "Last subprogram name returned by ada-which-function")
4331 (make-variable-buffer-local 'ada-last-which-function-subprog)
4332 (make-variable-buffer-local 'ada-last-which-function-line)
4333
4334
4335 (defun ada-which-function ()
4336   "Returns the name of the function whose body the point is in.
4337 This function works even in the case of nested subprograms, whereas the
4338 standard Emacs function which-function does not.
4339 Note that this function expects subprogram bodies to be terminated by
4340 'end <name>;', not 'end;'.
4341 Since the search can be long, the results are cached."
4342
4343   (let ((line (count-lines (point-min) (point)))
4344         (pos (point))
4345         end-pos
4346         func-name
4347         found)
4348
4349     ;;  If this is the same line as before, simply return the same result
4350     (if (= line ada-last-which-function-line)
4351         ada-last-which-function-subprog
4352
4353       (save-excursion
4354         ;; In case the current line is also the beginning of the body
4355         (end-of-line)
4356         (while (and (ada-in-paramlist-p)
4357                     (= (forward-line 1) 0))
4358           (end-of-line))
4359
4360         ;; Can't simply do forward-word, in case the "is" is not on the
4361         ;; same line as the closing parenthesis
4362         (skip-chars-forward "is \t\n")
4363
4364         ;; No look for the closest subprogram body that has not ended yet.
4365         ;; Not that we expect all the bodies to be finished by "end <name",
4366         ;; not simply "end"
4367
4368         (while (and (not found)
4369                     (re-search-backward ada-imenu-subprogram-menu-re nil t))
4370           (setq func-name (match-string 2))
4371           (if (and (not (ada-in-comment-p))
4372                    (not (save-excursion
4373                           (goto-char (match-end 0))
4374                           (looking-at "[ \t\n]*new"))))
4375               (save-excursion
4376                 (if (ada-search-ignore-string-comment
4377                      (concat "end[ \t]+" func-name "[ \t]*;"))
4378                     (setq end-pos (point))
4379                   (setq end-pos (point-max)))
4380                 (if (>= end-pos pos)
4381                     (setq found func-name))))
4382           )
4383         (setq ada-last-which-function-line line
4384               ada-last-which-function-subprog found)
4385         found))))
4386
4387 (defun ada-ff-other-window ()
4388   "Find other file in other window using `ff-find-other-file'."
4389   (interactive)
4390   (and (fboundp 'ff-find-other-file)
4391        (ff-find-other-file t)))
4392
4393 (defun ada-set-point-accordingly ()
4394   "Move to the function declaration that was set by
4395 `ff-which-function-are-we-in'."
4396   (if ff-function-name
4397       (progn
4398         (goto-char (point-min))
4399         (unless (ada-search-ignore-string-comment
4400                  (concat ff-function-name "\\b") nil)
4401           (goto-char (point-min))))))
4402
4403 (defun ada-get-body-name (&optional spec-name)
4404   "Returns the file name for the body of SPEC-NAME.
4405 If SPEC-NAME is nil, returns the body for the current package.
4406 Returns nil if no body was found."
4407   (interactive)
4408
4409   (unless spec-name (setq spec-name (buffer-file-name)))
4410
4411   ;; If find-file.el was available, use its functions
4412   (if (functionp 'ff-get-file)
4413       (ff-get-file-name ada-search-directories
4414                         (ada-make-filename-from-adaname
4415                          (file-name-nondirectory
4416                           (file-name-sans-extension spec-name)))
4417                         ada-body-suffixes)
4418     ;; Else emulate it very simply
4419     (concat (ada-make-filename-from-adaname
4420              (file-name-nondirectory
4421               (file-name-sans-extension spec-name)))
4422             ".adb")))
4423
4424 \f
4425 ;; ---------------------------------------------------
4426 ;;    support for font-lock.el
4427 ;; Strings are a real pain in Ada because a single quote character is
4428 ;; overloaded as a string quote and type/instance delimiter.  By default, a
4429 ;; single quote is given punctuation syntax in `ada-mode-syntax-table'.
4430 ;; So, for Font Lock mode purposes, we mark single quotes as having string
4431 ;; syntax when the gods that created Ada determine them to be.
4432 ;;
4433 ;; This only works in Emacs. See the comments before the grammar functions
4434 ;; at the beginning of this file for how this is done with XEmacs.
4435 ;; ----------------------------------------------------
4436
4437 (defconst ada-font-lock-syntactic-keywords
4438   ;; Mark single quotes as having string quote syntax in 'c' instances.
4439   ;; As a special case, ''' will not be highlighted, but if we do not
4440   ;; set this special case, then the rest of the buffer is highlighted as
4441   ;; a string
4442   ;; This sets the properties of the characters, so that ada-in-string-p
4443   ;; correctly handles '"' too...
4444   '(("\\('\\)[^'\n]\\('\\)" (1 (7 . ?')) (2 (7 . ?')))
4445     ("^[ \t]*\\(#\\(if\\|else\\|elsif\\|end\\)\\)" (1 (11 . ?\n)))
4446     ))
4447
4448 (defvar ada-font-lock-keywords
4449   (eval-when-compile
4450     (list
4451      ;;
4452      ;; handle "type T is access function return S;"
4453      (list "\\<\\(function[ \t]+return\\)\\>" '(1 font-lock-keyword-face) )
4454
4455      ;;  preprocessor line
4456      (list "^[ \t]*\\(#.*\n\\)"  '(1 font-lock-type-face t))
4457
4458      ;;
4459      ;; accept, entry, function, package (body), protected (body|type),
4460      ;; pragma, procedure, task (body) plus name.
4461      (list (concat
4462             "\\<\\("
4463             "accept\\|"
4464             "entry\\|"
4465             "function\\|"
4466             "package[ \t]+body\\|"
4467             "package\\|"
4468             "pragma\\|"
4469             "procedure\\|"
4470             "protected[ \t]+body\\|"
4471             "protected[ \t]+type\\|"
4472             "protected\\|"
4473             "task[ \t]+body\\|"
4474             "task[ \t]+type\\|"
4475             "task"
4476             "\\)\\>[ \t]*"
4477             "\\(\\sw+\\(\\.\\sw*\\)*\\)?")
4478            '(1 font-lock-keyword-face) '(2 font-lock-function-name-face nil t))
4479      ;;
4480      ;; Optional keywords followed by a type name.
4481      (list (concat                      ; ":[ \t]*"
4482             "\\<\\(access[ \t]+all\\|access\\|constant\\|in[ \t]+out\\|in\\|out\\)\\>"
4483             "[ \t]*"
4484             "\\(\\sw+\\(\\.\\sw*\\)*\\)?")
4485            '(1 font-lock-keyword-face nil t) '(2 font-lock-type-face nil t))
4486
4487      ;;
4488      ;; Main keywords, except those treated specially below.
4489      (concat "\\<"
4490              (regexp-opt
4491               '("abort" "abs" "abstract" "accept" "access" "aliased" "all"
4492                 "and" "array" "at" "begin" "case" "declare" "delay" "delta"
4493                 "digits" "do" "else" "elsif" "entry" "exception" "exit" "for"
4494                 "generic" "if" "in" "is" "limited" "loop" "mod" "not"
4495                 "null" "or" "others" "private" "protected" "raise"
4496                 "range" "record" "rem" "renames" "requeue" "return" "reverse"
4497                 "select" "separate" "tagged" "task" "terminate" "then" "until"
4498                 "when" "while" "xor") t)
4499              "\\>")
4500      ;;
4501      ;; Anything following end and not already fontified is a body name.
4502      '("\\<\\(end\\)\\>\\([ \t]+\\)?\\(\\(\\sw\\|[_.]\\)+\\)?"
4503        (1 font-lock-keyword-face) (3 font-lock-function-name-face nil t))
4504      ;;
4505      ;; Keywords followed by a type or function name.
4506      (list (concat "\\<\\("
4507                    "new\\|of\\|subtype\\|type"
4508                    "\\)\\>[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?[ \t]*\\((\\)?")
4509            '(1 font-lock-keyword-face)
4510            '(2 (if (match-beginning 4)
4511                    font-lock-function-name-face
4512                  font-lock-type-face) nil t))
4513      ;;
4514      ;; Keywords followed by a (comma separated list of) reference.
4515      (list (concat "\\<\\(goto\\|raise\\|use\\|with\\)\\>" ; "when" removed
4516                    "[ \t\n]*\\(\\(\\sw\\|[_.|, \t\n]\\)+\\)\\W")
4517            '(1 font-lock-keyword-face) '(2 font-lock-reference-face nil t))
4518      ;;
4519      ;; Goto tags.
4520      '("<<\\(\\sw+\\)>>" 1 font-lock-reference-face)
4521      ))
4522   "Default expressions to highlight in Ada mode.")
4523
4524
4525 ;; ---------------------------------------------------------
4526 ;;  Support for outline.el
4527 ;; ---------------------------------------------------------
4528
4529 (defun ada-outline-level ()
4530   "This is so that `current-column` DTRT in otherwise-hidden text"
4531   ;; patch from Dave Love <fx@gnu.org>
4532   (let (buffer-invisibility-spec)
4533     (save-excursion
4534       (back-to-indentation)
4535       (current-column))))
4536
4537 ;; ---------------------------------------------------------
4538 ;;    Automatic generation of code
4539 ;; The Ada-mode has a set of function to automatically generate a subprogram
4540 ;; or package body from its spec.
4541 ;; These function only use a primary and basic algorithm, this could use a
4542 ;; lot of improvement.
4543 ;; When the user is using GNAT, we rather use gnatstub to generate an accurate
4544 ;; body.
4545 ;; ----------------------------------------------------------
4546
4547 (defun ada-gen-treat-proc (match)
4548   "Make dummy body of a procedure/function specification.
4549 MATCH is a cons cell containing the start and end location of the last search
4550 for ada-procedure-start-regexp."
4551   (goto-char (car match))
4552   (let (func-found procname functype)
4553     (cond
4554      ((or (looking-at "^[ \t]*procedure")
4555           (setq func-found (looking-at "^[ \t]*function")))
4556       ;; treat it as a proc/func
4557       (forward-word 2)
4558       (forward-word -1)
4559       (setq procname (buffer-substring (point) (cdr match))) ; store  proc name
4560
4561       ;; goto end of procname
4562       (goto-char (cdr match))
4563
4564       ;; skip over parameterlist
4565       (unless (looking-at "[ \t\n]*\\(;\\|return\\)")
4566         (forward-sexp))
4567
4568       ;; if function, skip over 'return' and result type.
4569       (if func-found
4570           (progn
4571             (forward-word 1)
4572             (skip-chars-forward " \t\n")
4573             (setq functype (buffer-substring (point)
4574                                              (progn
4575                                                (skip-chars-forward
4576                                                 "a-zA-Z0-9_\.")
4577                                                (point))))))
4578       ;; look for next non WS
4579       (cond
4580        ((looking-at "[ \t]*;")
4581         (delete-region (match-beginning 0) (match-end 0));; delete the ';'
4582         (ada-indent-newline-indent)
4583         (insert "is")
4584         (ada-indent-newline-indent)
4585         (if func-found
4586             (progn
4587               (insert "Result : " functype ";")
4588               (ada-indent-newline-indent)))
4589         (insert "begin")
4590         (ada-indent-newline-indent)
4591         (if func-found
4592             (insert "return Result;")
4593           (insert "null;"))
4594         (ada-indent-newline-indent)
4595         (insert "end " procname ";")
4596         (ada-indent-newline-indent)
4597         )
4598        ;; else
4599        ((looking-at "[ \t\n]*is")
4600         ;; do nothing
4601         )
4602        ((looking-at "[ \t\n]*rename")
4603         ;; do nothing
4604         )
4605        (t
4606         (message "unknown syntax"))))
4607      (t
4608       (if (looking-at "^[ \t]*task")
4609           (progn
4610             (message "Task conversion is not yet implemented")
4611             (forward-word 2)
4612             (if (looking-at "[ \t]*;")
4613                 (forward-line)
4614               (ada-move-to-end))
4615             ))))))
4616
4617 (defun ada-make-body ()
4618   "Create an Ada package body in the current buffer.
4619 The potential old buffer contents is deleted first, then we copy the
4620 spec buffer in here and modify it to make it a body.
4621 This function typically is to be hooked into `ff-file-created-hooks'."
4622   (interactive)
4623   (delete-region (point-min) (point-max))
4624   (insert-buffer (car (cdr (buffer-list))))
4625   (ada-mode)
4626
4627   (let (found ada-procedure-or-package-start-regexp)
4628     (if (setq found
4629              (ada-search-ignore-string-comment ada-package-start-regexp nil))
4630         (progn (goto-char (cdr found))
4631                (insert " body")
4632                )
4633       (error "No package"))
4634
4635     (setq ada-procedure-or-package-start-regexp
4636          (concat ada-procedure-start-regexp
4637                  "\\|"
4638                  ada-package-start-regexp))
4639
4640     (while (setq found
4641                 (ada-search-ignore-string-comment
4642                  ada-procedure-or-package-start-regexp nil))
4643       (progn
4644         (goto-char (car found))
4645         (if (looking-at ada-package-start-regexp)
4646             (progn (goto-char (cdr found))
4647                    (insert " body"))
4648           (ada-gen-treat-proc found))))))
4649
4650
4651 (defun ada-make-subprogram-body ()
4652   "Make one dummy subprogram body from spec surrounding point."
4653   (interactive)
4654   (let* ((found (re-search-backward ada-procedure-start-regexp nil t))
4655          (spec  (match-beginning 0))
4656          body-file)
4657     (if found
4658         (progn
4659           (goto-char spec)
4660           (if (and (re-search-forward "(\\|;" nil t)
4661                    (= (char-before) ?\())
4662               (progn
4663                 (ada-search-ignore-string-comment ")" nil)
4664                 (ada-search-ignore-string-comment ";" nil)))
4665           (setq spec (buffer-substring spec (point)))
4666
4667           ;; If find-file.el was available, use its functions
4668           (setq body-file (ada-get-body-name))
4669           (if body-file
4670               (find-file body-file)
4671             (error "No body found for the package. Create it first"))
4672
4673           (save-restriction
4674             (widen)
4675             (goto-char (point-max))
4676             (forward-comment -10000)
4677             (re-search-backward "\\<end\\>" nil t)
4678             ;;  Move to the beginning of the elaboration part, if any
4679             (re-search-backward "^begin" nil t)
4680             (newline)
4681             (forward-char -1)
4682             (insert spec)
4683             (re-search-backward ada-procedure-start-regexp nil t)
4684             (ada-gen-treat-proc (cons (match-beginning 0) (match-end 0)))
4685             ))
4686       (error "Not in subprogram spec"))))
4687
4688 ;; --------------------------------------------------------
4689 ;; Global initializations
4690 ;; --------------------------------------------------------
4691
4692 ;;  Create the keymap once and for all. If we do that in ada-mode,
4693 ;;  the keys changed in the user's .emacs have to be modified
4694 ;;  every time
4695 (ada-create-keymap)
4696 (ada-create-menu)
4697
4698 ;;  Create the syntax tables, but do not activate them
4699 (ada-create-syntax-table)
4700
4701 ;;  Add the default extensions (and set up speedbar)
4702 (ada-add-extensions ".ads" ".adb")
4703 ;; This two files are generated by GNAT when running with -gnatD
4704 (if (equal ada-which-compiler 'gnat)
4705     (ada-add-extensions ".ads.dg" ".adb.dg"))
4706
4707 ;;  Read the special cases for exceptions
4708 (ada-case-read-exceptions)
4709
4710 ;; include the other ada-mode files
4711 (if (equal ada-which-compiler 'gnat)
4712     (progn
4713       ;; The order here is important: ada-xref defines the Project
4714       ;; submenu, and ada-prj adds to it.
4715       (require 'ada-xref)
4716       (condition-case nil  (require 'ada-prj) (error nil))
4717       ))
4718 (condition-case nil (require 'ada-stmt) (error nil))
4719
4720 ;;; provide ourselves
4721 (provide 'ada-mode)
4722
4723 ;;; ada-mode.el ends here