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

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