code.delx.au - gnu-emacs/blob - lisp/progmodes/ada-mode.el

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