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