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

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