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