cgit.sxemacs.org Git - packages/blob - xemacs-packages/ada/ada-mode.el

   1 ;;; ada-mode.el --- An Emacs major-mode for editing Ada source.
   2
   3 ;; Copyright (C) 1994, 1995, 1997 Free Software Foundation, Inc.
   4
   5 ;; Authors: Rolf Ebert      <ebert@inf.enst.fr>
   6 ;;          Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de>
   7 ;; Keywords: languages oop ada
   8 ;; Rolf Ebert's version: 2.27
   9
  10 ;; This file is part of XEmacs
  11
  12 ;; XEmacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; XEmacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with XEmacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; This mode is a complete rewrite of a major mode for editing Ada 83
  28 ;;; and Ada 95 source code under Emacs-19.  It contains completely new
  29 ;;; indenting code and support for code browsing (see ada-xref).
  30
  31 ;;; Synched up with: FSF 20.1
  32
  33 ;;; USAGE
  34 ;;; =====
  35 ;;; Emacs should enter Ada mode when you load an Ada source (*.ad[abs]).
  36 ;;;
  37 ;;; When you have entered ada-mode, you may get more info by pressing
  38 ;;; C-h m. You may also get online help describing various functions by:
  39 ;;; C-h d <Name of function you want described>
  40
  41
  42 ;;; HISTORY
  43 ;;; =======
  44 ;;; The first Ada mode for GNU Emacs was written by V. Broman in
  45 ;;; 1985. He based his work on the already existing Modula-2 mode.
  46 ;;; This was distributed as ada.el in versions of Emacs prior to 19.29.
  47 ;;;
  48 ;;; Lynn Slater wrote an extensive Ada mode in 1989. It consisted of
  49 ;;; several files with support for dired commands and other nice
  50 ;;; things. It is currently available from the PAL
  51 ;;; (wuarchive.wustl.edu:/languages/ada) as ada-mode-1.06a.tar.Z.
  52 ;;;
  53 ;;; The probably very first Ada mode (called electric-ada.el) was
  54 ;;; written by Steven D. Litvintchouk and Steven M. Rosen for the
  55 ;;; Gosling Emacs. L. Slater based his development on ada.el and
  56 ;;; electric-ada.el.
  57 ;;;
  58 ;;; The current Ada mode is a complete rewrite by M. Heritsch and
  59 ;;; R. Ebert.  Some ideas from the Ada mode mailing list have been
  60 ;;; added.  Some of the functionality of L. Slater's mode has not
  61 ;;; (yet) been recoded in this new mode.  Perhaps you prefer sticking
  62 ;;; to his version.
  63
  64
  65 ;;; KNOWN BUGS
  66 ;;; ==========
  67 ;;;
  68 ;;; In the presence of comments and/or incorrect syntax
  69 ;;; ada-format-paramlist produces weird results.
  70 ;;; -------------------
  71 ;;; Character constants with otherwise syntactic relevant characters
  72 ;;; like `(' or `"' throw indentation off the track.  Fontification
  73 ;;; should work now in Emacs-19.35
  74 ;;; C : constant Character := Character'('"');
  75 ;;; -------------------
  76
  77
  78 ;;; TODO
  79 ;;; ====
  80 ;;;
  81 ;;; o bodify-single-subprogram
  82 ;;; o make a function "separate" and put it in the corresponding file.
  83
  84
  85
  86 ;;; CREDITS
  87 ;;; =======
  88 ;;;
  89 ;;; Many thanks to
  90 ;;;    Philippe Waroquiers (PW) <philippe@cfmu.eurocontrol.be> in particular,
  91 ;;;    woodruff@stc.llnl.gov (John Woodruff)
  92 ;;;    jj@ddci.dk (Jesper Joergensen)
  93 ;;;    gse@ocsystems.com (Scott Evans)
  94 ;;;    comar@LANG8.CS.NYU.EDU (Cyrille Comar)
  95 ;;;    and others for their valuable hints.
  96 \f
  97 ;;;--------------------
  98 ;;;    USER OPTIONS
  99 ;;;--------------------
 100
 101
 102 ;; ---- customize support
 103
 104 (defgroup ada nil
 105   "Major mode for editing Ada source in Emacs"
 106   :group 'languages)
 107
 108 ;; ---- configure indentation
 109
 110 (defcustom ada-indent 3
 111   "*Defines the size of Ada indentation."
 112   :type 'integer
 113   :group 'ada)
 114
 115 (defcustom ada-broken-indent 2
 116   "*# of columns to indent the continuation of a broken line."
 117   :type 'integer
 118   :group 'ada)
 119
 120 (defcustom ada-label-indent -4
 121   "*# of columns to indent a label."
 122   :type 'integer
 123   :group 'ada)
 124
 125 (defcustom ada-stmt-end-indent 0
 126   "*# of columns to indent a statement end keyword in a separate line.
 127 Examples are 'is', 'loop', 'record', ..."
 128   :type 'integer
 129   :group 'ada)
 130
 131 (defcustom ada-when-indent 3
 132   "*Defines the indentation for 'when' relative to 'exception' or 'case'."
 133   :type 'integer
 134   :group 'ada)
 135
 136 (defcustom ada-indent-record-rel-type 3
 137   "*Defines the indentation for 'record' relative to 'type' or 'use'."
 138   :type 'integer
 139   :group 'ada)
 140
 141 (defcustom ada-indent-comment-as-code t
 142   "*If non-nil, comment-lines get indented as Ada code."
 143   :type 'boolean
 144   :group 'ada)
 145
 146 (defcustom ada-indent-is-separate t
 147   "*If non-nil, 'is separate' or 'is abstract' on a single line are indented."
 148   :type 'boolean
 149   :group 'ada)
 150
 151 (defcustom ada-indent-to-open-paren t
 152   "*If non-nil, indent according to the innermost open parenthesis."
 153   :type 'boolean
 154   :group 'ada)
 155
 156 (defcustom ada-search-paren-char-count-limit 3000
 157   "*Search that many characters for an open parenthesis."
 158   :type 'integer
 159   :group 'ada)
 160
 161
 162 ;; ---- other user options
 163
 164 (defcustom ada-tab-policy 'indent-auto
 165   "*Control behaviour of the TAB key.
 166 Must be one of `indent-rigidly', `indent-auto', `gei', `indent-af'
 167 or `always-tab'.
 168
 169 `indent-rigidly' : always adds ada-indent blanks at the beginning of the line.
 170 `indent-auto'    : use indentation functions in this file.
 171 `gei'            : use David Kågedal's Generic Indentation Engine.
 172 `indent-af'      : use Gary E. Barnes' ada-format.el
 173 `always-tab'     : do indent-relative."
 174   :type '(choice (const indent-auto)
 175                  (const indent-rigidly)
 176                  (const gei)
 177                  (const indent-af)
 178                  (const always-tab))
 179   :group 'ada)
 180
 181 (defcustom ada-move-to-declaration nil
 182   "*If non-nil, `ada-move-to-start' moves point to the subprog declaration,
 183 not to 'begin'."
 184   :type 'boolean
 185   :group 'ada)
 186
 187 (defcustom ada-spec-suffix ".ads"
 188   "*Suffix of Ada specification files."
 189   :type 'string
 190   :group 'ada)
 191
 192 (defcustom ada-body-suffix ".adb"
 193   "*Suffix of Ada body files."
 194   :type 'string
 195   :group 'ada)
 196
 197 (defcustom ada-spec-suffix-as-regexp "\\.ads$"
 198   "*Regexp to find Ada specification files."
 199   :type 'string
 200   :group 'ada)
 201
 202 (defcustom ada-body-suffix-as-regexp "\\.adb$"
 203   "*Regexp to find Ada body files."
 204   :type 'string
 205   :group 'ada)
 206
 207 (defvar ada-other-file-alist
 208   (list
 209    (list ada-spec-suffix-as-regexp (list ada-body-suffix))
 210    (list ada-body-suffix-as-regexp (list ada-spec-suffix))
 211    )
 212   "*Alist of extensions to find given the current file's extension.
 213
 214 This list should contain the most used extensions before the others,
 215 since the search algorithm searches sequentially through each directory
 216 specified in `ada-search-directories'.  If a file is not found, a new one
 217 is created with the first matching extension (`.adb' yields `.ads').")
 218
 219 (defcustom ada-search-directories
 220   '("." "/usr/adainclude" "/usr/local/adainclude" "/opt/gnu/adainclude")
 221   "*List of directories to search for Ada files.
 222 See the description for the `ff-search-directories' variable."
 223   :type '(repeat (choice :tag "Directory"
 224                          (const :tag "default" nil)
 225                          (directory :format "%v")))
 226   :group 'ada)
 227
 228 (defcustom ada-language-version 'ada95
 229   "*Do we program in `ada83' or `ada95'?"
 230   :type '(choice (const ada83)
 231                  (const ada95))
 232   :group 'ada)
 233
 234 (defcustom ada-case-keyword 'downcase-word
 235   "*Function to call to adjust the case of Ada keywords.
 236 It may be `downcase-word', `upcase-word', `ada-loose-case-word' or
 237 `capitalize-word'."
 238   :type '(choice (const downcase-word)
 239                  (const upcase-word)
 240                  (const capitalize-word)
 241                  (const ada-loose-case-word))
 242   :group 'ada)
 243
 244 (defcustom ada-case-identifier 'ada-loose-case-word
 245   "*Function to call to adjust the case of an Ada identifier.
 246 It may be `downcase-word', `upcase-word', `ada-loose-case-word' or
 247 `capitalize-word'."
 248   :type '(choice (const downcase-word)
 249                  (const upcase-word)
 250                  (const capitalize-word)
 251                  (const ada-loose-case-word))
 252   :group 'ada)
 253
 254 (defcustom ada-case-attribute 'capitalize-word
 255   "*Function to call to adjust the case of Ada attributes.
 256 It may be `downcase-word', `upcase-word', `ada-loose-case-word' or
 257 `capitalize-word'."
 258   :type '(choice (const downcase-word)
 259                  (const upcase-word)
 260                  (const capitalize-word)
 261                  (const ada-loose-case-word))
 262   :group 'ada)
 263
 264 (defcustom ada-auto-case t
 265   "*Non-nil automatically changes case of preceding word while typing.
 266 Casing is done according to `ada-case-keyword', `ada-case-identifier'
 267 and `ada-case-attribute'."
 268   :type 'boolean
 269   :group 'ada)
 270
 271 (defcustom ada-clean-buffer-before-saving t
 272   "*If non-nil, `remove-trailing-spaces' and `untabify' buffer before saving."
 273   :type 'boolean
 274   :group 'ada)
 275
 276 (defvar ada-mode-hook nil
 277   "*List of functions to call when Ada mode is invoked.
 278 This is a good place to add Ada environment specific bindings.")
 279
 280 (defcustom ada-external-pretty-print-program "aimap"
 281   "*External pretty printer to call from within Ada mode."
 282   :type 'string
 283   :group 'ada)
 284
 285 (defcustom ada-tmp-directory "/tmp/"
 286   "*Directory to store the temporary file for the Ada pretty printer."
 287   :type 'string
 288   :group 'ada)
 289
 290 (defcustom ada-compile-options "-c"
 291   "*Buffer local options passed to the Ada compiler.
 292 These options are used when the compiler is invoked on the current buffer."
 293   :type 'string
 294   :group 'ada)
 295 (make-variable-buffer-local 'ada-compile-options)
 296
 297 (defcustom ada-make-options "-c"
 298   "*Buffer local options passed to `ada-compiler-make' (usually `gnatmake').
 299 These options are used when `gnatmake' is invoked on the current buffer."
 300   :type 'string
 301   :group 'ada)
 302 (make-variable-buffer-local 'ada-make-options)
 303
 304 (defcustom ada-compiler-syntax-check "gcc -c -gnats"
 305   "*Compiler command with options for syntax checking."
 306   :type 'string
 307   :group 'ada)
 308
 309 (defcustom ada-compiler-make "gnatmake"
 310   "*The `make' command for the given compiler."
 311   :type 'string
 312   :group 'ada)
 313
 314 (defcustom ada-fill-comment-prefix "-- "
 315   "*This is inserted in the first columns when filling a comment paragraph."
 316   :type 'string
 317   :group 'ada)
 318
 319 (defcustom ada-fill-comment-postfix " --"
 320   "*This is inserted at the end of each line when filling a comment paragraph.
 321 with `ada-fill-comment-paragraph-postfix'."
 322   :type 'string
 323   :group 'ada)
 324
 325 (defcustom ada-krunch-args "0"
 326   "*Argument of gnatkr, a string containing the max number of characters.
 327 Set to 0, if you don't use crunched filenames."
 328   :type 'string
 329   :group 'ada)
 330
 331 ;;; ---- end of user configurable variables
 332 \f
 333
 334 (defvar ada-mode-abbrev-table nil
 335   "Abbrev table used in Ada mode.")
 336 (define-abbrev-table 'ada-mode-abbrev-table ())
 337
 338 (defvar ada-mode-map ()
 339   "Local keymap used for Ada mode.")
 340
 341 (defvar ada-mode-syntax-table nil
 342   "Syntax table to be used for editing Ada source code.")
 343
 344 (defvar ada-mode-symbol-syntax-table nil
 345   "Syntax table for Ada, where `_' is a word constituent.")
 346
 347 (defconst ada-83-keywords
 348   "\\<\\(abort\\|abs\\|accept\\|access\\|all\\|and\\|array\\|\
 349 at\\|begin\\|body\\|case\\|constant\\|declare\\|delay\\|delta\\|\
 350 digits\\|do\\|else\\|elsif\\|end\\|entry\\|exception\\|exit\\|for\\|\
 351 function\\|generic\\|goto\\|if\\|in\\|is\\|limited\\|loop\\|mod\\|\
 352 new\\|not\\|null\\|of\\|or\\|others\\|out\\|package\\|pragma\\|\
 353 private\\|procedure\\|raise\\|range\\|record\\|rem\\|renames\\|\
 354 return\\|reverse\\|select\\|separate\\|subtype\\|task\\|terminate\\|\
 355 then\\|type\\|use\\|when\\|while\\|with\\|xor\\)\\>"
 356 ;  "\\<\\(a\\(b\\(ort\\|s\\)\\|cce\\(pt\\|ss\\)\\|ll\\|nd\\|rray\\|t\\)\\|\
 357 ;b\\(egin\\|ody\\)\\|c\\(ase\\|onstant\\)\\|\
 358 ;d\\(e\\(clare\\|l\\(ay\\|ta\\)\\)\\|igits\\|o\\)\\|\
 359 ;e\\(ls\\(e\\|if\\)\\|n\\(d\\|try\\)\\|x\\(ception\\|it\\)\\)\\|\
 360 ;f\\(or\\|unction\\)\\|g\\(eneric\\|oto\\)\\|i[fns]\\|l\\(imited\\|oop\\)\\|\
 361 ;mod\\|n\\(ew\\|ot\\|ull\\)\\|o\\([fr]\\|thers\\|ut\\)\\|\
 362 ;p\\(ackage\\|r\\(agma\\|ivate\\|ocedure\\)\\)\\|\
 363 ;r\\(a\\(ise\\|nge\\)\\|e\\(cord\\|m\\|names\\|turn\\|verse\\)\\)\\|\
 364 ;s\\(e\\(lect\\|parate\\)\\|ubtype\\)\\|use\\|
 365 ;t\\(ask\\|erminate\\|hen\\|ype\\)\\|w\\(h\\(en\\|ile\\)\\|ith\\)\\|xor\\)\\>"
 366   "Regular expression for looking at Ada83 keywords.")
 367
 368 (defconst ada-95-keywords
 369   "\\<\\(abort\\|abs\\|abstract\\|accept\\|access\\|aliased\\|\
 370 all\\|and\\|array\\|at\\|begin\\|body\\|case\\|constant\\|declare\\|\
 371 delay\\|delta\\|digits\\|do\\|else\\|elsif\\|end\\|entry\\|\
 372 exception\\|exit\\|for\\|function\\|generic\\|goto\\|if\\|in\\|\
 373 is\\|limited\\|loop\\|mod\\|new\\|not\\|null\\|of\\|or\\|others\\|\
 374 out\\|package\\|pragma\\|private\\|procedure\\|protected\\|raise\\|\
 375 range\\|record\\|rem\\|renames\\|requeue\\|return\\|reverse\\|\
 376 select\\|separate\\|subtype\\|tagged\\|task\\|terminate\\|then\\|\
 377 type\\|until\\|use\\|when\\|while\\|with\\|xor\\)\\>"
 378   "Regular expression for looking at Ada95 keywords.")
 379
 380 (defvar ada-keywords ada-95-keywords
 381   "Regular expression for looking at Ada keywords.")
 382
 383 (defvar ada-ret-binding nil
 384   "Variable to save key binding of RET when casing is activated.")
 385
 386 (defvar ada-lfd-binding nil
 387   "Variable to save key binding of LFD when casing is activated.")
 388
 389 ;;; ---- Regexps to find procedures/functions/packages
 390
 391 (defconst ada-ident-re
 392   "[a-zA-Z0-9_\\.]+"
 393   "Regexp matching Ada (qualified) identifiers.")
 394
 395 (defvar ada-procedure-start-regexp
 396   "^[ \t]*\\(procedure\\|function\\|task\\)[ \t\n]+\\([a-zA-Z0-9_\\.]+\\)"
 397   "Regexp used to find Ada procedures/functions.")
 398
 399 (defvar ada-package-start-regexp
 400   "^[ \t]*\\(package\\)"
 401   "Regexp used to find Ada packages")
 402
 403
 404 ;;; ---- regexps for indentation functions
 405
 406 (defvar ada-block-start-re
 407   "\\<\\(begin\\|select\\|declare\\|private\\|or\\|generic\\|\
 408 exception\\|loop\\|else\\|\
 409 \\(\\(limited\\|abstract\\|tagged\\)[ \t]+\\)*record\\)\\>"
 410   "Regexp for keywords starting Ada blocks.")
 411
 412 (defvar ada-end-stmt-re
 413   "\\(;\\|=>\\|^[ \t]*separate[ \t]+([a-zA-Z0-9_\\.]+)\\|\
 414 \\<\\(begin\\|else\\|record\\|loop\\|select\\|do\\|then\\|\
 415 declare\\|generic\\|private\\)\\>\\|\
 416 ^[ \t]*\\(package\\|procedure\\|function\\)\\>[ \ta-zA-Z0-9_\\.]+\\<is\\>\\|\
 417 ^[ \t]*exception\\>\\)"
 418   "Regexp of possible ends for a non-broken statement.
 419 A new statement starts after these.")
 420
 421 (defvar ada-loop-start-re
 422   "\\<\\(for\\|while\\|loop\\)\\>"
 423   "Regexp for the start of a loop.")
 424
 425 (defvar ada-subprog-start-re
 426   "\\<\\(procedure\\|protected\\|package\\|function\\|\
 427 task\\|accept\\|entry\\)\\>"
 428   "Regexp for the start of a subprogram.")
 429
 430 (defvar ada-named-block-re
 431   "[ \t]*[a-zA-Z_0-9]+ *:[^=]"
 432   "Regexp of the name of a block or loop.")
 433
 434 \f
 435 ;; Written by Christian Egli <Christian.Egli@hcsd.hac.com>
 436 ;;
 437 (defvar ada-imenu-generic-expression
 438       '((nil "^\\s-*\\(procedure\\|function\\)\\s-+\\([A-Za-z0-9_]+\\)" 2)
 439         ("Type Defs" "^\\s-*\\(sub\\)?type\\s-+\\([A-Za-z0-9_]+\\)" 2))
 440
 441   "Imenu generic expression for Ada mode.  See `imenu-generic-expression'.")
 442 \f
 443 ;;;-------------
 444 ;;;  functions
 445 ;;;-------------
 446
 447 (defun ada-xemacs ()
 448   (or (string-match "Lucid"  emacs-version)
 449       (string-match "XEmacs" emacs-version)))
 450
 451 (defun ada-create-syntax-table ()
 452   "Create the syntax table for Ada mode."
 453   ;; There are two different syntax-tables.  The standard one declares
 454   ;; `_' as a symbol constituent, in the second one, it is a word
 455   ;; constituent.  For some search and replacing routines we
 456   ;; temporarily switch between the two.
 457   (setq ada-mode-syntax-table (make-syntax-table))
 458   (set-syntax-table  ada-mode-syntax-table)
 459
 460   ;; define string brackets (`%' is alternative string bracket, but
 461   ;; almost never used as such and throws font-lock and indentation
 462   ;; off the track.)
 463   (modify-syntax-entry ?%  "$" ada-mode-syntax-table)
 464   (modify-syntax-entry ?\" "\"" ada-mode-syntax-table)
 465
 466   (modify-syntax-entry ?\#  "$" ada-mode-syntax-table)
 467
 468   (modify-syntax-entry ?:  "." ada-mode-syntax-table)
 469   (modify-syntax-entry ?\; "." ada-mode-syntax-table)
 470   (modify-syntax-entry ?&  "." ada-mode-syntax-table)
 471   (modify-syntax-entry ?\|  "." ada-mode-syntax-table)
 472   (modify-syntax-entry ?+  "." ada-mode-syntax-table)
 473   (modify-syntax-entry ?*  "." ada-mode-syntax-table)
 474   (modify-syntax-entry ?/  "." ada-mode-syntax-table)
 475   (modify-syntax-entry ?=  "." ada-mode-syntax-table)
 476   (modify-syntax-entry ?<  "." ada-mode-syntax-table)
 477   (modify-syntax-entry ?>  "." ada-mode-syntax-table)
 478   (modify-syntax-entry ?$ "." ada-mode-syntax-table)
 479   (modify-syntax-entry ?\[ "." ada-mode-syntax-table)
 480   (modify-syntax-entry ?\] "." ada-mode-syntax-table)
 481   (modify-syntax-entry ?\{ "." ada-mode-syntax-table)
 482   (modify-syntax-entry ?\} "." ada-mode-syntax-table)
 483   (modify-syntax-entry ?. "." ada-mode-syntax-table)
 484   (modify-syntax-entry ?\\ "." ada-mode-syntax-table)
 485   (modify-syntax-entry ?\' "." ada-mode-syntax-table)
 486
 487   ;; a single hyphen is punctuation, but a double hyphen starts a comment
 488   (modify-syntax-entry ?-  ". 12" ada-mode-syntax-table)
 489
 490   ;; and \f and \n end a comment
 491   (modify-syntax-entry ?\f  ">   " ada-mode-syntax-table)
 492   (modify-syntax-entry ?\n  ">   " ada-mode-syntax-table)
 493
 494   ;; define what belongs in Ada symbols
 495   (modify-syntax-entry ?_ "_" ada-mode-syntax-table)
 496
 497   ;; define parentheses to match
 498   (modify-syntax-entry ?\( "()" ada-mode-syntax-table)
 499   (modify-syntax-entry ?\) ")(" ada-mode-syntax-table)
 500
 501   (setq ada-mode-symbol-syntax-table (copy-syntax-table ada-mode-syntax-table))
 502   (modify-syntax-entry ?_ "w" ada-mode-symbol-syntax-table)
 503   )
 504
 505
 506 ;;;###autoload
 507 (defun ada-mode ()
 508   "Ada mode is the major mode for editing Ada code.
 509
 510 Bindings are as follows: (Note: 'LFD' is control-j.)
 511
 512  Indent line                                          '\\[ada-tab]'
 513  Indent line, insert newline and indent the new line. '\\[newline-and-indent]'
 514
 515  Re-format the parameter-list point is in             '\\[ada-format-paramlist]'
 516  Indent all lines in region                           '\\[ada-indent-region]'
 517  Call external pretty printer program                 '\\[ada-call-pretty-printer]'
 518
 519  Adjust case of identifiers and keywords in region    '\\[ada-adjust-case-region]'
 520  Adjust case of identifiers and keywords in buffer    '\\[ada-adjust-case-buffer]'
 521
 522  Call EXTERNAL pretty printer (if you have one)       '\\[ada-call-pretty-printer]'
 523
 524  Fill comment paragraph                               '\\[ada-fill-comment-paragraph]'
 525  Fill comment paragraph and justify each line         '\\[ada-fill-comment-paragraph-justify]'
 526  Fill comment paragraph, justify and append postfix   '\\[ada-fill-comment-paragraph-postfix]'
 527
 528  Next func/proc/task '\\[ada-next-procedure]'  Previous func/proc/task '\\[ada-previous-procedure]'
 529  Next package        '\\[ada-next-package]'  Previous package        '\\[ada-previous-package]'
 530
 531  Goto matching start of current 'end ...;'            '\\[ada-move-to-start]'
 532  Goto end of current block                            '\\[ada-move-to-end]'
 533
 534 Comments are handled using standard GNU Emacs conventions, including:
 535  Start a comment                                      '\\[indent-for-comment]'
 536  Comment region                                       '\\[comment-region]'
 537  Uncomment region                                     '\\[ada-uncomment-region]'
 538  Continue comment on next line                        '\\[indent-new-comment-line]'
 539
 540 If you use imenu.el:
 541  Display index-menu of functions & procedures         '\\[imenu]'
 542
 543 If you use find-file.el:
 544  Switch to other file (Body <-> Spec)                 '\\[ff-find-other-file]'
 545                                                    or '\\[ff-mouse-find-other-file]
 546  Switch to other file in other window                 '\\[ada-ff-other-window]'
 547                                                    or '\\[ff-mouse-find-other-file-other-window]
 548  If you use this function in a spec and no body is available, it gets created
 549  with body stubs.
 550
 551 If you use ada-xref.el:
 552  Goto declaration:          '\\[ada-point-and-xref]' on the identifier
 553                          or '\\[ada-goto-declaration]' with point on the identifier
 554  Complete identifier:       '\\[ada-complete-identifier]'
 555  Execute Gnatf:             '\\[ada-gnatf-current]'"
 556
 557   (interactive)
 558   (kill-all-local-variables)
 559
 560   (make-local-variable 'require-final-newline)
 561   (setq require-final-newline t)
 562
 563   (make-local-variable 'comment-start)
 564   (setq comment-start "-- ")
 565
 566   ;; comment end must be set because it may hold a wrong value if
 567   ;; this buffer had been in another mode before. RE
 568   (make-local-variable 'comment-end)
 569   (setq comment-end "")
 570
 571   (make-local-variable 'comment-start-skip) ;; used by autofill
 572   (setq comment-start-skip "--+[ \t]*")
 573
 574   (make-local-variable 'indent-line-function)
 575   (setq indent-line-function 'ada-indent-current-function)
 576
 577   (make-local-variable 'fill-column)
 578   (setq fill-column 75)
 579
 580   (make-local-variable 'comment-column)
 581   (setq comment-column 40)
 582
 583   (make-local-variable 'parse-sexp-ignore-comments)
 584   (setq parse-sexp-ignore-comments t)
 585
 586   (make-local-variable 'case-fold-search)
 587   (setq case-fold-search t)
 588
 589   (make-local-variable 'outline-regexp)
 590   (setq outline-regexp "[^\n\^M]")
 591   (make-local-variable 'outline-level)
 592   (setq outline-level 'ada-outline-level)
 593
 594   (make-local-variable 'fill-paragraph-function)
 595   (setq fill-paragraph-function 'ada-fill-comment-paragraph)
 596   ;;(make-local-variable 'adaptive-fill-regexp)
 597
 598   (make-local-variable 'imenu-generic-expression)
 599   (setq imenu-generic-expression ada-imenu-generic-expression)
 600
 601   (if (ada-xemacs) nil ; XEmacs uses properties
 602     (make-local-variable 'font-lock-defaults)
 603     (setq font-lock-defaults
 604           '((ada-font-lock-keywords
 605              ada-font-lock-keywords-1 ada-font-lock-keywords-2)
 606             nil t
 607             ((?\_ . "w")(?\. . "w"))
 608             beginning-of-line
 609             (font-lock-syntactic-keywords . ada-font-lock-syntactic-keywords)))
 610
 611     ;; Set up support for find-file.el.
 612     (make-variable-buffer-local 'ff-other-file-alist)
 613     (make-variable-buffer-local 'ff-search-directories)
 614     (setq ff-other-file-alist   'ada-other-file-alist
 615           ff-search-directories 'ada-search-directories
 616           ff-pre-load-hooks     'ff-which-function-are-we-in
 617           ff-post-load-hooks    'ff-set-point-accordingly
 618           ff-file-created-hooks 'ada-make-body))
 619
 620   (setq major-mode 'ada-mode)
 621   (setq mode-name "Ada")
 622
 623   (use-local-map ada-mode-map)
 624
 625   (if ada-mode-syntax-table
 626       (set-syntax-table ada-mode-syntax-table)
 627     (ada-create-syntax-table))
 628
 629   (if ada-clean-buffer-before-saving
 630       (progn
 631         ;; remove all spaces at the end of lines in the whole buffer.
 632         (add-hook 'local-write-file-hooks 'ada-remove-trailing-spaces)
 633         ;; convert all tabs to the correct number of spaces.
 634         (add-hook 'local-write-file-hooks 'ada-untabify-buffer)))
 635
 636
 637   ;; add menu 'Ada' to the menu bar
 638   (ada-add-ada-menu)
 639
 640   (run-hooks 'ada-mode-hook)
 641
 642   ;; the following has to be done after running the ada-mode-hook
 643   ;; because users might want to set the values of these variable
 644   ;; inside the hook (MH)
 645
 646   (cond ((eq ada-language-version 'ada83)
 647          (setq ada-keywords ada-83-keywords))
 648         ((eq ada-language-version 'ada95)
 649          (setq ada-keywords ada-95-keywords)))
 650
 651   (if ada-auto-case
 652       (ada-activate-keys-for-case)))
 653
 654 \f
 655 ;;;--------------------------
 656 ;;;  Compile support
 657 ;;;--------------------------
 658
 659 (defun ada-check-syntax ()
 660   "Check syntax of the current buffer.
 661 Uses the function `compile' to execute `ada-compiler-syntax-check'."
 662   (interactive)
 663   (let ((old-compile-command compile-command))
 664     (setq compile-command (concat ada-compiler-syntax-check
 665                                   (if (eq ada-language-version 'ada83)
 666                                       "-gnat83 ")
 667                                   " " ada-compile-options " "
 668                                   (buffer-name)))
 669     (setq compile-command (read-from-minibuffer
 670                            "enter command for syntax check: "
 671                            compile-command))
 672     (compile compile-command)
 673     ;; restore old compile-command
 674     (setq compile-command old-compile-command)))
 675
 676 (defun ada-make-local ()
 677   "Bring current Ada unit up-to-date.
 678 Uses the function `compile' to execute `ada-compile-make'."
 679   (interactive)
 680   (let ((old-compile-command compile-command))
 681     (setq compile-command (concat ada-compiler-make
 682                                   " " ada-make-options " "
 683                                   (buffer-name)))
 684     (setq compile-command (read-from-minibuffer
 685                            "enter command for local make: "
 686                            compile-command))
 687     (compile compile-command)
 688     ;; restore old compile-command
 689     (setq compile-command old-compile-command)))
 690
 691
 692
 693 \f
 694 ;;;--------------------------
 695 ;;;  Fill Comment Paragraph
 696 ;;;--------------------------
 697
 698 (defun ada-fill-comment-paragraph-justify ()
 699   "Fills current comment paragraph and justifies each line as well."
 700   (interactive)
 701   (ada-fill-comment-paragraph t))
 702
 703
 704 (defun ada-fill-comment-paragraph-postfix ()
 705   "Fills current comment paragraph and justifies each line as well.
 706 Prompts for a postfix to be appended to each line."
 707   (interactive)
 708   (ada-fill-comment-paragraph t t))
 709
 710
 711 (defun ada-fill-comment-paragraph (&optional justify postfix)
 712   "Fills the current comment paragraph.
 713 If JUSTIFY is non-nil, each line is justified as well.
 714 If POSTFIX and JUSTIFY are  non-nil, `ada-fill-comment-postfix' is appended
 715 to each filled and justified line.
 716 If `ada-indent-comment-as-code' is non-nil, the paragraph is indented."
 717   (interactive "P")
 718   (let ((opos (point-marker))
 719         (begin nil)
 720         (end nil)
 721         (end-2 nil)
 722         (indent nil)
 723         (ada-fill-comment-old-postfix "")
 724         (fill-prefix nil))
 725
 726     ;; check if inside comment
 727     (if (not (ada-in-comment-p))
 728         (error "not inside comment"))
 729
 730     ;; prompt for postfix if wanted
 731     (if (and justify
 732              postfix)
 733         (setq ada-fill-comment-postfix
 734               (read-from-minibuffer "enter new postfix string: "
 735                                     ada-fill-comment-postfix)))
 736
 737     ;; prompt for old postfix to remove if necessary
 738     (if (and justify
 739              postfix)
 740         (setq ada-fill-comment-old-postfix
 741               (read-from-minibuffer "enter already existing postfix string: "
 742                                     ada-fill-comment-postfix)))
 743
 744     ;;
 745     ;; find limits of paragraph
 746     ;;
 747     (message "filling comment paragraph ...")
 748     (save-excursion
 749       (back-to-indentation)
 750       ;; find end of paragraph
 751       (while (and (looking-at "--.*$")
 752                   (not (looking-at "--[ \t]*$")))
 753         (forward-line 1)
 754         (back-to-indentation))
 755       (beginning-of-line)
 756       (setq end (point-marker))
 757       (goto-char opos)
 758       ;; find begin of paragraph
 759       (back-to-indentation)
 760       (while (and (looking-at "--.*$")
 761                   (not (looking-at "--[ \t]*$")))
 762         (forward-line -1)
 763         (back-to-indentation))
 764       (forward-line 1)
 765       ;; get indentation to calculate width for filling
 766       (ada-indent-current)
 767       (back-to-indentation)
 768       (setq indent (current-column))
 769       (setq begin (point-marker)))
 770
 771     ;; delete old postfix if necessary
 772     (if (and justify
 773              postfix)
 774         (save-excursion
 775           (goto-char begin)
 776           (while (re-search-forward (concat ada-fill-comment-old-postfix
 777                                             "\n")
 778                                     end t)
 779             (replace-match "\n"))))
 780
 781     ;; delete leading whitespace and uncomment
 782     (save-excursion
 783       (goto-char begin)
 784       (beginning-of-line)
 785       (while (re-search-forward "^[ \t]*--[ \t]*" end t)
 786         (replace-match "")))
 787
 788     ;; calculate fill width
 789     (setq fill-column (- fill-column indent
 790                          (length ada-fill-comment-prefix)
 791                          (if postfix
 792                              (length ada-fill-comment-postfix)
 793                            0)))
 794     ;; fill paragraph
 795     (fill-region begin (1- end) justify)
 796     (setq fill-column (+ fill-column indent
 797                          (length ada-fill-comment-prefix)
 798                          (if postfix
 799                              (length ada-fill-comment-postfix)
 800                            0)))
 801    ;; find end of second last line
 802     (save-excursion
 803       (goto-char end)
 804       (forward-line -2)
 805       (end-of-line)
 806       (setq end-2 (point-marker)))
 807
 808     ;; re-comment and re-indent region
 809     (save-excursion
 810       (goto-char begin)
 811       (indent-to indent)
 812       (insert ada-fill-comment-prefix)
 813       (while (re-search-forward "\n" (1- end-2) t)
 814         (replace-match (concat "\n" ada-fill-comment-prefix))
 815         (beginning-of-line)
 816         (indent-to indent)))
 817
 818     ;; append postfix if wanted
 819     (if (and justify
 820              postfix
 821              ada-fill-comment-postfix)
 822         (progn
 823           ;; append postfix up to there
 824           (save-excursion
 825             (goto-char begin)
 826             (while (re-search-forward "\n" (1- end-2) t)
 827               (replace-match (concat ada-fill-comment-postfix "\n")))
 828
 829             ;; fill last line and append postfix
 830             (end-of-line)
 831             (insert-char ?
 832                          (- fill-column
 833                             (current-column)
 834                             (length ada-fill-comment-postfix)))
 835             (insert ada-fill-comment-postfix))))
 836
 837     ;; delete the extra line that gets inserted somehow(??)
 838     (save-excursion
 839       (goto-char (1- end))
 840       (end-of-line)
 841       (delete-char 1))
 842
 843      (message "filling comment paragraph ... done")
 844     (goto-char opos))
 845   t)
 846
 847 \f
 848 ;;;--------------------------------;;;
 849 ;;;  Call External Pretty Printer  ;;;
 850 ;;;--------------------------------;;;
 851
 852 (defun ada-call-pretty-printer ()
 853   "Calls the external Pretty Printer.
 854 The name is specified in `ada-external-pretty-print-program'.  Saves the
 855 current buffer in a directory specified by `ada-tmp-directory',
 856 starts the pretty printer as external process on that file and then
 857 reloads the beautified program in the buffer and cleans up
 858 `ada-tmp-directory'."
 859   (interactive)
 860   (let ((filename-with-path buffer-file-name)
 861         (curbuf (current-buffer))
 862         (orgpos (point))
 863         (mesgbuf nil) ;; for byte-compiling
 864         (file-path (file-name-directory buffer-file-name))
 865         (filename-without-path (file-name-nondirectory buffer-file-name))
 866         (tmp-file-with-directory
 867          (concat ada-tmp-directory
 868                  (file-name-nondirectory buffer-file-name))))
 869     ;;
 870     ;; save buffer in temporary file
 871     ;;
 872     (message "saving current buffer to temporary file ...")
 873     (write-file tmp-file-with-directory)
 874     (auto-save-mode nil)
 875     (message "saving current buffer to temporary file ... done")
 876     ;;
 877     ;; call external pretty printer program
 878     ;;
 879
 880     (message "running external pretty printer ...")
 881     ;; create a temporary buffer for messages of pretty printer
 882     (setq mesgbuf (get-buffer-create "Pretty Printer Messages"))
 883     ;; execute pretty printer on temporary file
 884     (call-process ada-external-pretty-print-program
 885                   nil mesgbuf t
 886                   tmp-file-with-directory)
 887     ;; display messages if there are some
 888     (if (buffer-modified-p mesgbuf)
 889         ;; show the message buffer
 890         (display-buffer mesgbuf t)
 891       ;; kill the message buffer
 892       (kill-buffer mesgbuf))
 893     (message "running external pretty printer ... done")
 894     ;;
 895     ;; kill current buffer and load pretty printer output
 896     ;; or restore old buffer
 897     ;;
 898     (if (y-or-n-p
 899          "Really replace current buffer with pretty printer output ? ")
 900         (progn
 901           (set-buffer-modified-p nil)
 902           (kill-buffer curbuf)
 903           (find-file tmp-file-with-directory))
 904       (message "old buffer contents restored"))
 905     ;;
 906     ;; delete temporary file and restore information of current buffer
 907     ;;
 908     (delete-file tmp-file-with-directory)
 909     (set-visited-file-name filename-with-path)
 910     (auto-save-mode t)
 911     (goto-char orgpos)))
 912
 913 \f
 914 ;;;---------------
 915 ;;;  auto-casing
 916 ;;;---------------
 917
 918 ;; from Philippe Waroquiers <philippe@cfmu.eurocontrol.be>
 919 ;; modified by RE and MH
 920
 921 (defun ada-after-keyword-p ()
 922   ;; returns t if cursor is after a keyword.
 923   (save-excursion
 924     (forward-word -1)
 925     (and (save-excursion
 926            (or
 927             (= (point) (point-min))
 928             (backward-char 1))
 929            (not (looking-at "_")))     ; (MH)
 930          (looking-at (concat ada-keywords "[^_]")))))
 931
 932 (defun ada-in-char-const-p ()
 933   ;; Returns t if point is inside a character constant.
 934   ;; We assume to be in a constant if the previous and the next character
 935   ;; are "'".
 936   (save-excursion
 937     (if (> (point) 1)
 938         (and
 939          (progn
 940            (forward-char 1)
 941            (looking-at "'"))
 942          (progn
 943            (forward-char -2)
 944            (looking-at "'")))
 945       nil)))
 946
 947
 948 (defun ada-adjust-case (&optional force-identifier)
 949   "Adjust the case of the word before the just typed character.
 950 Respect options `ada-case-keyword', `ada-case-identifier', and
 951 `ada-case-attribute'.
 952 If FORCE-IDENTIFIER is non-nil then also adjust keyword as identifier." ; (MH)
 953   (forward-char -1)
 954   (if (and (> (point) 1) (not (or (ada-in-string-p)
 955                                   (ada-in-comment-p)
 956                                   (ada-in-char-const-p))))
 957       (if (eq (char-syntax (char-after (1- (point)))) ?w)
 958           (if (save-excursion
 959                 (forward-word -1)
 960                 (or (= (point) (point-min))
 961                     (backward-char 1))
 962                 (looking-at "'"))
 963               (funcall ada-case-attribute -1)
 964             (if (and
 965                  (not force-identifier) ; (MH)
 966                  (ada-after-keyword-p))
 967                 (funcall ada-case-keyword -1)
 968               (funcall ada-case-identifier -1)))))
 969   (forward-char 1))
 970
 971
 972 (defun ada-adjust-case-interactive (arg)
 973   (interactive "P")
 974   (let ((lastk last-command-char))
 975     (cond ((or (eq lastk ?\n)
 976                (eq lastk ?\r))
 977            ;; horrible kludge
 978            (insert " ")
 979            (ada-adjust-case)
 980            ;; horrible dekludge
 981            (delete-backward-char 1)
 982            ;; some special keys and their bindings
 983            (cond
 984             ((eq lastk ?\n)
 985              (funcall ada-lfd-binding))
 986             ((eq lastk ?\r)
 987              (funcall ada-ret-binding))))
 988           ((eq lastk ?\C-i) (ada-tab))
 989           ((self-insert-command (prefix-numeric-value arg))))
 990     ;; if there is a keyword in front of the underscore
 991     ;; then it should be part of an identifier (MH)
 992     (if (eq lastk ?_)
 993         (ada-adjust-case t)
 994       (ada-adjust-case))))
 995
 996
 997 (defun ada-activate-keys-for-case ()
 998   ;; save original keybindings to allow swapping ret/lfd
 999   ;; when casing is activated
1000   ;; the 'or ...' is there to be sure that the value will not
1001   ;; be changed again when Ada mode is called more than once (MH)
1002   (or ada-ret-binding
1003       (setq ada-ret-binding (key-binding "\C-M")))
1004   (or ada-lfd-binding
1005       (setq ada-lfd-binding (key-binding "\C-j")))
1006   ;; call case modifying function after certain keys.
1007   (mapcar (function (lambda(key) (define-key
1008                                    ada-mode-map
1009                                    (char-to-string key)
1010                                    'ada-adjust-case-interactive)))
1011           '( ?` ?~ ?! ?@ ?# ?$ ?% ?^ ?& ?* ?( ?)  ?- ?= ?+ ?[ ?{ ?] ?}
1012                 ?_ ?\\ ?| ?\; ?: ?' ?\" ?< ?, ?. ?> ?? ?/ ?\n 32 ?\r )))
1013 ;; deleted ?\t from above list
1014
1015 ;;
1016 ;; added by MH
1017 ;;
1018 (defun ada-loose-case-word (&optional arg)
1019   "Capitalizes the first letter and the letters following `_'.
1020 ARG is ignored, it's there to fit the standard casing functions' style."
1021   (let ((pos (point))
1022         (first t))
1023     (skip-chars-backward "a-zA-Z0-9_")
1024     (while (or first
1025                (search-forward "_" pos t))
1026       (and first
1027            (setq first nil))
1028       (insert-char (upcase (following-char)) 1)
1029       (delete-char 1))
1030     (goto-char pos)))
1031
1032
1033 ;;
1034 ;; added by MH
1035 ;; modified by JSH to handle attributes
1036 ;;
1037 (defun ada-adjust-case-region (from to)
1038   "Adjusts the case of all words in the region.
1039 Attention: This function might take very long for big regions !"
1040   (interactive "*r")
1041   (let ((begin nil)
1042         (end nil)
1043         (keywordp nil)
1044         (attribp nil))
1045     (unwind-protect
1046         (save-excursion
1047           (set-syntax-table ada-mode-symbol-syntax-table)
1048           (goto-char to)
1049           ;;
1050           ;; loop: look for all identifiers, keywords, and attributes
1051           ;;
1052           (while (re-search-backward
1053                   "[^a-zA-Z0-9_]\\([a-zA-Z0-9_]+\\)[^a-zA-Z0-9_]"
1054                   from
1055                   t)
1056             ;;
1057             ;; print status message
1058             ;;
1059             (message "adjusting case ... %5d characters left" (- (point) from))
1060             (setq attribp (looking-at "'[a-zA-Z0-9_]+[^']"))
1061             (forward-char 1)
1062             (or
1063              ;; do nothing if it is a string or comment
1064              (ada-in-string-or-comment-p)
1065              (progn
1066                ;;
1067                ;; get the identifier or keyword or attribute
1068                ;;
1069                (setq begin (point))
1070                (setq keywordp (looking-at (concat ada-keywords "[^_]")))
1071                (skip-chars-forward "a-zA-Z0-9_")
1072                ;;
1073                ;; casing according to user-option
1074                ;;
1075                (if keywordp
1076                    (funcall ada-case-keyword -1)
1077                  (if attribp
1078                      (funcall ada-case-attribute -1)
1079                    (funcall ada-case-identifier -1)))
1080                (goto-char begin))))
1081           (message "adjusting case ... done"))
1082       (set-syntax-table ada-mode-syntax-table))))
1083
1084
1085 ;;
1086 ;; added by MH
1087 ;;
1088 (defun ada-adjust-case-buffer ()
1089   "Adjusts the case of all words in the whole buffer.
1090 ATTENTION: This function might take very long for big buffers !"
1091   (interactive "*")
1092   (ada-adjust-case-region (point-min) (point-max)))
1093
1094 \f
1095 ;;;------------------------;;;
1096 ;;; Format Parameter Lists ;;;
1097 ;;;------------------------;;;
1098
1099 (defun ada-format-paramlist ()
1100   "Reformats a parameter list.
1101 ATTENTION:  1) Comments inside the list are killed !
1102             2) If the syntax is not correct (especially, if there are
1103                semicolons missing), it can get totally confused !
1104 In such a case, use `undo', correct the syntax and try again."
1105
1106   (interactive)
1107   (let ((begin nil)
1108         (end nil)
1109         (delend nil)
1110         (paramlist nil))
1111     (unwind-protect
1112         (progn
1113           (set-syntax-table ada-mode-symbol-syntax-table)
1114
1115           ;; check if really inside parameter list
1116           (or (ada-in-paramlist-p)
1117               (error "not in parameter list"))
1118           ;;
1119           ;; find start of current parameter-list
1120           ;;
1121           (ada-search-ignore-string-comment
1122            (concat ada-subprog-start-re "\\|\\<body\\>" ) t nil)
1123           (ada-search-ignore-string-comment "(" nil nil t)
1124           (backward-char 1)
1125           (setq begin (point))
1126
1127           ;;
1128           ;; find end of parameter-list
1129           ;;
1130           (forward-sexp 1)
1131           (setq delend (point))
1132           (delete-char -1)
1133
1134           ;;
1135           ;; find end of last parameter-declaration
1136           ;;
1137           (ada-search-ignore-string-comment "[^ \t\n]" t nil t)
1138           (forward-char 1)
1139           (setq end (point))
1140
1141           ;;
1142           ;; build a list of all elements of the parameter-list
1143           ;;
1144           (setq paramlist (ada-scan-paramlist (1+ begin) end))
1145
1146           ;;
1147           ;; delete the original parameter-list
1148           ;;
1149           (delete-region begin (1- delend))
1150
1151           ;;
1152           ;; insert the new parameter-list
1153           ;;
1154           (goto-char begin)
1155           (ada-insert-paramlist paramlist))
1156
1157       ;;
1158       ;; restore syntax-table
1159       ;;
1160       (set-syntax-table ada-mode-syntax-table)
1161       )))
1162
1163
1164 (defun ada-scan-paramlist (begin end)
1165   ;; Scans a parameter-list  between BEGIN and END and returns a list
1166   ;; of its contents.
1167   ;; The list has the following format:
1168   ;;
1169   ;;   Name of Param  in? out? access?  Name of Type   Default-Exp or nil
1170   ;;
1171   ;; ( ('Name_Param_1' t   nil    t      Type_Param_1   ':= expression')
1172   ;;   ('Name_Param_2' nil nil    t      Type_Param_2    nil) )
1173
1174   (let ((paramlist (list))
1175         (param (list))
1176         (notend t)
1177         (apos nil)
1178         (epos nil)
1179         (semipos nil)
1180         (match-cons nil))
1181
1182     (goto-char begin)
1183     ;;
1184     ;; loop until end of last parameter
1185     ;;
1186     (while notend
1187
1188       ;;
1189       ;; find first character of parameter-declaration
1190       ;;
1191       (ada-goto-next-non-ws)
1192       (setq apos (point))
1193
1194       ;;
1195       ;; find last character of parameter-declaration
1196       ;;
1197       (if (setq match-cons
1198                 (ada-search-ignore-string-comment "[ \t\n]*;" nil end t))
1199           (progn
1200             (setq epos (car match-cons))
1201             (setq semipos (cdr match-cons)))
1202         (setq epos end))
1203
1204       ;;
1205       ;; read name(s) of parameter(s)
1206       ;;
1207       (goto-char apos)
1208       (looking-at "\\([a-zA-Z0-9_, \t\n]*[a-zA-Z0-9_]\\)[ \t\n]*:[^=]")
1209
1210       (setq param (list (buffer-substring (match-beginning 1)
1211                                           (match-end 1))))
1212       (ada-search-ignore-string-comment ":" nil epos t)
1213
1214       ;;
1215       ;; look for 'in'
1216       ;;
1217       (setq apos (point))
1218       (setq param
1219             (append param
1220                     (list
1221                      (consp
1222                       (ada-search-ignore-string-comment "\\<in\\>"
1223                                                         nil
1224                                                         epos
1225                                                         t)))))
1226
1227       ;;
1228       ;; look for 'out'
1229       ;;
1230       (goto-char apos)
1231       (setq param
1232             (append param
1233                     (list
1234                      (consp
1235                       (ada-search-ignore-string-comment "\\<out\\>"
1236                                                         nil
1237                                                         epos
1238                                                         t)))))
1239
1240       ;;
1241       ;; look for 'access'
1242       ;;
1243       (goto-char apos)
1244       (setq param
1245             (append param
1246                     (list
1247                      (consp
1248                       (ada-search-ignore-string-comment "\\<access\\>"
1249                                                         nil
1250                                                         epos
1251                                                         t)))))
1252
1253       ;;
1254       ;; skip 'in'/'out'/'access'
1255       ;;
1256       (goto-char apos)
1257       (ada-goto-next-non-ws)
1258       (while (looking-at "\\<\\(in\\|out\\|access\\)\\>")
1259         (forward-word 1)
1260         (ada-goto-next-non-ws))
1261
1262       ;;
1263       ;; read type of parameter
1264       ;;
1265       (looking-at "\\<[a-zA-Z0-9_\\.\\']+\\>")
1266       (setq param
1267             (append param
1268                     (list
1269                      (buffer-substring (match-beginning 0)
1270                                        (match-end 0)))))
1271
1272       ;;
1273       ;; read default-expression, if there is one
1274       ;;
1275       (goto-char (setq apos (match-end 0)))
1276       (setq param
1277             (append param
1278                     (list
1279                      (if (setq match-cons
1280                                (ada-search-ignore-string-comment ":="
1281                                                                  nil
1282                                                                  epos
1283                                                                  t))
1284                          (buffer-substring (car match-cons)
1285                                            epos)
1286                        nil))))
1287       ;;
1288       ;; add this parameter-declaration to the list
1289       ;;
1290       (setq paramlist (append paramlist (list param)))
1291
1292       ;;
1293       ;; check if it was the last parameter
1294       ;;
1295       (if (eq epos end)
1296           (setq notend nil)
1297         (goto-char semipos))
1298
1299       ) ; end of loop
1300
1301     (reverse paramlist)))
1302
1303
1304 (defun ada-insert-paramlist (paramlist)
1305   ;; Inserts a formatted PARAMLIST in the buffer.
1306   ;; See doc of `ada-scan-paramlist' for the format.
1307   (let ((i (length paramlist))
1308         (parlen 0)
1309         (typlen 0)
1310         (temp 0)
1311         (inp nil)
1312         (outp nil)
1313         (accessp nil)
1314         (column nil)
1315         (orgpoint 0)
1316         (firstcol nil))
1317
1318     ;;
1319     ;; loop until last parameter
1320     ;;
1321     (while (not (zerop i))
1322       (setq i (1- i))
1323
1324       ;;
1325       ;; get max length of parameter-name
1326       ;;
1327       (setq parlen
1328             (if (<= parlen (setq temp
1329                               (length (nth 0 (nth i paramlist)))))
1330                 temp
1331               parlen))
1332
1333       ;;
1334       ;; get max length of type-name
1335       ;;
1336       (setq typlen
1337             (if (<= typlen (setq temp
1338                               (length (nth 4 (nth i paramlist)))))
1339                 temp
1340               typlen))
1341
1342       ;;
1343       ;; is there any 'in' ?
1344       ;;
1345       (setq inp
1346             (or inp
1347                 (nth 1 (nth i paramlist))))
1348
1349       ;;
1350       ;; is there any 'out' ?
1351       ;;
1352       (setq outp
1353             (or outp
1354                 (nth 2 (nth i paramlist))))
1355
1356       ;;
1357       ;; is there any 'access' ?
1358       ;;
1359       (setq accessp
1360             (or accessp
1361                 (nth 3 (nth i paramlist))))) ; end of loop
1362
1363     ;;
1364     ;; does paramlist already start on a separate line ?
1365     ;;
1366     (if (save-excursion
1367           (re-search-backward "^.\\|[^ \t]" nil t)
1368           (looking-at "^."))
1369         ;; yes => re-indent it
1370         (ada-indent-current)
1371       ;;
1372       ;; no => insert newline and indent it
1373       ;;
1374       (progn
1375         (ada-indent-current)
1376         (newline)
1377         (delete-horizontal-space)
1378         (setq orgpoint (point))
1379         (setq column (save-excursion
1380                        (funcall (ada-indent-function) orgpoint)))
1381         (indent-to column)
1382         ))
1383
1384     (insert "(")
1385
1386     (setq firstcol (current-column))
1387     (setq i (length paramlist))
1388
1389     ;;
1390     ;; loop until last parameter
1391     ;;
1392     (while (not (zerop i))
1393       (setq i (1- i))
1394       (setq column firstcol)
1395
1396       ;;
1397       ;; insert parameter-name, space and colon
1398       ;;
1399       (insert (nth 0 (nth i paramlist)))
1400       (indent-to (+ column parlen 1))
1401       (insert ": ")
1402       (setq column (current-column))
1403
1404       ;;
1405       ;; insert 'in' or space
1406       ;;
1407       (if (nth 1 (nth i paramlist))
1408           (insert "in ")
1409         (if (and
1410              (or inp
1411                  accessp)
1412              (not (nth 3 (nth i paramlist))))
1413             (insert "   ")))
1414
1415       ;;
1416       ;; insert 'out' or space
1417       ;;
1418       (if (nth 2 (nth i paramlist))
1419           (insert "out ")
1420         (if (and
1421              (or outp
1422                  accessp)
1423              (not (nth 3 (nth i paramlist))))
1424             (insert "    ")))
1425
1426       ;;
1427       ;; insert 'access'
1428       ;;
1429       (if (nth 3 (nth i paramlist))
1430           (insert "access "))
1431
1432       (setq column (current-column))
1433
1434       ;;
1435       ;; insert type-name and, if necessary, space and default-expression
1436       ;;
1437       (insert (nth 4 (nth i paramlist)))
1438       (if (nth 5 (nth i paramlist))
1439           (progn
1440             (indent-to (+ column typlen 1))
1441             (insert (nth 5 (nth i paramlist)))))
1442
1443       ;;
1444       ;; check if it was the last parameter
1445       ;;
1446       (if (not (zerop i))
1447           ;; no => insert ';' and newline and indent
1448           (progn
1449             (insert ";")
1450             (newline)
1451             (indent-to firstcol))
1452         ;; yes
1453         (insert ")"))
1454
1455       ) ; end of loop
1456
1457     ;;
1458     ;; if anything follows, except semicolon:
1459     ;; put it in a new line and indent it
1460     ;;
1461     (if (not (looking-at "[ \t]*[;\n]"))
1462         (ada-indent-newline-indent))
1463
1464     ))
1465
1466 \f
1467 ;;;----------------------------;;;
1468 ;;; Move To Matching Start/End ;;;
1469 ;;;----------------------------;;;
1470
1471 (defun ada-move-to-start ()
1472   "Moves point to the matching start of the current Ada structure."
1473   (interactive)
1474   (let ((pos (point)))
1475     (unwind-protect
1476         (progn
1477           (set-syntax-table ada-mode-symbol-syntax-table)
1478
1479           (message "searching for block start ...")
1480           (save-excursion
1481             ;;
1482             ;; do nothing if in string or comment or not on 'end ...;'
1483             ;;            or if an error occurs during processing
1484             ;;
1485             (or
1486              (ada-in-string-or-comment-p)
1487              (and (progn
1488                     (or (looking-at "[ \t]*\\<end\\>")
1489                         (backward-word 1))
1490                     (or (looking-at "[ \t]*\\<end\\>")
1491                         (backward-word 1))
1492                     (or (looking-at "[ \t]*\\<end\\>")
1493                         (error "not on end ...;")))
1494                   (ada-goto-matching-start 1)
1495                   (setq pos (point))
1496
1497                   ;;
1498                   ;; on 'begin' => go on, according to user option
1499                   ;;
1500                   ada-move-to-declaration
1501                   (looking-at "\\<begin\\>")
1502                   (ada-goto-matching-decl-start)
1503                   (setq pos (point))))
1504
1505             ) ; end of save-excursion
1506
1507           ;; now really move to the found position
1508           (goto-char pos)
1509           (message "searching for block start ... done"))
1510
1511       ;;
1512       ;; restore syntax-table
1513       ;;
1514       (set-syntax-table ada-mode-syntax-table))))
1515
1516
1517 (defun ada-move-to-end ()
1518   "Moves point to the matching end of the current block around point.
1519 Moves to 'begin' if in a declarative part."
1520   (interactive)
1521   (let ((pos (point))
1522         (decstart nil)
1523         (packdecl nil))
1524     (unwind-protect
1525         (progn
1526           (set-syntax-table ada-mode-symbol-syntax-table)
1527
1528           (message "searching for block end ...")
1529           (save-excursion
1530
1531             (forward-char 1)
1532             (cond
1533              ;; directly on 'begin'
1534              ((save-excursion
1535                 (ada-goto-previous-word)
1536                 (looking-at "\\<begin\\>"))
1537               (ada-goto-matching-end 1))
1538              ;; on first line of defun declaration
1539              ((save-excursion
1540                 (and (ada-goto-stmt-start)
1541                      (looking-at "\\<function\\>\\|\\<procedure\\>" )))
1542               (ada-search-ignore-string-comment "\\<begin\\>"))
1543              ;; on first line of task declaration
1544              ((save-excursion
1545                 (and (ada-goto-stmt-start)
1546                      (looking-at "\\<task\\>" )
1547                      (forward-word 1)
1548                      (ada-search-ignore-string-comment "[^ \n\t]")
1549                      (not (backward-char 1))
1550                      (looking-at "\\<body\\>")))
1551               (ada-search-ignore-string-comment "\\<begin\\>"))
1552              ;; accept block start
1553              ((save-excursion
1554                 (and (ada-goto-stmt-start)
1555                      (looking-at "\\<accept\\>" )))
1556               (ada-goto-matching-end 0))
1557              ;; package start
1558              ((save-excursion
1559                 (and (ada-goto-matching-decl-start t)
1560                      (looking-at "\\<package\\>")))
1561               (ada-goto-matching-end 1))
1562              ;; inside a 'begin' ... 'end' block
1563              ((save-excursion
1564                 (ada-goto-matching-decl-start t))
1565               (ada-search-ignore-string-comment "\\<begin\\>"))
1566              ;; (hopefully ;-) everything else
1567              (t
1568               (ada-goto-matching-end 1)))
1569             (setq pos (point))
1570
1571             ) ; end of save-excursion
1572
1573           ;; now really move to the found position
1574           (goto-char pos)
1575           (message "searching for block end ... done"))
1576
1577       ;;
1578       ;; restore syntax-table
1579       ;;
1580       (set-syntax-table ada-mode-syntax-table))))
1581
1582 \f
1583 ;;;-----------------------------;;;
1584 ;;;  Functions For Indentation  ;;;
1585 ;;;-----------------------------;;;
1586
1587 ;; ---- main functions for indentation
1588
1589 (defun ada-indent-region (beg end)
1590   "Indents the region using `ada-indent-current' on each line."
1591   (interactive "*r")
1592   (goto-char beg)
1593   (let ((block-done 0)
1594         (lines-remaining (count-lines beg end))
1595         (msg (format "indenting %4d lines %%4d lines remaining ..."
1596                      (count-lines beg end)))
1597         (endmark (copy-marker end)))
1598     ;; catch errors while indenting
1599     (condition-case err
1600         (while (< (point) endmark)
1601           (if (> block-done 9)
1602               (progn (message msg lines-remaining)
1603                      (setq block-done 0)))
1604           (if (looking-at "^$") nil
1605             (ada-indent-current))
1606           (forward-line 1)
1607           (setq block-done (1+ block-done))
1608           (setq lines-remaining (1- lines-remaining)))
1609       ;; show line number where the error occurred
1610       (error
1611        (error "line %d: %s" (1+ (count-lines (point-min) (point))) err) nil))
1612     (message "indenting ... done")))
1613
1614
1615 (defun ada-indent-newline-indent ()
1616   "Indents the current line, inserts a newline and then indents the new line."
1617   (interactive "*")
1618   (ada-indent-current)
1619   (newline)
1620   (ada-indent-current))
1621
1622
1623 (defun ada-indent-current ()
1624   "Indents current line as Ada code.
1625 This works by two steps:
1626  1) It moves point to the end of the previous code line.
1627     Then it calls the function to calculate the indentation for the
1628     following line as if a newline would be inserted there.
1629     The calculated column # is saved and the old position of point
1630     is restored.
1631  2) Then another function is called to calculate the indentation for
1632     the current line, based on the previously calculated column #."
1633
1634   (interactive)
1635
1636   (unwind-protect
1637       (progn
1638         (set-syntax-table ada-mode-symbol-syntax-table)
1639
1640         (let ((line-end)
1641               (orgpoint (point-marker))
1642               (cur-indent)
1643               (prev-indent)
1644               (prevline t))
1645
1646           ;;
1647           ;; first step
1648           ;;
1649           (save-excursion
1650             (if (ada-goto-prev-nonblank-line t)
1651                 ;;
1652                 ;; we are not in the first accessible line in the buffer
1653                 ;;
1654                 (progn
1655                   ;;(end-of-line)
1656                   ;;(forward-char 1)
1657                   ;; we are already at the BOL
1658                   (forward-line 1)
1659                   (setq line-end (point))
1660                   (setq prev-indent
1661                         (save-excursion
1662                           (funcall (ada-indent-function) line-end))))
1663               (progn                    ; first line of buffer -> set indent
1664                 (beginning-of-line)     ; to 0
1665                 (delete-horizontal-space)
1666                 (setq prevline nil))))
1667
1668           (if prevline
1669               ;;
1670               ;; we are not in the first accessible line in the buffer
1671               ;;
1672               (progn
1673                 ;;
1674                 ;; second step
1675                 ;;
1676                 (back-to-indentation)
1677                 (setq cur-indent (ada-get-current-indent prev-indent))
1678                 ;; only reindent if indentation is different then the current
1679                 (if (= (current-column) cur-indent)
1680                     nil
1681                   (delete-horizontal-space)
1682                   (indent-to cur-indent))
1683                 ;;
1684                 ;; restore position of point
1685                 ;;
1686                 (goto-char orgpoint)
1687                 (if (< (current-column) (current-indentation))
1688                     (back-to-indentation))))))
1689
1690     ;;
1691     ;; restore syntax-table
1692     ;;
1693     (set-syntax-table ada-mode-syntax-table)))
1694
1695
1696 (defun ada-get-current-indent (prev-indent)
1697   ;; Returns the column # to indent the current line to.
1698   ;; PREV-INDENT is the indentation resulting from the previous lines.
1699   (let ((column nil)
1700         (pos nil)
1701         (match-cons nil))
1702
1703     (cond
1704      ;;
1705      ;; in open parenthesis, but not in parameter-list
1706      ;;
1707      ((and
1708        ada-indent-to-open-paren
1709        (not (ada-in-paramlist-p))
1710        (setq column (ada-in-open-paren-p)))
1711       ;; check if we have something like this  (Table_Component_Type =>
1712       ;;                                          Source_File_Record,)
1713       (save-excursion
1714         (if (and (ada-search-ignore-string-comment "[^ \t]" t nil)
1715                  (looking-at "\n")
1716                  (ada-search-ignore-string-comment "[^ \t\n]" t nil)
1717                  (looking-at ">"))
1718             (setq column (+ ada-broken-indent column))))
1719       column)
1720
1721      ;;
1722      ;; end
1723      ;;
1724      ((looking-at "\\<end\\>")
1725       (let ((label 0))
1726         (save-excursion
1727           (ada-goto-matching-start 1)
1728
1729           ;;
1730           ;; found 'loop' => skip back to 'while' or 'for'
1731           ;;                 if 'loop' is not on a separate line
1732           ;;
1733           (if (and
1734                (looking-at "\\<loop\\>")
1735                (save-excursion
1736                  (back-to-indentation)
1737                  (not (looking-at "\\<loop\\>"))))
1738               (if (save-excursion
1739                     (and
1740                      (setq match-cons
1741                            (ada-search-ignore-string-comment
1742                             ada-loop-start-re t nil))
1743                      (not (looking-at "\\<loop\\>"))))
1744                   (progn
1745                     (goto-char (car match-cons))
1746                     (save-excursion
1747                       (beginning-of-line)
1748                       (if (looking-at ada-named-block-re)
1749                           (setq label (- ada-label-indent)))))))
1750
1751           (+ (current-indentation) label))))
1752      ;;
1753      ;; exception
1754      ;;
1755      ((looking-at "\\<exception\\>")
1756       (save-excursion
1757         (ada-goto-matching-start 1)
1758         (current-indentation)))
1759      ;;
1760      ;; when
1761      ;;
1762      ((looking-at "\\<when\\>")
1763       (save-excursion
1764         (ada-goto-matching-start 1)
1765         (+ (current-indentation) ada-when-indent)))
1766      ;;
1767      ;; else
1768      ;;
1769      ((looking-at "\\<else\\>")
1770       (if (save-excursion
1771             (ada-goto-previous-word)
1772             (looking-at "\\<or\\>"))
1773           prev-indent
1774         (save-excursion
1775           (ada-goto-matching-start 1 nil t)
1776           (current-indentation))))
1777      ;;
1778      ;; elsif
1779      ;;
1780      ((looking-at "\\<elsif\\>")
1781       (save-excursion
1782         (ada-goto-matching-start 1 nil t)
1783         (current-indentation)))
1784      ;;
1785      ;; then
1786      ;;
1787      ((looking-at "\\<then\\>")
1788       (if (save-excursion
1789             (ada-goto-previous-word)
1790             (looking-at "\\<and\\>"))
1791           prev-indent
1792         (save-excursion
1793           (ada-search-ignore-string-comment "\\<elsif\\>\\|\\<if\\>" t nil)
1794           (+ (current-indentation) ada-stmt-end-indent))))
1795      ;;
1796      ;; loop
1797      ;;
1798      ((looking-at "\\<loop\\>")
1799       (setq pos (point))
1800       (save-excursion
1801         (goto-char (match-end 0))
1802         (ada-goto-stmt-start)
1803         (if (looking-at "\\<loop\\>\\|\\<if\\>")
1804             prev-indent
1805           (progn
1806             (if (not (looking-at ada-loop-start-re))
1807                 (ada-search-ignore-string-comment ada-loop-start-re
1808                                                   nil pos))
1809             (if (looking-at "\\<loop\\>")
1810                 prev-indent
1811               (+ (current-indentation) ada-stmt-end-indent))))))
1812      ;;
1813      ;; begin
1814      ;;
1815      ((looking-at "\\<begin\\>")
1816       (save-excursion
1817         (if (ada-goto-matching-decl-start t)
1818             (current-indentation)
1819           prev-indent)))
1820      ;;
1821      ;; is
1822      ;;
1823      ((looking-at "\\<is\\>")
1824       (if (and
1825            ada-indent-is-separate
1826            (save-excursion
1827              (goto-char (match-end 0))
1828              (ada-goto-next-non-ws (save-excursion
1829                                      (end-of-line)
1830                                      (point)))
1831              (looking-at "\\<abstract\\>\\|\\<separate\\>")))
1832           (save-excursion
1833             (ada-goto-stmt-start)
1834             (+ (current-indentation) ada-indent))
1835         (save-excursion
1836           (ada-goto-stmt-start)
1837           (+ (current-indentation) ada-stmt-end-indent))))
1838      ;;
1839      ;; record
1840      ;;
1841      ((looking-at "\\<record\\>")
1842       (save-excursion
1843         (ada-search-ignore-string-comment
1844          "\\<\\(type\\|use\\)\\>" t nil)
1845         (if (looking-at "\\<use\\>")
1846             (ada-search-ignore-string-comment "\\<for\\>" t nil))
1847         (+ (current-indentation) ada-indent-record-rel-type)))
1848      ;;
1849      ;; or as statement-start
1850      ;;
1851      ((ada-looking-at-semi-or)
1852       (save-excursion
1853         (ada-goto-matching-start 1)
1854         (current-indentation)))
1855      ;;
1856      ;; private as statement-start
1857      ;;
1858      ((ada-looking-at-semi-private)
1859       (save-excursion
1860         (ada-goto-matching-decl-start)
1861         (current-indentation)))
1862      ;;
1863      ;; new/abstract/separate
1864      ;;
1865      ((looking-at "\\<\\(new\\|abstract\\|separate\\)\\>")
1866       (- prev-indent ada-indent (- ada-broken-indent)))
1867      ;;
1868      ;; return
1869      ;;
1870      ((looking-at "\\<return\\>")
1871       (save-excursion
1872         (forward-sexp -1)
1873         (if (and (looking-at "(")
1874                  (save-excursion
1875                    (backward-sexp 2)
1876                    (looking-at "\\<function\\>")))
1877             (1+ (current-column))
1878           prev-indent)))
1879      ;;
1880      ;; do
1881      ;;
1882      ((looking-at "\\<do\\>")
1883       (save-excursion
1884         (ada-goto-stmt-start)
1885         (+ (current-indentation) ada-stmt-end-indent)))
1886      ;;
1887      ;; package/function/procedure
1888      ;;
1889      ((and (looking-at "\\<\\(package\\|function\\|procedure\\)\\>")
1890            (save-excursion
1891              (forward-char 1)
1892              (ada-goto-stmt-start)
1893              (looking-at "\\<\\(package\\|function\\|procedure\\)\\>")))
1894       (save-excursion
1895         ;; look for 'generic'
1896         (if (and (ada-goto-matching-decl-start t)
1897                  (looking-at "generic"))
1898             (current-column)
1899           prev-indent)))
1900      ;;
1901      ;; label
1902      ;;
1903      ((looking-at "\\<[a-zA-Z0-9_]+[ \t\n]*:[^=]")
1904       (if (ada-in-decl-p)
1905           prev-indent
1906         (+ prev-indent ada-label-indent)))
1907      ;;
1908      ;; identifier and other noindent-statements
1909      ;;
1910      ((looking-at "\\<[a-zA-Z0-9_]+[ \t\n]*")
1911       prev-indent)
1912      ;;
1913      ;; beginning of a parameter list
1914      ;;
1915      ((looking-at "(")
1916       prev-indent)
1917      ;;
1918      ;; end of a parameter list
1919      ;;
1920      ((looking-at ")")
1921       (save-excursion
1922         (forward-char 1)
1923         (backward-sexp 1)
1924         (current-column)))
1925      ;;
1926      ;; comment
1927      ;;
1928      ((looking-at "--")
1929       (if ada-indent-comment-as-code
1930           prev-indent
1931         (current-indentation)))
1932      ;;
1933      ;; unknown syntax - maybe this should signal an error ?
1934      ;;
1935      (t
1936       prev-indent))))
1937
1938
1939 (defun ada-indent-function (&optional nomove)
1940   ;; Returns the function to calculate the indentation for the current
1941   ;; line according to the previous statement, ignoring the contents
1942   ;; of the current line after point.  Moves point to the beginning of
1943   ;; the current statement, if NOMOVE is nil.
1944
1945   (let ((orgpoint (point))
1946         (func nil))
1947     ;;
1948     ;; inside a parameter-list
1949     ;;
1950     (if (ada-in-paramlist-p)
1951         (setq func 'ada-get-indent-paramlist)
1952       (progn
1953         ;;
1954         ;; move to beginning of current statement
1955         ;;
1956         (if (not nomove)
1957             (ada-goto-stmt-start))
1958         ;;
1959         ;; no beginning found => don't change indentation
1960         ;;
1961         (if (and
1962              (eq orgpoint (point))
1963              (not nomove))
1964             (setq func 'ada-get-indent-nochange)
1965
1966           (cond
1967            ;;
1968            ((and
1969              ada-indent-to-open-paren
1970              (ada-in-open-paren-p))
1971             (setq func 'ada-get-indent-open-paren))
1972            ;;
1973            ((looking-at "\\<end\\>")
1974             (setq func 'ada-get-indent-end))
1975            ;;
1976            ((looking-at ada-loop-start-re)
1977             (setq func 'ada-get-indent-loop))
1978            ;;
1979            ((looking-at ada-subprog-start-re)
1980             (setq func 'ada-get-indent-subprog))
1981            ;;
1982            ((looking-at ada-block-start-re)
1983             (setq func 'ada-get-indent-block-start))
1984            ;;
1985            ((looking-at "\\<type\\>")
1986             (setq func 'ada-get-indent-type))
1987            ;;
1988            ((looking-at "\\<\\(els\\)?if\\>")
1989             (setq func 'ada-get-indent-if))
1990            ;;
1991            ((looking-at "\\<case\\>")
1992             (setq func 'ada-get-indent-case))
1993            ;;
1994            ((looking-at "\\<when\\>")
1995             (setq func 'ada-get-indent-when))
1996            ;;
1997            ((looking-at "--")
1998             (setq func 'ada-get-indent-comment))
1999            ;;
2000            ((looking-at "[a-zA-Z0-9_]+[ \t\n]*:[^=]")
2001             (setq func 'ada-get-indent-label))
2002            ;;
2003            ((looking-at "\\<separate\\>")
2004             (setq func 'ada-get-indent-nochange))
2005            (t
2006             (setq func 'ada-get-indent-noindent))))))
2007
2008     func))
2009
2010
2011 ;; ---- functions to return indentation for special cases
2012
2013 (defun ada-get-indent-open-paren (orgpoint)
2014   ;; Returns the indentation (column #) for the new line after ORGPOINT.
2015   ;; Assumes point to be behind an open parenthesis not yet closed.
2016   (ada-in-open-paren-p))
2017
2018
2019 (defun ada-get-indent-nochange (orgpoint)
2020   ;; Returns the indentation (column #) of the current line.
2021   (save-excursion
2022     (forward-line -1)
2023     (current-indentation)))
2024
2025
2026 (defun ada-get-indent-paramlist (orgpoint)
2027   ;; Returns the indentation (column #) for the new line after ORGPOINT.
2028   ;; Assumes point to be inside a parameter-list.
2029   (save-excursion
2030     (ada-search-ignore-string-comment "[^ \t\n]" t nil t)
2031     (cond
2032      ;;
2033      ;; in front of the first parameter
2034      ;;
2035      ((looking-at "(")
2036       (goto-char (match-end 0))
2037       (current-column))
2038      ;;
2039      ;; in front of another parameter
2040      ;;
2041      ((looking-at ";")
2042       (goto-char (cdr (ada-search-ignore-string-comment "(\\|;" t nil t)))
2043       (ada-goto-next-non-ws)
2044       (current-column))
2045      ;;
2046      ;; inside a parameter declaration
2047      ;;
2048      (t
2049       (goto-char (cdr (ada-search-ignore-string-comment "(\\|;" t nil t)))
2050       (ada-goto-next-non-ws)
2051       (+ (current-column) ada-broken-indent)))))
2052
2053
2054 (defun ada-get-indent-end (orgpoint)
2055   ;; Returns the indentation (column #) for the new line after ORGPOINT.
2056   ;; Assumes point to be at the beginning of an end-statement.
2057   ;; Therefore it has to find the corresponding start. This can be a little
2058   ;; slow, if it has to search through big files with many nested blocks.
2059   ;; Signals an error if the corresponding block-start doesn't match.
2060   (let ((defun-name nil)
2061         (label 0)
2062         (indent nil))
2063     ;;
2064     ;; is the line already terminated by ';' ?
2065     ;;
2066     (if (save-excursion
2067           (ada-search-ignore-string-comment ";" nil orgpoint))
2068         ;;
2069         ;; yes, look what's following 'end'
2070         ;;
2071         (progn
2072           (forward-word 1)
2073           (ada-goto-next-non-ws)
2074           (cond
2075            ;;
2076            ;; loop/select/if/case/record/select
2077            ;;
2078            ((looking-at "\\<\\(loop\\|select\\|if\\|case\\|record\\)\\>")
2079             (save-excursion
2080               (ada-check-matching-start
2081                (buffer-substring (match-beginning 0)
2082                                  (match-end 0)))
2083               (if (looking-at "\\<\\(loop\\|record\\)\\>")
2084                   (progn
2085                     (forward-word 1)
2086                     (ada-goto-stmt-start)))
2087               ;; a label ? => skip it
2088               (if (looking-at ada-named-block-re)
2089                   (progn
2090                     (setq label (- ada-label-indent))
2091                     (goto-char (match-end 0))
2092                     (ada-goto-next-non-ws)))
2093               ;; really looking-at the right thing ?
2094               (or (looking-at (concat "\\<\\("
2095                                       "loop\\|select\\|if\\|case\\|"
2096                                       "record\\|while\\|type\\)\\>"))
2097                   (progn
2098                     (ada-search-ignore-string-comment
2099                      (concat "\\<\\("
2100                              "loop\\|select\\|if\\|case\\|"
2101                              "record\\|while\\|type\\)\\>")))
2102                   (backward-word 1))
2103               (+ (current-indentation) label)))
2104            ;;
2105            ;; a named block end
2106            ;;
2107            ((looking-at ada-ident-re)
2108             (setq defun-name (buffer-substring (match-beginning 0)
2109                                                (match-end 0)))
2110             (save-excursion
2111               (ada-goto-matching-start 0)
2112               (ada-check-defun-name defun-name)
2113               (current-indentation)))
2114            ;;
2115            ;; a block-end without name
2116            ;;
2117            ((looking-at ";")
2118             (save-excursion
2119               (ada-goto-matching-start 0)
2120               (if (looking-at "\\<begin\\>")
2121                   (progn
2122                     (setq indent (current-column))
2123                     (if (ada-goto-matching-decl-start t)
2124                         (current-indentation)
2125                       indent)))))
2126            ;;
2127            ;; anything else - should maybe signal an error ?
2128            ;;
2129            (t
2130             (+ (current-indentation) ada-broken-indent))))
2131
2132       (+ (current-indentation) ada-broken-indent))))
2133
2134
2135 (defun ada-get-indent-case (orgpoint)
2136   ;; Returns the indentation (column #) for the new line after ORGPOINT.
2137   ;; Assumes point to be at the beginning of a case-statement.
2138   (let ((cur-indent (current-indentation))
2139         (match-cons nil)
2140         (opos (point)))
2141     (cond
2142      ;;
2143      ;; case..is..when..=>
2144      ;;
2145      ((save-excursion
2146         (setq match-cons (and
2147                           ;; the `=>' must be after the keyword `is'.
2148                           (ada-search-ignore-string-comment
2149                            "\\<is\\>" nil orgpoint)
2150                           (ada-search-ignore-string-comment
2151                            "[ \t\n]+=>" nil orgpoint))))
2152       (save-excursion
2153         (goto-char (car match-cons))
2154         (if (not (ada-search-ignore-string-comment "\\<when\\>" t opos))
2155             (error "missing 'when' between 'case' and '=>'"))
2156         (+ (current-indentation) ada-indent)))
2157      ;;
2158      ;; case..is..when
2159      ;;
2160      ((save-excursion
2161        (setq match-cons (ada-search-ignore-string-comment
2162                          "\\<when\\>" nil orgpoint)))
2163       (goto-char (cdr match-cons))
2164       (+ (current-indentation) ada-broken-indent))
2165      ;;
2166      ;; case..is
2167      ;;
2168      ((save-excursion
2169        (setq match-cons (ada-search-ignore-string-comment
2170                          "\\<is\\>" nil orgpoint)))
2171       (+ (current-indentation) ada-when-indent))
2172      ;;
2173      ;; incomplete case
2174      ;;
2175      (t
2176       (+ (current-indentation) ada-broken-indent)))))
2177
2178
2179 (defun ada-get-indent-when (orgpoint)
2180   ;; Returns the indentation (column #) for the new line after ORGPOINT.
2181   ;; Assumes point to be at the beginning of an when-statement.
2182   (let ((cur-indent (current-indentation)))
2183     (if (ada-search-ignore-string-comment
2184          "[ \t\n]+=>" nil orgpoint)
2185         (+ cur-indent  ada-indent)
2186       (+ cur-indent ada-broken-indent))))
2187
2188
2189 (defun ada-get-indent-if (orgpoint)
2190   ;; Returns the indentation (column #) for the new line after ORGPOINT.
2191   ;; Assumes point to be at the beginning of an if-statement.
2192   (let ((cur-indent (current-indentation))
2193         (match-cons nil))
2194     ;;
2195     ;; if..then ?
2196     ;;
2197     (if (ada-search-but-not
2198          "\\<then\\>" "\\<and\\>[ \t\n]+\\<then\\>" nil orgpoint)
2199
2200         (progn
2201           ;;
2202           ;; 'then' first in separate line ?
2203           ;; => indent according to 'then'
2204           ;;
2205           (if (save-excursion
2206                 (back-to-indentation)
2207                 (looking-at "\\<then\\>"))
2208               (setq cur-indent (current-indentation)))
2209           (forward-word 1)
2210           ;;
2211           ;; something follows 'then' ?
2212           ;;
2213           (if (setq match-cons
2214                     (ada-search-ignore-string-comment
2215                      "[^ \t\n]" nil orgpoint))
2216               (progn
2217                 (goto-char (car match-cons))
2218                 (+ ada-indent
2219                    (- cur-indent (current-indentation))
2220                    (funcall (ada-indent-function t) orgpoint)))
2221
2222             (+ cur-indent ada-indent)))
2223
2224       (+ cur-indent ada-broken-indent))))
2225
2226
2227 (defun ada-get-indent-block-start (orgpoint)
2228   ;; Returns the indentation (column #) for the new line after
2229   ;; ORGPOINT.  Assumes point to be at the beginning of a block start
2230   ;; keyword.
2231   (let ((cur-indent (current-indentation))
2232         (pos nil))
2233     (cond
2234      ((save-excursion
2235         (forward-word 1)
2236         (setq pos (car (ada-search-ignore-string-comment
2237                         "[^ \t\n]" nil orgpoint))))
2238       (goto-char pos)
2239       (save-excursion
2240         (funcall (ada-indent-function t) orgpoint)))
2241      ;;
2242      ;; nothing follows the block-start
2243      ;;
2244      (t
2245       (+ (current-indentation) ada-indent)))))
2246
2247
2248 (defun ada-get-indent-subprog (orgpoint)
2249   ;; Returns the indentation (column #) for the new line after ORGPOINT.
2250   ;; Assumes point to be at the beginning of a subprog-/package-declaration.
2251   (let ((match-cons nil)
2252         (cur-indent (current-indentation))
2253         (foundis nil)
2254         (addind 0)
2255         (fstart (point)))
2256     ;;
2257     ;; is there an 'is' in front of point ?
2258     ;;
2259     (if (save-excursion
2260           (setq match-cons
2261                 (ada-search-ignore-string-comment
2262                  "\\<\\(is\\|do\\)\\>" nil orgpoint)))
2263         ;;
2264         ;; yes, then skip to its end
2265         ;;
2266         (progn
2267           (setq foundis t)
2268           (goto-char (cdr match-cons)))
2269       ;;
2270       ;; no, then goto next non-ws, if there is one in front of point
2271       ;;
2272       (progn
2273         (if (ada-search-ignore-string-comment "[^ \t\n]" nil orgpoint)
2274             (ada-goto-next-non-ws)
2275           (goto-char orgpoint))))
2276
2277     (cond
2278      ;;
2279      ;; nothing follows 'is'
2280      ;;
2281      ((and
2282        foundis
2283        (save-excursion
2284          (not (ada-search-ignore-string-comment
2285                "[^ \t\n]" nil orgpoint t))))
2286       (+ cur-indent ada-indent))
2287      ;;
2288      ;; is abstract/separate/new ...
2289      ;;
2290      ((and
2291        foundis
2292        (save-excursion
2293          (setq match-cons
2294                (ada-search-ignore-string-comment
2295                 "\\<\\(separate\\|new\\|abstract\\)\\>"
2296                 nil orgpoint))))
2297       (goto-char (car match-cons))
2298       (ada-search-ignore-string-comment ada-subprog-start-re t)
2299       (ada-get-indent-noindent orgpoint))
2300      ;;
2301      ;; something follows 'is'
2302      ;;
2303      ((and
2304        foundis
2305        (save-excursion
2306          (ada-search-ignore-string-comment "[^ \t\n]" nil orgpoint))
2307        (ada-goto-next-non-ws)
2308       (funcall (ada-indent-function t) orgpoint)))
2309      ;;
2310      ;; no 'is' but ';'
2311      ;;
2312      ((save-excursion
2313         (ada-search-ignore-string-comment ";" nil orgpoint))
2314       cur-indent)
2315      ;;
2316      ;; no 'is' or ';'
2317      ;;
2318      (t
2319       (+ cur-indent ada-broken-indent)))))
2320
2321
2322 (defun ada-get-indent-noindent (orgpoint)
2323   ;; Returns the indentation (column #) for the new line after ORGPOINT.
2324   ;; Assumes point to be at the beginning of a 'noindent statement'.
2325   (let ((label 0))
2326     (save-excursion
2327       (beginning-of-line)
2328       (if (looking-at ada-named-block-re)
2329           (setq label (- ada-label-indent))))
2330     (if (save-excursion
2331           (ada-search-ignore-string-comment ";" nil orgpoint))
2332         (+ (current-indentation) label)
2333       (+ (current-indentation) ada-broken-indent label))))
2334
2335
2336 (defun ada-get-indent-label (orgpoint)
2337   ;; Returns the indentation (column #) for the new line after ORGPOINT.
2338   ;; Assumes point to be at the beginning of a label or variable declaration.
2339   ;; Checks the context to decide if it's a label or a variable declaration.
2340   ;; This check might be a bit slow.
2341   (let ((match-cons nil)
2342         (cur-indent (current-indentation)))
2343     (goto-char (cdr (ada-search-ignore-string-comment ":")))
2344     (cond
2345      ;;
2346      ;; loop label
2347      ;;
2348      ((save-excursion
2349         (setq match-cons (ada-search-ignore-string-comment
2350                           ada-loop-start-re nil orgpoint)))
2351       (goto-char (car match-cons))
2352       (ada-get-indent-loop orgpoint))
2353      ;;
2354      ;; declare label
2355      ;;
2356      ((save-excursion
2357         (setq match-cons (ada-search-ignore-string-comment
2358                           "\\<declare\\|begin\\>" nil orgpoint)))
2359       (save-excursion
2360         (goto-char (car match-cons))
2361         (+ (current-indentation) ada-indent)))
2362      ;;
2363      ;; complete statement following colon
2364      ;;
2365      ((save-excursion
2366         (ada-search-ignore-string-comment ";" nil orgpoint))
2367       (if (ada-in-decl-p)
2368           cur-indent                      ; variable-declaration
2369         (- cur-indent ada-label-indent))) ; label
2370      ;;
2371      ;; broken statement
2372      ;;
2373      ((save-excursion
2374         (ada-search-ignore-string-comment "[^ \t\n]" nil orgpoint))
2375       (if (ada-in-decl-p)
2376           (+ cur-indent ada-broken-indent)
2377         (+ cur-indent ada-broken-indent (- ada-label-indent))))
2378      ;;
2379      ;; nothing follows colon
2380      ;;
2381      (t
2382       (if (ada-in-decl-p)
2383           (+ cur-indent ada-broken-indent)   ; variable-declaration
2384         (- cur-indent ada-label-indent)))))) ; label
2385
2386
2387 (defun ada-get-indent-loop (orgpoint)
2388   ;; Returns the indentation (column #) for the new line after ORGPOINT.
2389   ;; Assumes point to be at the beginning of a loop statement
2390   ;; or (unfortunately) also a for ... use statement.
2391   (let ((match-cons nil)
2392         (pos (point))
2393         (label (save-excursion
2394                  (beginning-of-line)
2395                  (if (looking-at ada-named-block-re)
2396                      (- ada-label-indent)
2397                    0))))
2398
2399     (cond
2400
2401      ;;
2402      ;; statement complete
2403      ;;
2404      ((save-excursion
2405         (ada-search-ignore-string-comment ";" nil orgpoint))
2406       (+ (current-indentation) label))
2407      ;;
2408      ;; simple loop
2409      ;;
2410      ((looking-at "loop\\>")
2411       (+ (ada-get-indent-block-start orgpoint) label))
2412
2413      ;;
2414      ;; 'for'- loop (or also a for ... use statement)
2415      ;;
2416      ((looking-at "for\\>")
2417       (cond
2418        ;;
2419        ;; for ... use
2420        ;;
2421        ((save-excursion
2422           (and
2423            (goto-char (match-end 0))
2424            (ada-search-ignore-string-comment "[^ /n/t]" nil orgpoint)
2425            (not (backward-char 1))
2426            (not (zerop (skip-chars-forward "_a-zA-Z0-9'")))
2427            (ada-search-ignore-string-comment "[^ /n/t]" nil orgpoint)
2428            (not (backward-char 1))
2429            (looking-at "\\<use\\>")
2430            ;;
2431            ;; check if there is a 'record' before point
2432            ;;
2433            (progn
2434              (setq match-cons (ada-search-ignore-string-comment
2435                                "\\<record\\>" nil orgpoint))
2436              t)))
2437         (if match-cons
2438             (goto-char (car match-cons)))
2439         (+ (current-indentation) ada-indent))
2440        ;;
2441        ;; for..loop
2442        ;;
2443        ((save-excursion
2444           (setq match-cons (ada-search-ignore-string-comment
2445                             "\\<loop\\>" nil orgpoint)))
2446         (goto-char (car match-cons))
2447         ;;
2448         ;; indent according to 'loop', if it's first in the line;
2449         ;; otherwise to 'for'
2450         ;;
2451         (if (not (save-excursion
2452                    (back-to-indentation)
2453                    (looking-at "\\<loop\\>")))
2454             (goto-char pos))
2455         (+ (current-indentation) ada-indent label))
2456        ;;
2457        ;; for-statement is broken
2458        ;;
2459        (t
2460         (+ (current-indentation) ada-broken-indent label))))
2461
2462      ;;
2463      ;; 'while'-loop
2464      ;;
2465      ((looking-at "while\\>")
2466       ;;
2467       ;; while..loop ?
2468       ;;
2469       (if (save-excursion
2470             (setq match-cons (ada-search-ignore-string-comment
2471                               "\\<loop\\>" nil orgpoint)))
2472
2473           (progn
2474             (goto-char (car match-cons))
2475             ;;
2476             ;; indent according to 'loop', if it's first in the line;
2477             ;; otherwise to 'while'.
2478             ;;
2479             (if (not (save-excursion
2480                        (back-to-indentation)
2481                        (looking-at "\\<loop\\>")))
2482                 (goto-char pos))
2483             (+ (current-indentation) ada-indent label))
2484
2485         (+ (current-indentation) ada-broken-indent label))))))
2486
2487
2488 (defun ada-get-indent-type (orgpoint)
2489   ;; Returns the indentation (column #) for the new line after ORGPOINT.
2490   ;; Assumes point to be at the beginning of a type statement.
2491   (let ((match-dat nil))
2492     (cond
2493      ;;
2494      ;; complete record declaration
2495      ;;
2496      ((save-excursion
2497         (and
2498          (setq match-dat (ada-search-ignore-string-comment "\\<end\\>"
2499                                                            nil
2500                                                            orgpoint))
2501          (ada-goto-next-non-ws)
2502          (looking-at "\\<record\\>")
2503          (forward-word 1)
2504          (ada-goto-next-non-ws)
2505          (looking-at ";")))
2506       (goto-char (car match-dat))
2507       (current-indentation))
2508      ;;
2509      ;; record type
2510      ;;
2511      ((save-excursion
2512         (setq match-dat (ada-search-ignore-string-comment "\\<record\\>"
2513                                                           nil
2514                                                           orgpoint)))
2515       (goto-char (car match-dat))
2516       (+ (current-indentation) ada-indent))
2517      ;;
2518      ;; complete type declaration
2519      ;;
2520      ((save-excursion
2521         (ada-search-ignore-string-comment ";" nil orgpoint))
2522       (current-indentation))
2523      ;;
2524      ;; "type ... is", but not "type ... is ...", which is broken
2525      ;;
2526      ((save-excursion
2527         (and
2528          (ada-search-ignore-string-comment "\\<is\\>" nil orgpoint)
2529          (not (ada-search-ignore-string-comment "[^ \t\n]" nil orgpoint))))
2530       (+ (current-indentation) ada-indent))
2531      ;;
2532      ;; broken statement
2533      ;;
2534      (t
2535       (+ (current-indentation) ada-broken-indent)))))
2536
2537 \f
2538 ;;; ---- support-functions for indentation
2539
2540 ;;; ---- searching and matching
2541
2542 (defun ada-goto-stmt-start (&optional limit)
2543   ;; Moves point to the beginning of the statement that point is in or
2544   ;; after.  Returns the new position of point.  Beginnings are found
2545   ;; by searching for 'ada-end-stmt-re' and then moving to the
2546   ;; following non-ws that is not a comment.  LIMIT is actually not
2547   ;; used by the indentation functions.
2548   (let ((match-dat nil)
2549         (orgpoint (point)))
2550
2551     (setq match-dat (ada-search-prev-end-stmt limit))
2552     (if match-dat
2553         ;;
2554         ;; found a previous end-statement => check if anything follows
2555         ;;
2556         (progn
2557           (if (not
2558                (save-excursion
2559                  (goto-char (cdr match-dat))
2560                  (ada-search-ignore-string-comment
2561                   "[^ \t\n]" nil orgpoint)))
2562               ;;
2563               ;; nothing follows => it's the end-statement directly in
2564               ;;                    front of point => search again
2565               ;;
2566               (setq match-dat (ada-search-prev-end-stmt limit)))
2567           ;;
2568           ;; if found the correct end-statement => goto next non-ws
2569           ;;
2570           (if match-dat
2571               (goto-char (cdr match-dat)))
2572           (ada-goto-next-non-ws))
2573
2574       ;;
2575       ;; no previous end-statement => we are at the beginning of the
2576       ;;                              accessible part of the buffer
2577       ;;
2578       (progn
2579         (goto-char (point-min))
2580         ;;
2581         ;; skip to the very first statement, if there is one
2582         ;;
2583         (if (setq match-dat
2584                   (ada-search-ignore-string-comment
2585                    "[^ \t\n]" nil orgpoint))
2586             (goto-char (car match-dat))
2587           (goto-char orgpoint))))
2588
2589
2590     (point)))
2591
2592
2593 (defun ada-search-prev-end-stmt (&optional limit)
2594   ;; Moves point to previous end-statement.  Returns a cons cell whose
2595   ;; car is the beginning and whose cdr the end of the match.
2596   ;; End-statements are defined by 'ada-end-stmt-re'.  Checks for
2597   ;; certain keywords if they follow 'end', which means they are no
2598   ;; end-statement there.
2599   (let ((match-dat nil)
2600         (pos nil)
2601         (found nil))
2602     ;;
2603     ;; search until found or beginning-of-buffer
2604     ;;
2605     (while
2606         (and
2607          (not found)
2608          (setq match-dat (ada-search-ignore-string-comment ada-end-stmt-re
2609                                                            t
2610                                                            limit)))
2611
2612       (goto-char (car match-dat))
2613       (if (not (ada-in-open-paren-p))
2614           ;;
2615           ;; check if there is an 'end' in front of the match
2616           ;;
2617           (if (not (and
2618                     (looking-at
2619                      "\\<\\(record\\|loop\\|select\\|else\\|then\\)\\>")
2620                     (save-excursion
2621                       (ada-goto-previous-word)
2622                       (looking-at "\\<\\(end\\|or\\|and\\)\\>"))))
2623               (save-excursion
2624                 (goto-char (cdr match-dat))
2625                 (ada-goto-next-word)
2626                 (if (not (looking-at "\\<\\(separate\\|new\\)\\>"))
2627                     (setq found t)))
2628
2629             (forward-word -1)))) ; end of loop
2630
2631     (if found
2632         match-dat
2633       nil)))
2634
2635
2636 (defun ada-goto-next-non-ws (&optional limit)
2637   ;; Skips whitespaces, newlines and comments to next non-ws
2638   ;; character.  Signals an error if there is no more such character
2639   ;; and limit is nil.
2640   (let ((match-cons nil))
2641     (setq match-cons (ada-search-ignore-string-comment
2642                       "[^ \t\n]" nil limit t))
2643     (if match-cons
2644         (goto-char (car match-cons))
2645       (if (not limit)
2646           (error "no more non-ws")
2647         nil))))
2648
2649
2650 (defun ada-goto-stmt-end (&optional limit)
2651   ;; Moves point to the end of the statement that point is in or
2652   ;; before.  Returns the new position of point or nil if not found.
2653   (if (ada-search-ignore-string-comment ada-end-stmt-re nil limit)
2654       (point)
2655     nil))
2656
2657
2658 (defun ada-goto-next-word (&optional backward)
2659   ;; Moves point to the beginning of the next word of Ada code.
2660   ;; If BACKWARD is non-nil, jump to the beginning of the previous word.
2661   ;; Returns the new position of point or nil if not found.
2662   (let ((match-cons nil)
2663         (orgpoint (point)))
2664     (if (not backward)
2665         (skip-chars-forward "_a-zA-Z0-9\\."))
2666     (if (setq match-cons
2667               (ada-search-ignore-string-comment "\\w" backward nil t))
2668         ;;
2669         ;; move to the beginning of the word found
2670         ;;
2671         (progn
2672           (goto-char (car match-cons))
2673           (skip-chars-backward "_a-zA-Z0-9")
2674           (point))
2675       ;;
2676       ;; if not found, restore old position of point
2677       ;;
2678       (progn
2679         (goto-char orgpoint)
2680         'nil))))
2681
2682
2683 (defun ada-goto-previous-word ()
2684   ;; Moves point to the beginning of the previous word of Ada code.
2685   ;; Returns the new position of point or nil if not found.
2686   (ada-goto-next-word t))
2687
2688
2689 (defun ada-check-matching-start (keyword)
2690   ;; Signals an error if matching block start is not KEYWORD.
2691   ;; Moves point to the matching block start.
2692   (ada-goto-matching-start 0)
2693   (if (not (looking-at (concat "\\<" keyword "\\>")))
2694       (error "matching start is not '%s'" keyword)))
2695
2696
2697 (defun ada-check-defun-name (defun-name)
2698   ;; Checks if the name of the matching defun really is DEFUN-NAME.
2699   ;; Assumes point to be already positioned by 'ada-goto-matching-start'.
2700   ;; Moves point to the beginning of the declaration.
2701
2702   ;;
2703   ;; named block without a `declare'
2704   ;;
2705   (if (save-excursion
2706         (ada-goto-previous-word)
2707         (looking-at (concat "\\<" defun-name "\\> *:")))
2708       t ; do nothing
2709     ;;
2710     ;; 'accept' or 'package' ?
2711     ;;
2712     (if (not (looking-at "\\<\\(accept\\|package\\|task\\|protected\\)\\>"))
2713         (ada-goto-matching-decl-start))
2714     ;;
2715     ;; 'begin' of 'procedure'/'function'/'task' or 'declare'
2716     ;;
2717     (save-excursion
2718       ;;
2719       ;; a named 'declare'-block ?
2720       ;;
2721       (if (looking-at "\\<declare\\>")
2722           (ada-goto-stmt-start)
2723         ;;
2724         ;; no, => 'procedure'/'function'/'task'/'protected'
2725         ;;
2726         (progn
2727           (forward-word 2)
2728           (backward-word 1)
2729           ;;
2730           ;; skip 'body' 'type'
2731           ;;
2732           (if (looking-at "\\<\\(body\\|type\\)\\>")
2733               (forward-word 1))
2734           (forward-sexp 1)
2735           (backward-sexp 1)))
2736       ;;
2737       ;; should be looking-at the correct name
2738       ;;
2739       (if (not (looking-at (concat "\\<" defun-name "\\>")))
2740           (error "matching defun has different name: %s"
2741                  (buffer-substring (point)
2742                                    (progn (forward-sexp 1) (point))))))))
2743
2744
2745 (defun ada-goto-matching-decl-start (&optional noerror nogeneric)
2746   ;; Moves point to the matching declaration start of the current 'begin'.
2747   ;; If NOERROR is non-nil, it only returns nil if no match was found.
2748   (let ((nest-count 1)
2749         (pos nil)
2750         (first t)
2751         (flag nil))
2752     ;;
2753     ;; search backward for interesting keywords
2754     ;;
2755     (while (and
2756             (not (zerop nest-count))
2757             (ada-search-ignore-string-comment
2758              (concat "\\<\\("
2759                      "is\\|separate\\|end\\|declare\\|new\\|begin\\|generic"
2760                      "\\)\\>") t))
2761       ;;
2762       ;; calculate nest-depth
2763       ;;
2764       (cond
2765        ;;
2766        ((looking-at "end")
2767         (ada-goto-matching-start 1 noerror)
2768         (if (looking-at "begin")
2769             (setq nest-count (1+ nest-count))))
2770        ;;
2771        ((looking-at "declare\\|generic")
2772         (setq nest-count (1- nest-count))
2773         (setq first nil))
2774        ;;
2775        ((looking-at "is")
2776         ;; check if it is only a type definition, but not a protected
2777         ;; type definition, which should be handled like a procedure.
2778         (if (or (looking-at "is +<>")
2779                 (save-excursion
2780                   (ada-goto-previous-word)
2781                   (skip-chars-backward "a-zA-Z0-9_.'")
2782                   (if (save-excursion
2783                         (backward-char 1)
2784                         (looking-at ")"))
2785                       (progn
2786                         (forward-char 1)
2787                         (backward-sexp 1)
2788                         (skip-chars-backward "a-zA-Z0-9_.'")
2789                         ))
2790                   (ada-goto-previous-word)
2791                   (and
2792                    (looking-at "\\<type\\>")
2793                    (save-match-data
2794                      (ada-goto-previous-word)
2795                      (not (looking-at "\\<protected\\>"))))
2796                   )); end of `or'
2797             (goto-char (match-beginning 0))
2798           (progn
2799             (setq nest-count (1- nest-count))
2800             (setq first nil))))
2801
2802        ;;
2803        ((looking-at "new")
2804         (if (save-excursion
2805               (ada-goto-previous-word)
2806               (looking-at "is"))
2807             (goto-char (match-beginning 0))))
2808        ;;
2809        ((and first
2810              (looking-at "begin"))
2811         (setq nest-count 0)
2812         (setq flag t))
2813        ;;
2814        (t
2815         (setq nest-count (1+ nest-count))
2816         (setq first nil)))
2817
2818       )  ;; end of loop
2819
2820     ;; check if declaration-start is really found
2821     (if (not
2822          (and
2823           (zerop nest-count)
2824           (not flag)
2825           (if (looking-at "is")
2826               (ada-search-ignore-string-comment ada-subprog-start-re t)
2827             (looking-at "declare\\|generic"))))
2828         (if noerror nil
2829           (error "no matching proc/func/task/declare/package/protected"))
2830       t)))
2831
2832
2833 (defun ada-goto-matching-start (&optional nest-level noerror gotothen)
2834   ;; Moves point to the beginning of a block-start.  Which block
2835   ;; depends on the value of NEST-LEVEL, which defaults to zero.  If
2836   ;; NOERROR is non-nil, it only returns nil if no matching start was
2837   ;; found.  If GOTOTHEN is non-nil, point moves to the 'then'
2838   ;; following 'if'.
2839   (let ((nest-count (if nest-level nest-level 0))
2840         (found nil)
2841         (pos nil))
2842
2843     ;;
2844     ;; search backward for interesting keywords
2845     ;;
2846     (while (and
2847             (not found)
2848             (ada-search-ignore-string-comment
2849              (concat "\\<\\("
2850                      "end\\|loop\\|select\\|begin\\|case\\|do\\|"
2851                      "if\\|task\\|package\\|record\\|protected\\)\\>")
2852              t))
2853
2854       ;;
2855       ;; calculate nest-depth
2856       ;;
2857       (cond
2858        ;; found block end => increase nest depth
2859        ((looking-at "end")
2860         (setq nest-count (1+ nest-count)))
2861        ;; found loop/select/record/case/if => check if it starts or
2862        ;; ends a block
2863        ((looking-at "loop\\|select\\|record\\|case\\|if")
2864         (setq pos (point))
2865         (save-excursion
2866           ;;
2867           ;; check if keyword follows 'end'
2868           ;;
2869           (ada-goto-previous-word)
2870           (if (looking-at "\\<end\\> *[^;]")
2871               ;; it ends a block => increase nest depth
2872               (progn
2873                 (setq nest-count (1+ nest-count))
2874                 (setq pos (point)))
2875             ;; it starts a block => decrease nest depth
2876             (setq nest-count (1- nest-count))))
2877         (goto-char pos))
2878        ;; found package start => check if it really is a block
2879        ((looking-at "package")
2880         (save-excursion
2881           (ada-search-ignore-string-comment "\\<is\\>")
2882           (ada-goto-next-non-ws)
2883           ;; ignore it if it is only a declaration with 'new'
2884           (if (not (looking-at "\\<new\\>"))
2885               (setq nest-count (1- nest-count)))))
2886        ;; found task start => check if it has a body
2887        ((looking-at "task")
2888         (save-excursion
2889           (forward-word 1)
2890           (ada-goto-next-non-ws)
2891           ;; ignore it if it has no body
2892           (if (not (looking-at "\\<body\\>"))
2893               (setq nest-count (1- nest-count)))))
2894        ;; all the other block starts
2895        (t
2896         (setq nest-count (1- nest-count)))) ; end of 'cond'
2897
2898       ;; match is found, if nest-depth is zero
2899       ;;
2900       (setq found (zerop nest-count))) ; end of loop
2901
2902     (if found
2903         ;;
2904         ;; match found => is there anything else to do ?
2905         ;;
2906         (progn
2907           (cond
2908            ;;
2909            ;; found 'if' => skip to 'then', if it's on a separate line
2910            ;;                               and GOTOTHEN is non-nil
2911            ;;
2912            ((and
2913              gotothen
2914              (looking-at "if")
2915              (save-excursion
2916                (ada-search-ignore-string-comment "\\<then\\>" nil nil)
2917                (back-to-indentation)
2918                (looking-at "\\<then\\>")))
2919             (goto-char (match-beginning 0)))
2920            ;;
2921            ;; found 'do' => skip back to 'accept'
2922            ;;
2923            ((looking-at "do")
2924             (if (not (ada-search-ignore-string-comment "\\<accept\\>" t nil))
2925                 (error "missing 'accept' in front of 'do'"))))
2926           (point))
2927
2928       (if noerror
2929           nil
2930         (error "no matching start")))))
2931
2932
2933 (defun ada-goto-matching-end (&optional nest-level noerror)
2934   ;; Moves point to the end of a block.  Which block depends on the
2935   ;; value of NEST-LEVEL, which defaults to zero.  If NOERROR is
2936   ;; non-nil, it only returns nil if found no matching start.
2937   (let ((nest-count (if nest-level nest-level 0))
2938         (found nil))
2939
2940     ;;
2941     ;; search forward for interesting keywords
2942     ;;
2943     (while (and
2944             (not found)
2945             (ada-search-ignore-string-comment
2946              (concat "\\<\\(end\\|loop\\|select\\|begin\\|case\\|"
2947                      "if\\|task\\|package\\|record\\|do\\)\\>")))
2948
2949       ;;
2950       ;; calculate nest-depth
2951       ;;
2952       (backward-word 1)
2953       (cond
2954        ;; found block end => decrease nest depth
2955        ((looking-at "\\<end\\>")
2956         (setq nest-count (1- nest-count))
2957         ;; skip the following keyword
2958         (if (progn
2959               (skip-chars-forward "end")
2960               (ada-goto-next-non-ws)
2961               (looking-at "\\<\\(loop\\|select\\|record\\|case\\|if\\)\\>"))
2962             (forward-word 1)))
2963        ;; found package start => check if it really starts a block
2964        ((looking-at "\\<package\\>")
2965         (ada-search-ignore-string-comment "\\<is\\>")
2966         (ada-goto-next-non-ws)
2967         ;; ignore and skip it if it is only a 'new' package
2968         (if (not (looking-at "\\<new\\>"))
2969             (setq nest-count (1+ nest-count))
2970           (skip-chars-forward "new")))
2971        ;; all the other block starts
2972        (t
2973         (setq nest-count (1+ nest-count))
2974         (forward-word 1))) ; end of 'cond'
2975
2976       ;; match is found, if nest-depth is zero
2977       ;;
2978       (setq found (zerop nest-count))) ; end of loop
2979
2980     (if (not found)
2981         (if noerror
2982             nil
2983           (error "no matching end"))
2984       t)))
2985
2986
2987 (defun ada-forward-sexp-ignore-comment ()
2988   ;; Skips one sexp forward, ignoring comments.
2989   (while (looking-at "[ \t\n]*--")
2990     (skip-chars-forward "[ \t\n]")
2991     (end-of-line))
2992   (forward-sexp 1))
2993
2994
2995 (defun ada-search-ignore-string-comment
2996   (search-re &optional backward limit paramlists)
2997   ;; Regexp-Search for SEARCH-RE, ignoring comments, strings and
2998   ;; parameter lists, if PARAMLISTS is nil. Returns a cons cell of
2999   ;; begin and end of match data or nil, if not found.
3000   (let ((found nil)
3001         (begin nil)
3002         (end nil)
3003         (pos nil)
3004         (search-func
3005          (if backward 're-search-backward
3006            're-search-forward)))
3007
3008     ;;
3009     ;; search until found or end-of-buffer
3010     ;;
3011     (while (and (not found)
3012                 (funcall search-func search-re limit 1))
3013       (setq begin (match-beginning 0))
3014       (setq end (match-end 0))
3015
3016       (cond
3017        ;;
3018        ;; found in comment => skip it
3019        ;;
3020        ((ada-in-comment-p)
3021         (if backward
3022             (progn
3023               (re-search-backward "--" nil 1)
3024               (goto-char (match-beginning 0)))
3025           (progn
3026             (forward-line 1)
3027             (beginning-of-line))))
3028        ;;
3029        ;; found in string => skip it
3030        ;;
3031        ((ada-in-string-p)
3032         (if backward
3033             (progn
3034               (re-search-backward "\"" nil 1) ; "\"\\|#" don't treat #
3035               (goto-char (match-beginning 0))))
3036         (re-search-forward "\"" nil 1))
3037        ;;
3038        ;; found character constant => ignore it
3039        ;;
3040        ((save-excursion
3041           (setq pos (- (point) (if backward 1 2)))
3042           (and (char-after pos)
3043                (= (char-after pos) ?')
3044                (= (char-after (+ pos 2)) ?')))
3045         ())
3046        ;;
3047        ;; found a parameter-list but should ignore it => skip it
3048        ;;
3049        ((and (not paramlists)
3050              (ada-in-paramlist-p))
3051         (if backward
3052             (ada-search-ignore-string-comment "(" t nil t)))
3053        ;;
3054        ;; directly in front of a comment => skip it, if searching forward
3055        ;;
3056        ((save-excursion
3057           (goto-char begin)
3058           (looking-at "--"))
3059         (if (not backward)
3060             (progn
3061               (forward-line 1)
3062               (beginning-of-line))))
3063        ;;
3064        ;; found what we were looking for
3065        ;;
3066        (t
3067         (setq found t)))) ; end of loop
3068
3069     (if found
3070         (cons begin end)
3071       nil)))
3072
3073
3074 (defun ada-search-but-not (search-re not-search-re &optional backward limit)
3075   ;; Searches SEARCH-RE, ignoring parts of NOT-SEARCH-RE, strings,
3076   ;; comments and parameter-lists.
3077   (let ((begin nil)
3078         (end nil)
3079         (begin-not nil)
3080         (begin-end nil)
3081         (end-not nil)
3082         (ret-cons nil)
3083         (found nil))
3084
3085     ;;
3086     ;; search until found or end-of-buffer
3087     ;;
3088     (while (and
3089             (not found)
3090             (save-excursion
3091               (setq ret-cons
3092                     (ada-search-ignore-string-comment search-re
3093                                                       backward limit))
3094               (if (consp ret-cons)
3095                   (progn
3096                     (setq begin (car ret-cons))
3097                     (setq end (cdr ret-cons))
3098                     t)
3099                 nil)))
3100
3101       (if (or
3102            ;;
3103            ;; if no NO-SEARCH-RE was found
3104            ;;
3105            (not
3106             (save-excursion
3107               (setq ret-cons
3108                     (ada-search-ignore-string-comment not-search-re
3109                                                       backward nil))
3110               (if (consp ret-cons)
3111                   (progn
3112                     (setq begin-not (car ret-cons))
3113                     (setq end-not (cdr ret-cons))
3114                     t)
3115                 nil)))
3116            ;;
3117            ;;  or this NO-SEARCH-RE is not a part of the SEARCH-RE
3118            ;;  found before.
3119            ;;
3120            (or
3121             (<= end-not begin)
3122             (>= begin-not end)))
3123
3124           (setq found t)
3125
3126         ;;
3127         ;; not found the correct match => skip this match
3128         ;;
3129         (goto-char (if backward
3130                        begin
3131                      end)))) ; end of loop
3132
3133     (if found
3134         (progn
3135           (goto-char begin)
3136           (cons begin end))
3137       nil)))
3138
3139
3140 (defun ada-goto-prev-nonblank-line ( &optional ignore-comment)
3141   ;; Moves point to the beginning of previous non-blank line,
3142   ;; ignoring comments if IGNORE-COMMENT is non-nil.
3143   ;; It returns t if a matching line was found.
3144   (let ((notfound t)
3145         (newpoint nil))
3146
3147     (save-excursion
3148       ;;
3149       ;; backward one line, if there is one
3150       ;;
3151       (if (zerop (forward-line -1))
3152           ;;
3153           ;; there is some kind of previous line
3154           ;;
3155           (progn
3156             (beginning-of-line)
3157             (setq newpoint (point))
3158
3159             ;;
3160             ;; search until found or beginning-of-buffer
3161             ;;
3162             (while (and (setq notfound
3163                               (or (looking-at "[ \t]*$")
3164                                   (and (looking-at "[ \t]*--")
3165                                        ignore-comment)))
3166                         (not (ada-in-limit-line-p)))
3167               (forward-line -1)
3168               ;;(beginning-of-line)
3169               (setq newpoint (point))) ; end of loop
3170
3171             )) ; end of if
3172
3173       ) ; end of save-excursion
3174
3175     (if notfound nil
3176       (progn
3177         (goto-char newpoint)
3178         t))))
3179
3180
3181 (defun ada-goto-next-nonblank-line ( &optional ignore-comment)
3182   ;; Moves point to next non-blank line,
3183   ;; ignoring comments if IGNORE-COMMENT is non-nil.
3184   ;; It returns t if a matching line was found.
3185   (let ((notfound t)
3186         (newpoint nil))
3187
3188     (save-excursion
3189     ;;
3190     ;; forward one line
3191     ;;
3192       (if (zerop (forward-line 1))
3193           ;;
3194           ;; there is some kind of previous line
3195           ;;
3196           (progn
3197             (beginning-of-line)
3198             (setq newpoint (point))
3199
3200             ;;
3201             ;; search until found or end-of-buffer
3202             ;;
3203             (while (and (setq notfound
3204                               (or (looking-at "[ \t]*$")
3205                                   (and (looking-at "[ \t]*--")
3206                                        ignore-comment)))
3207                         (not (ada-in-limit-line-p)))
3208               (forward-line 1)
3209               (beginning-of-line)
3210               (setq newpoint (point))) ; end of loop
3211
3212             )) ; end of if
3213
3214       ) ; end of save-excursion
3215
3216     (if notfound nil
3217       (progn
3218         (goto-char newpoint)
3219         t))))
3220
3221
3222 ;; ---- boolean functions for indentation
3223
3224 (defun ada-in-decl-p ()
3225   ;; Returns t if point is inside a declarative part.
3226   ;; Assumes point to be at the end of a statement.
3227   (or
3228    (ada-in-paramlist-p)
3229    (save-excursion
3230      (ada-goto-matching-decl-start t))))
3231
3232
3233 (defun ada-looking-at-semi-or ()
3234   ;; Returns t if looking-at an 'or' following a semicolon.
3235   (save-excursion
3236     (and (looking-at "\\<or\\>")
3237          (progn
3238            (forward-word 1)
3239            (ada-goto-stmt-start)
3240            (looking-at "\\<or\\>")))))
3241
3242
3243 (defun ada-looking-at-semi-private ()
3244   ;; Returns t if looking-at an 'private' following a semicolon.
3245   (save-excursion
3246     (and (looking-at "\\<private\\>")
3247          (progn
3248            (forward-word 1)
3249            (ada-goto-stmt-start)
3250            (looking-at "\\<private\\>")))))
3251
3252
3253 ;;; make a faster??? ada-in-limit-line-p not using count-lines
3254 (defun ada-in-limit-line-p ()
3255   ;; return t if point is in first or last accessible line.
3256   (or (save-excursion (beginning-of-line) (= (point-min) (point)))
3257       (save-excursion (end-of-line) (= (point-max) (point)))))
3258
3259
3260 (defun ada-in-comment-p ()
3261   ;; Returns t if inside a comment.
3262   (nth 4 (parse-partial-sexp
3263           (save-excursion (beginning-of-line) (point))
3264           (point))))
3265
3266
3267 (defun ada-in-string-p ()
3268   ;; Returns t if point is inside a string
3269   ;; (Taken from pascal-mode.el, modified by MH).
3270   (save-excursion
3271     (and
3272      (nth 3 (parse-partial-sexp
3273              (save-excursion
3274                (beginning-of-line)
3275                (point)) (point)))
3276      ;; check if 'string quote' is only a character constant
3277      (progn
3278        (re-search-backward "\"" nil t) ; `#' is not taken as a string delimiter
3279        (not (= (char-after (1- (point))) ?'))))))
3280
3281
3282 (defun ada-in-string-or-comment-p ()
3283   ;; Returns t if point is inside a string, a comment, or a character constant.
3284   (let ((parse-result (parse-partial-sexp
3285                        (save-excursion (beginning-of-line) (point)) (point))))
3286     (or ;; in-comment-p
3287      (nth 4 parse-result)
3288      ;; in-string-p
3289      (and
3290       (nth 3 parse-result)
3291       ;; check if 'string quote' is only a character constant
3292       (progn
3293         (re-search-backward "\"" nil t) ; `#' not regarded a string delimiter
3294         (not (= (char-after (1- (point))) ?'))))
3295      ;; in-char-const-p
3296      (ada-in-char-const-p))))
3297
3298
3299 (defun ada-in-paramlist-p ()
3300   ;; Returns t if point is inside a parameter-list
3301   ;; following 'function'/'procedure'/'package'.
3302   (save-excursion
3303     (and
3304      (re-search-backward "(\\|)" nil t)
3305      ;; inside parentheses ?
3306      (looking-at "(")
3307      (backward-word 2)
3308      ;; right keyword before parenthesis ?
3309      (looking-at (concat "\\<\\("
3310                          "procedure\\|function\\|body\\|package\\|"
3311                          "task\\|entry\\|accept\\)\\>"))
3312      (re-search-forward ")\\|:" nil t)
3313      ;; at least one ':' inside the parentheses ?
3314      (not (backward-char 1))
3315      (looking-at ":"))))
3316
3317
3318 ;; not really a boolean function ...
3319 (defun ada-in-open-paren-p ()
3320   ;; If point is somewhere behind an open parenthesis not yet closed,
3321   ;; it returns the column # of the first non-ws behind this open
3322   ;; parenthesis, otherwise nil."
3323   (let ((start (if (<= (point) ada-search-paren-char-count-limit)
3324                    (point-min)
3325                  (save-excursion
3326                    (goto-char (- (point) ada-search-paren-char-count-limit))
3327                    (beginning-of-line)
3328                    (point))))
3329         parse-result
3330         (col nil))
3331     (setq parse-result (parse-partial-sexp start (point)))
3332     (if (nth 1 parse-result)
3333         (save-excursion
3334           (goto-char (1+ (nth 1 parse-result)))
3335           (if (save-excursion
3336                 (re-search-forward "[^ \t]" nil 1)
3337                 (backward-char 1)
3338                 (and
3339                  (not (looking-at "\n"))
3340                  (setq col (current-column))))
3341               col
3342             (current-column)))
3343       nil)))
3344
3345
3346 \f
3347 ;;;----------------------;;;
3348 ;;; Behaviour Of TAB Key ;;;
3349 ;;;----------------------;;;
3350
3351 (defun ada-tab ()
3352   "Do indenting or tabbing according to `ada-tab-policy'."
3353   (interactive)
3354   (cond ((eq ada-tab-policy 'indent-and-tab) (error "not implemented"))
3355         ;; ada-indent-and-tab
3356         ((eq ada-tab-policy 'indent-rigidly) (ada-tab-hard))
3357         ((eq ada-tab-policy 'indent-auto) (ada-indent-current))
3358         ((eq ada-tab-policy 'gei) (ada-tab-gei))
3359         ((eq ada-tab-policy 'indent-af) (af-indent-line)) ; GEB
3360         ((eq ada-tab-policy 'always-tab) (error "not implemented"))
3361         ))
3362
3363
3364 (defun ada-untab (arg)
3365   "Delete leading indenting according to `ada-tab-policy'."
3366   (interactive "P")
3367   (cond ((eq ada-tab-policy 'indent-rigidly) (ada-untab-hard))
3368         ((eq ada-tab-policy 'indent-af) (backward-delete-char-untabify ; GEB
3369                                          (prefix-numeric-value arg) ; GEB
3370                                          arg)) ; GEB
3371         ((eq ada-tab-policy 'indent-auto) (error "not implemented"))
3372         ((eq ada-tab-policy 'always-tab) (error "not implemented"))
3373         ))
3374
3375
3376 (defun ada-indent-current-function ()
3377   "Ada mode version of the indent-line-function."
3378   (interactive "*")
3379   (let ((starting-point (point-marker)))
3380     (ada-beginning-of-line)
3381     (ada-tab)
3382     (if (< (point) starting-point)
3383         (goto-char starting-point))
3384     (set-marker starting-point nil)
3385     ))
3386
3387
3388 (defun ada-tab-hard ()
3389   "Indent current line to next tab stop."
3390   (interactive)
3391   (save-excursion
3392     (beginning-of-line)
3393     (insert-char ?  ada-indent))
3394   (if (save-excursion (= (point) (progn (beginning-of-line) (point))))
3395       (forward-char ada-indent)))
3396
3397
3398 (defun ada-untab-hard ()
3399   "indent current line to previous tab stop."
3400   (interactive)
3401   (let  ((bol (save-excursion (progn (beginning-of-line) (point))))
3402         (eol (save-excursion (progn (end-of-line) (point)))))
3403     (indent-rigidly bol eol  (- 0 ada-indent))))
3404
3405
3406 \f
3407 ;;;---------------;;;
3408 ;;; Miscellaneous ;;;
3409 ;;;---------------;;;
3410
3411 (defun ada-remove-trailing-spaces  ()
3412  "remove trailing spaces in the whole buffer."
3413   (interactive)
3414   (save-match-data
3415     (save-excursion
3416       (save-restriction
3417         (widen)
3418         (goto-char (point-min))
3419         (while (re-search-forward "[ \t]+$" (point-max) t)
3420           (replace-match "" nil nil))))))
3421
3422
3423 (defun ada-untabify-buffer ()
3424 ;; change all tabs to spaces
3425   (save-excursion
3426     (untabify (point-min) (point-max))
3427     nil))
3428
3429
3430 (defun ada-uncomment-region (beg end)
3431   "delete `comment-start' at the beginning of a line in the region."
3432   (interactive "r")
3433   (comment-region beg end -1))
3434
3435
3436 ;; define a function to support find-file.el if loaded
3437 (defun ada-ff-other-window ()
3438   "Find other file in other window using `ff-find-other-file'."
3439   (interactive)
3440   (and (fboundp 'ff-find-other-file)
3441        (ff-find-other-file t)))
3442
3443 ;; inspired by Laurent.GUERBY@enst-bretagne.fr
3444 (defun ada-gnat-style ()
3445   "Clean up comments, `(' and `,' for GNAT style checking switch."
3446   (interactive)
3447   (save-excursion
3448     (goto-char (point-min))
3449     (while (re-search-forward "-- ?\\([^ -]\\)" nil t)
3450       (replace-match "--  \\1"))
3451     (goto-char (point-min))
3452     (while (re-search-forward "\\>(" nil t)
3453       (replace-match " ("))
3454     (goto-char (point-min))
3455     (while (re-search-forward ",\\<" nil t)
3456       (replace-match ", "))
3457     ))
3458
3459
3460 \f
3461 ;;;-------------------------------;;;
3462 ;;; Moving To Procedures/Packages ;;;
3463 ;;;-------------------------------;;;
3464
3465 (defun ada-next-procedure ()
3466   "Moves point to next procedure."
3467   (interactive)
3468   (end-of-line)
3469   (if (re-search-forward ada-procedure-start-regexp nil t)
3470       (goto-char (match-beginning 1))
3471     (error "No more functions/procedures/tasks")))
3472
3473 (defun ada-previous-procedure ()
3474   "Moves point to previous procedure."
3475   (interactive)
3476   (beginning-of-line)
3477   (if (re-search-backward ada-procedure-start-regexp nil t)
3478       (goto-char (match-beginning 1))
3479     (error "No more functions/procedures/tasks")))
3480
3481 (defun ada-next-package ()
3482   "Moves point to next package."
3483   (interactive)
3484   (end-of-line)
3485   (if (re-search-forward ada-package-start-regexp nil t)
3486       (goto-char (match-beginning 1))
3487     (error "No more packages")))
3488
3489 (defun ada-previous-package ()
3490   "Moves point to previous package."
3491   (interactive)
3492   (beginning-of-line)
3493   (if (re-search-backward ada-package-start-regexp nil t)
3494       (goto-char (match-beginning 1))
3495     (error "No more packages")))
3496
3497 \f
3498 ;;;-----------------------
3499 ;;; define keymap for Ada
3500 ;;;-----------------------
3501
3502 (if (not ada-mode-map)
3503     (progn
3504       (setq ada-mode-map (make-sparse-keymap))
3505
3506       ;; Indentation and Formatting
3507       (define-key ada-mode-map "\C-j"     'ada-indent-newline-indent)
3508       (define-key ada-mode-map "\t"       'ada-tab)
3509       (define-key ada-mode-map "\C-c\C-l" 'ada-indent-region)
3510       (if (ada-xemacs)
3511           (define-key ada-mode-map '(shift tab)    'ada-untab)
3512         (define-key ada-mode-map [S-tab]    'ada-untab))
3513       (define-key ada-mode-map "\C-c\C-f" 'ada-format-paramlist)
3514       (define-key ada-mode-map "\C-c\C-p" 'ada-call-pretty-printer)
3515 ;;; We don't want to make meta-characters case-specific.
3516 ;;;   (define-key ada-mode-map "\M-Q"     'ada-fill-comment-paragraph-justify)
3517       (define-key ada-mode-map "\M-\C-q"  'ada-fill-comment-paragraph-postfix)
3518
3519       ;; Movement
3520 ;;; It isn't good to redefine these.  What should be done instead?  -- rms.
3521 ;;;   (define-key ada-mode-map "\M-e"     'ada-next-package)
3522 ;;;   (define-key ada-mode-map "\M-a"     'ada-previous-package)
3523       (define-key ada-mode-map "\M-\C-e"  'ada-next-procedure)
3524       (define-key ada-mode-map "\M-\C-a"  'ada-previous-procedure)
3525       (define-key ada-mode-map "\C-c\C-a" 'ada-move-to-start)
3526       (define-key ada-mode-map "\C-c\C-e" 'ada-move-to-end)
3527
3528       ;; Compilation
3529       (define-key ada-mode-map "\C-c\C-c" 'compile)
3530       (define-key ada-mode-map "\C-c\C-v" 'ada-check-syntax)
3531       (define-key ada-mode-map "\C-c\C-m" 'ada-make-local)
3532
3533       ;; Casing
3534       (define-key ada-mode-map "\C-c\C-r" 'ada-adjust-case-region)
3535       (define-key ada-mode-map "\C-c\C-b" 'ada-adjust-case-buffer)
3536
3537       (define-key ada-mode-map "\177"     'backward-delete-char-untabify)
3538
3539       ;; Use predefined function of emacs19 for comments (RE)
3540       (define-key ada-mode-map "\C-c;"    'comment-region)
3541       (define-key ada-mode-map "\C-c:"    'ada-uncomment-region)
3542
3543       ;; Change basic functionality
3544
3545       ;; `substitute-key-definition' is not defined equally in Emacs
3546       ;; and XEmacs, you cannot put in an optional 4th parameter in
3547       ;; XEmacs.  I don't think it's necessary, so I leave it out for
3548       ;; Emacs as well.  If you encounter any problems with the
3549       ;; following three functions, please tell me. RE
3550       (mapcar (function (lambda (pair)
3551                           (substitute-key-definition (car pair) (cdr pair)
3552                                                      ada-mode-map)))
3553               '((beginning-of-line      . ada-beginning-of-line)
3554                 (end-of-line            . ada-end-of-line)
3555                 (forward-to-indentation . ada-forward-to-indentation)
3556                 ))
3557       ;; else Emacs
3558       ;;(mapcar (lambda (pair)
3559       ;;             (substitute-key-definition (car pair) (cdr pair)
3560       ;;                                   ada-mode-map global-map))
3561
3562       ))
3563
3564 \f
3565 ;;;-------------------
3566 ;;; define menu 'Ada'
3567 ;;;-------------------
3568
3569 (require 'easymenu)
3570
3571 (defun ada-add-ada-menu ()
3572   "Adds the menu 'Ada' to the menu bar in Ada mode."
3573   (easy-menu-define ada-mode-menu ada-mode-map "Menu keymap for Ada mode."
3574                     '("Ada"
3575                       ["Next Package" ada-next-package t]
3576                       ["Previous Package" ada-previous-package t]
3577                       ["Next Procedure" ada-next-procedure t]
3578                       ["Previous Procedure" ada-previous-procedure t]
3579                       ["Goto Start" ada-move-to-start t]
3580                       ["Goto End" ada-move-to-end t]
3581                       ["------------------" nil nil]
3582                       ["Indent Current Line (TAB)"
3583                        ada-indent-current-function t]
3584                       ["Indent Lines in Region" ada-indent-region t]
3585                       ["Format Parameter List" ada-format-paramlist t]
3586                       ["Pretty Print Buffer" ada-call-pretty-printer t]
3587                       ["------------" nil nil]
3588                       ["Fill Comment Paragraph"
3589                        ada-fill-comment-paragraph t]
3590                       ["Justify Comment Paragraph"
3591                        ada-fill-comment-paragraph-justify t]
3592                       ["Postfix Comment Paragraph"
3593                        ada-fill-comment-paragraph-postfix t]
3594                       ["------------" nil nil]
3595                       ["Adjust Case Region" ada-adjust-case-region t]
3596                       ["Adjust Case Buffer" ada-adjust-case-buffer t]
3597                       ["----------" nil nil]
3598                       ["Comment   Region" comment-region t]
3599                       ["Uncomment Region" ada-uncomment-region t]
3600                       ["----------------" nil nil]
3601                       ["Global Make" compile (fboundp 'compile)]
3602                       ["Local Make" ada-make-local t]
3603                       ["Check Syntax" ada-check-syntax t]
3604                       ["Next Error" next-error (fboundp 'next-error)]
3605                       ["---------------" nil nil]
3606                       ["Index" imenu (fboundp 'imenu)]
3607                       ["--------------" nil nil]
3608                       ["Other File Other Window" ada-ff-other-window
3609                        (fboundp 'ff-find-other-file)]
3610                       ["Other File" ff-find-other-file
3611                        (fboundp 'ff-find-other-file)]))
3612   (if (ada-xemacs) (progn
3613                      (easy-menu-add ada-mode-menu)
3614                      (setq mode-popup-menu (cons "Ada mode" ada-mode-menu)))))
3615
3616
3617 \f
3618 ;;;-------------------------------
3619 ;;; Define Some Support Functions
3620 ;;;-------------------------------
3621
3622 (defun ada-beginning-of-line (&optional arg)
3623   (interactive "P")
3624   (cond
3625    ((eq ada-tab-policy 'indent-af) (af-beginning-of-line arg))
3626    (t (beginning-of-line arg))
3627    ))
3628
3629 (defun ada-end-of-line (&optional arg)
3630   (interactive "P")
3631   (cond
3632    ((eq ada-tab-policy 'indent-af) (af-end-of-line arg))
3633    (t (end-of-line arg))
3634    ))
3635
3636 (defun ada-current-column ()
3637   (cond
3638    ((eq ada-tab-policy 'indent-af) (af-current-column))
3639    (t (current-column))
3640    ))
3641
3642 (defun ada-forward-to-indentation (&optional arg)
3643   (interactive "P")
3644   (cond
3645    ((eq ada-tab-policy 'indent-af) (af-forward-to-indentation arg))
3646    (t (forward-to-indentation arg))
3647    ))
3648
3649 ;;;---------------------------------------------------
3650 ;;; support for find-file.el
3651 ;;;---------------------------------------------------
3652
3653
3654 ;;;###autoload
3655 (defun ada-make-filename-from-adaname (adaname)
3656   "Determine the filename of a package/procedure from its own Ada name."
3657   ;; this is done simply by calling `gnatkr', when we work with GNAT. It
3658   ;; must be a more complex function in other compiler environments.
3659   (interactive "s")
3660   (let (krunch-buf)
3661     (setq krunch-buf (generate-new-buffer "*gkrunch*"))
3662     (save-excursion
3663       (set-buffer krunch-buf)
3664       ;; send adaname to external process `gnatkr'.
3665       (call-process "gnatkr" nil krunch-buf nil
3666                     adaname ada-krunch-args)
3667       ;; fetch output of that process
3668       (setq adaname (buffer-substring
3669                      (point-min)
3670                      (progn
3671                        (goto-char (point-min))
3672                        (end-of-line)
3673                        (point))))
3674       (kill-buffer krunch-buf)))
3675   (setq adaname adaname) ;; can I avoid this statement?
3676   )
3677
3678
3679 ;;; functions for placing the cursor on the corresponding subprogram
3680 (defun ada-which-function-are-we-in ()
3681   "Determine whether we are on a function definition/declaration.
3682 If that is the case remember the name of that function."
3683
3684   (setq ff-function-name nil)
3685
3686   (save-excursion
3687     (if (re-search-backward ada-procedure-start-regexp nil t)
3688         (setq ff-function-name (buffer-substring (match-beginning 0)
3689                                                  (match-end 0)))
3690       ; we didn't find a procedure start, perhaps there is a package
3691       (if (re-search-backward ada-package-start-regexp nil t)
3692           (setq ff-function-name (buffer-substring (match-beginning 0)
3693                                                    (match-end 0)))
3694         ))))
3695
3696
3697 ;;;---------------------------------------------------
3698 ;;; support for font-lock
3699 ;;;---------------------------------------------------
3700
3701 ;; Strings are a real pain in Ada because a single quote character is
3702 ;; overloaded as a string quote and type/instance delimiter.  By default, a
3703 ;; single quote is given punctuation syntax in `ada-mode-syntax-table'.
3704 ;; So, for Font Lock mode purposes, we mark single quotes as having string
3705 ;; syntax when the gods that created Ada determine them to be.  sm.
3706
3707 (defconst ada-font-lock-syntactic-keywords
3708   ;; Mark single quotes as having string quote syntax in 'c' instances.
3709   '(("\\(\'\\).\\(\'\\)" (1 (7 . ?\')) (2 (7 . ?\')))))
3710
3711 (defconst ada-font-lock-keywords-1
3712   (list
3713    ;;
3714    ;; handle "type T is access function return S;"
3715    ;;
3716    (list "\\<\\(function[ \t]+return\\)\\>" '(1 font-lock-keyword-face) )
3717    ;;
3718    ;; accept, entry, function, package (body), protected (body|type),
3719    ;; pragma, procedure, task (body) plus name.
3720    (list (concat
3721           "\\<\\("
3722           "accept\\|"
3723           "entry\\|"
3724           "function\\|"
3725           "package[ \t]+body\\|"
3726           "package\\|"
3727           "pragma\\|"
3728           "procedure\\|"
3729           "protected[ \t]+body\\|"
3730           "protected[ \t]+type\\|"
3731           "protected\\|"
3732 ;;        "p\\(\\(ackage\\|rotected\\)\\(\\|[ \t]+\\(body\\|type\\)\\)\
3733 ;;\\|r\\(agma\\|ocedure\\)\\)\\|"
3734           "task[ \t]+body\\|"
3735           "task[ \t]+type\\|"
3736           "task"
3737 ;;        "task\\(\\|[ \t]+body\\)"
3738           "\\)\\>[ \t]*"
3739           "\\(\\sw+\\(\\.\\sw*\\)*\\)?")
3740     '(1 font-lock-keyword-face) '(2 font-lock-function-name-face nil t)))
3741   "Subdued level highlighting for Ada mode.")
3742
3743 (defconst ada-font-lock-keywords-2
3744   (append ada-font-lock-keywords-1
3745    (list
3746     ;;
3747     ;; Main keywords, except those treated specially below.
3748     (concat "\\<\\("
3749 ;    ("abort" "abs" "abstract" "accept" "access" "aliased" "all"
3750 ;     "and" "array" "at" "begin" "case" "declare" "delay" "delta"
3751 ;     "digits" "do" "else" "elsif" "entry" "exception" "exit" "for"
3752 ;     "generic" "if" "in" "is" "limited" "loop" "mod" "not"
3753 ;     "null" "or" "others" "private" "protected"
3754 ;     "range" "record" "rem" "renames" "requeue" "return" "reverse"
3755 ;     "select" "separate" "tagged" "task" "terminate" "then" "until"
3756 ;     "while" "xor")
3757             "a\\(b\\(ort\\|s\\(\\|tract\\)\\)\\|cce\\(pt\\|ss\\)\\|"
3758             "l\\(iased\\|l\\)\\|nd\\|rray\\|t\\)\\|begin\\|case\\|"
3759             "d\\(e\\(clare\\|l\\(ay\\|ta\\)\\)\\|igits\\|o\\)\\|"
3760             "e\\(ls\\(e\\|if\\)\\|ntry\\|x\\(ception\\|it\\)\\)\\|for\\|"
3761             "generic\\|i[fns]\\|l\\(imited\\|oop\\)\\|mod\\|n\\(ot\\|ull\\)\\|"
3762             "o\\(r\\|thers\\|ut\\)\\|pr\\(ivate\\|otected\\)\\|"
3763             "r\\(a\\(ise\\|nge\\)\\|e\\(cord\\|m\\|names\\|queue\\|turn\\|verse\\)\\)\\|"
3764             "se\\(lect\\|parate\\)\\|"
3765             "t\\(agged\\|erminate\\|hen\\)\\|until\\|" ; task removed
3766             "wh\\(ile\\|en\\)\\|xor" ; "when" added
3767             "\\)\\>")
3768     ;;
3769     ;; Anything following end and not already fontified is a body name.
3770     '("\\<\\(end\\)\\>\\([ \t]+\\)?\\([a-zA-Z0-9_\\.]+\\)?"
3771       (1 font-lock-keyword-face) (3 font-lock-function-name-face nil t))
3772     ;;
3773     ;; Variable name plus optional keywords followed by a type name.  Slow.
3774 ;    (list (concat "\\<\\(\\sw+\\)\\>[ \t]*:?[ \t]*"
3775 ;                 "\\(access\\|constant\\|in\\|in[ \t]+out\\|out\\)?[ \t]*"
3776 ;                 "\\(\\sw+\\)?")
3777 ;         '(1 font-lock-variable-name-face)
3778 ;         '(2 font-lock-keyword-face nil t) '(3 font-lock-type-face nil t))
3779     ;;
3780     ;; Optional keywords followed by a type name.
3781     (list (concat ; ":[ \t]*"
3782                   "\\<\\(access\\|constant\\|in[ \t]+out\\|in\\|out\\)\\>"
3783                   "[ \t]*"
3784                   "\\(\\sw+\\)?")
3785           '(1 font-lock-keyword-face nil t) '(2 font-lock-type-face nil t))
3786     ;;
3787     ;; Keywords followed by a type or function name.
3788     (list (concat "\\<\\("
3789                   "new\\|of\\|subtype\\|type"
3790                   "\\)\\>[ \t]*\\(\\sw+\\)?[ \t]*\\((\\)?")
3791           '(1 font-lock-keyword-face)
3792           '(2 (if (match-beginning 4)
3793                   font-lock-function-name-face
3794                 font-lock-type-face) nil t))
3795     ;;
3796     ;; Keywords followed by a (comma separated list of) reference.
3797     (list (concat "\\<\\(goto\\|raise\\|use\\|with\\)\\>" ; "when" removed
3798                   ; "[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?") ; RE
3799                   "[ \t]*\\([a-zA-Z0-9_\\.\\|, ]+\\)\\W")
3800           '(1 font-lock-keyword-face) '(2 font-lock-reference-face nil t))
3801     ;;
3802     ;; Goto tags.
3803     '("<<\\(\\sw+\\)>>" 1 font-lock-reference-face)
3804     ))
3805   "Gaudy level highlighting for Ada mode.")
3806
3807 (defvar ada-font-lock-keywords ada-font-lock-keywords-1
3808   "Default expressions to highlight in Ada mode.")
3809
3810
3811 ;; set font-lock properties for XEmacs
3812 (if (ada-xemacs)
3813     (put 'ada-mode 'font-lock-defaults
3814          '(ada-font-lock-keywords
3815            nil t ((?\_ . "w")(?\. . "w")) beginning-of-line)))
3816
3817 ;;;
3818 ;;; support for outline
3819 ;;;
3820
3821 ;; used by outline-minor-mode
3822 (defun ada-outline-level ()
3823   (save-excursion
3824     (skip-chars-forward "\t ")
3825     (current-column)))
3826
3827 ;;;
3828 ;;; generate body
3829 ;;;
3830 (defun ada-gen-comment-until-proc ()
3831   ;; comment until spec of a procedure or a function.
3832   (forward-line 1)
3833   (set-mark-command (point))
3834   (if (re-search-forward ada-procedure-start-regexp nil t)
3835       (progn (goto-char (match-beginning 1))
3836              (comment-region (mark) (point)))
3837     (error "No more functions/procedures")))
3838
3839
3840 (defun ada-gen-treat-proc (match)
3841   ;; make dummy body of a procedure/function specification.
3842   ;; MATCH is a cons cell containing the start and end location of the
3843   ;; last search for ada-procedure-start-regexp.
3844   (goto-char (car match))
3845   (let (proc-found func-found procname functype)
3846     (cond
3847      ((or (setq proc-found (looking-at "^[ \t]*procedure"))
3848           (setq func-found (looking-at "^[ \t]*function")))
3849       ;; treat it as a proc/func
3850       (forward-word 2)
3851       (forward-word -1)
3852       (setq procname (buffer-substring (point) (cdr match))) ; store  proc name
3853
3854     ;; goto end of procname
3855     (goto-char (cdr match))
3856
3857     ;; skip over parameterlist
3858     (forward-sexp)
3859     ;; if function, skip over 'return' and result type.
3860     (if func-found
3861         (progn
3862           (forward-word 1)
3863           (skip-chars-forward " \t\n")
3864           (setq functype (buffer-substring (point)
3865                                            (progn
3866                                              (skip-chars-forward
3867                                               "a-zA-Z0-9_\.")
3868                                              (point))))))
3869     ;; look for next non WS
3870     (cond
3871      ((looking-at "[ \t]*;")
3872       (delete-region (match-beginning 0) (match-end 0)) ;; delete the ';'
3873       (ada-indent-newline-indent)
3874       (insert " is")
3875       (ada-indent-newline-indent)
3876       (if func-found
3877           (progn
3878             (insert "Result : ")
3879             (insert functype)
3880             (insert ";")
3881             (ada-indent-newline-indent)))
3882       (insert "begin -- ")
3883       (insert procname)
3884       (ada-indent-newline-indent)
3885       (insert "null;")
3886       (ada-indent-newline-indent)
3887       (if func-found
3888           (progn
3889             (insert "return Result;")
3890             (ada-indent-newline-indent)))
3891       (insert "end ")
3892       (insert procname)
3893       (insert ";")
3894       (ada-indent-newline-indent)
3895       )
3896       ;; else
3897      ((looking-at "[ \t\n]*is")
3898       ;; do nothing
3899       )
3900      ((looking-at "[ \t\n]*rename")
3901       ;; do nothing
3902       )
3903      (t
3904       (message "unknown syntax")))
3905     ))))
3906
3907
3908 (defun ada-make-body ()
3909   "Create an Ada package body in the current buffer.
3910 The potential old buffer contents is deleted first, then we copy the
3911 spec buffer in here and modify it to make it a body.
3912
3913 This function typically is to be hooked into `ff-file-created-hooks'."
3914   (interactive)
3915   (delete-region (point-min) (point-max))
3916   (insert-buffer (car (cdr (buffer-list))))
3917   (ada-mode)
3918
3919   (let (found)
3920     (if (setq found
3921               (ada-search-ignore-string-comment ada-package-start-regexp))
3922         (progn (goto-char (cdr found))
3923                (insert " body")
3924                ;; (forward-line -1)
3925                ;;(comment-region (point-min) (point))
3926                )
3927       (error "No package"))
3928
3929     ;; (comment-until-proc)
3930     ;;   does not work correctly
3931     ;;   must be done by hand
3932
3933     (while (setq found
3934                  (ada-search-ignore-string-comment ada-procedure-start-regexp))
3935       (ada-gen-treat-proc found))))
3936
3937 ;; XEmacs addition
3938 ;;;###autoload(add-to-list 'auto-mode-alist '("\\.ad[abs]\\'" . ada-mode))
3939
3940 ;;; provide ourself
3941
3942 (provide 'ada-mode)
3943
3944 ;;; ada-mode.el ends here