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