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

   1 ;;; ada.el --- Ada editing support package in GNUlisp.  v1.0
   2
   3 ;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
   4
   5 ;; Author: Vincent Broman <broman@bugs.nosc.mil>
   6 ;; Keywords: languages
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  22 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23
  24 ;;; Commentary:
  25
  26 ;; Created May 1987.
  27 ;; (borrows heavily from Mick Jordan's Modula-2 package for GNU,
  28 ;; as modified by Peter Robinson, Michael Schmidt, and Tom Perrine.)
  29
  30 ;;; Code:
  31
  32 (defvar ada-mode-syntax-table nil
  33   "Syntax table in use in Ada-mode buffers.")
  34
  35 (let ((table (make-syntax-table)))
  36   (modify-syntax-entry ?_ "_" table)
  37   (modify-syntax-entry ?\# "_" table)
  38   (modify-syntax-entry ?\( "()" table)
  39   (modify-syntax-entry ?\) ")(" table)
  40   (modify-syntax-entry ?$ "." table)
  41   (modify-syntax-entry ?* "." table)
  42   (modify-syntax-entry ?/ "." table)
  43   (modify-syntax-entry ?+ "." table)
  44   (modify-syntax-entry ?- ". 12" table)
  45   (modify-syntax-entry ?= "." table)
  46   (modify-syntax-entry ?\& "." table)
  47   (modify-syntax-entry ?\| "." table)
  48   (modify-syntax-entry ?< "." table)
  49   (modify-syntax-entry ?> "." table)
  50   (modify-syntax-entry ?\[ "." table)
  51   (modify-syntax-entry ?\] "." table)
  52   (modify-syntax-entry ?\{ "." table)
  53   (modify-syntax-entry ?\} "." table)
  54   (modify-syntax-entry ?. "." table)
  55   (modify-syntax-entry ?\\ "." table)
  56   (modify-syntax-entry ?: "." table)
  57   (modify-syntax-entry ?\; "." table)
  58   (modify-syntax-entry ?\' "." table)
  59   (modify-syntax-entry ?\" "\"" table)
  60   (modify-syntax-entry ?\n ">" table)
  61   (setq ada-mode-syntax-table table))
  62
  63 ;; Strings are a real pain in Ada because both ' and " can appear in a
  64 ;; non-string quote context (the former as an operator, the latter as a
  65 ;; character string).  We follow the least losing solution, in which only " is
  66 ;; a string quote.  Therefore a character string of the form '"' will throw
  67 ;; fontification off on the wrong track.
  68
  69 (defconst ada-font-lock-keywords-1
  70   (list
  71    ;;
  72    ;; Function, package (body), pragma, procedure, task (body) plus name.
  73    (list (concat "\\<\\("
  74                  "function\\|"
  75                  "p\\(ackage\\(\\|[ \t]+body\\)\\|r\\(agma\\|ocedure\\)\\)\\|"
  76                  "task\\(\\|[ \t]+body\\)"
  77                  "\\)\\>[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?")
  78          '(1 font-lock-keyword-face) '(6 font-lock-function-name-face nil t)))
  79   "For consideration as a value of `ada-font-lock-keywords'.
  80 This does fairly subdued highlighting.")
  81
  82 (defconst ada-font-lock-keywords-2
  83   (append ada-font-lock-keywords-1
  84    (list
  85     ;;
  86     ;; Main keywords, except those treated specially below.
  87     (concat "\\<\\("
  88 ;    ("abort" "abs" "abstract" "accept" "access" "aliased" "all"
  89 ;     "and" "array" "at" "begin" "case" "declare" "delay" "delta"
  90 ;     "digits" "do" "else" "elsif" "entry" "exception" "exit" "for"
  91 ;     "generic" "if" "in" "is" "limited" "loop" "mod" "not"
  92 ;     "null" "or" "others" "private" "protected"
  93 ;     "range" "record" "rem" "renames" "requeue" "return" "reverse"
  94 ;     "select" "separate" "tagged" "task" "terminate" "then" "until"
  95 ;     "while" "xor")
  96             "a\\(b\\(ort\\|s\\(\\|tract\\)\\)\\|cce\\(pt\\|ss\\)\\|"
  97             "l\\(iased\\|l\\)\\|nd\\|rray\\|t\\)\\|begin\\|case\\|"
  98             "d\\(e\\(clare\\|l\\(ay\\|ta\\)\\)\\|igits\\|o\\)\\|"
  99             "e\\(ls\\(e\\|if\\)\\|ntry\\|x\\(ception\\|it\\)\\)\\|for\\|"
 100             "generic\\|i[fns]\\|l\\(imited\\|oop\\)\\|mod\\|n\\(ot\\|ull\\)\\|"
 101             "o\\(r\\|thers\\)\\|pr\\(ivate\\|otected\\)\\|"
 102             "r\\(ange\\|e\\(cord\\|m\\|names\\|queue\\|turn\\|verse\\)\\)\\|"
 103             "se\\(lect\\|parate\\)\\|"
 104             "t\\(a\\(gged\\|sk\\)\\|erminate\\|hen\\)\\|until\\|while\\|xor"
 105             "\\)\\>")
 106     ;;
 107     ;; Anything following end and not already fontified is a body name.
 108     '("\\<\\(end\\)\\>[ \t]*\\(\\sw+\\)?"
 109       (1 font-lock-keyword-face) (2 font-lock-function-name-face nil t))
 110 ;    ;;
 111 ;    ;; Variable name plus optional keywords followed by a type name.  Slow.
 112 ;    (list (concat "\\<\\(\\sw+\\)\\>[ \t]*:"
 113 ;                 "[ \t]*\\(constant\\|in\\|in[ \t]+out\\|out\\)?[ \t]*"
 114 ;                 "\\(\\sw+\\(\\.\\sw*\\)*\\)?")
 115 ;         '(1 font-lock-variable-name-face)
 116 ;         '(2 font-lock-keyword-face nil t) '(3 font-lock-type-face nil t))
 117     ;;
 118     ;; Optional keywords followed by a type name.
 119     (list (concat ":[ \t]*\\<\\(constant\\|in\\|in[ \t]+out\\|out\\)\\>?[ \t]*"
 120                   "\\(\\sw+\\(\\.\\sw*\\)*\\)?")
 121           '(1 font-lock-keyword-face nil t) '(2 font-lock-type-face nil t))
 122     ;;
 123     ;; Keywords followed by a type or function name.
 124     (list (concat "\\<\\("
 125                   "new\\|of\\|subtype\\|type"
 126                   "\\)\\>[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?[ \t]*\\((\\)?")
 127           '(1 font-lock-keyword-face)
 128           '(2 (if (match-beginning 4)
 129                   font-lock-function-name-face
 130                 font-lock-type-face) nil t))
 131     ;;
 132     ;; Keywords followed by a reference.
 133     (list (concat "\\<\\(goto\\|raise\\|use\\|when\\|with\\)\\>"
 134                   "[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?")
 135           '(1 font-lock-keyword-face) '(2 font-lock-reference-face nil t))
 136     ;;
 137     ;; Goto tags.
 138     '("<<\\(\\sw+\\(\\.\\sw*\\)*\\)>>" 1 font-lock-reference-face)
 139     ))
 140   "For consideration as a value of `ada-font-lock-keywords'.
 141 This does a lot more highlighting.")
 142
 143 (defvar ada-font-lock-keywords ada-font-lock-keywords-1
 144   "Additional expressions to highlight in Ada mode.")
 145
 146 (defvar ada-mode-map nil
 147   "Keymap used in Ada mode.")
 148
 149 (let ((map (make-sparse-keymap)))
 150   (define-key map "\C-m" 'ada-newline)
 151   (define-key map "\C-?" 'backward-delete-char-untabify)
 152   (define-key map "\C-i" 'ada-tab)
 153   (define-key map "\C-c\C-i" 'ada-untab)
 154   (define-key map "\C-c<" 'ada-backward-to-same-indent)
 155   (define-key map "\C-c>" 'ada-forward-to-same-indent)
 156   (define-key map "\C-ch" 'ada-header)
 157   (define-key map "\C-c(" 'ada-paired-parens)
 158   (define-key map "\C-c-" 'ada-inline-comment)
 159   (define-key map "\C-c\C-a" 'ada-array)
 160   (define-key map "\C-cb" 'ada-exception-block)
 161   (define-key map "\C-cd" 'ada-declare-block)
 162   (define-key map "\C-c\C-e" 'ada-exception)
 163   (define-key map "\C-cc" 'ada-case)
 164   (define-key map "\C-c\C-k" 'ada-package-spec)
 165   (define-key map "\C-ck" 'ada-package-body)
 166   (define-key map "\C-c\C-p" 'ada-procedure-spec)
 167   (define-key map "\C-cp" 'ada-subprogram-body)
 168   (define-key map "\C-c\C-f" 'ada-function-spec)
 169   (define-key map "\C-cf" 'ada-for-loop)
 170   (define-key map "\C-cl" 'ada-loop)
 171   (define-key map "\C-ci" 'ada-if)
 172   (define-key map "\C-cI" 'ada-elsif)
 173   (define-key map "\C-ce" 'ada-else)
 174   (define-key map "\C-c\C-v" 'ada-private)
 175   (define-key map "\C-c\C-r" 'ada-record)
 176   (define-key map "\C-c\C-s" 'ada-subtype)
 177   (define-key map "\C-cs" 'ada-separate)
 178   (define-key map "\C-c\C-t" 'ada-type)
 179   (define-key map "\C-ct" 'ada-tabsize)
 180 ;;    (define-key map "\C-c\C-u" 'ada-use)
 181 ;;    (define-key map "\C-c\C-w" 'ada-with)
 182   (define-key map "\C-cw" 'ada-while-loop)
 183   (define-key map "\C-c\C-w" 'ada-when)
 184   (define-key map "\C-cx" 'ada-exit)
 185   (define-key map "\C-cC" 'ada-compile)
 186   (define-key map "\C-cB" 'ada-bind)
 187   (define-key map "\C-cE" 'ada-find-listing)
 188   (define-key map "\C-cL" 'ada-library-name)
 189   (define-key map "\C-cO" 'ada-options-for-bind)
 190   (setq ada-mode-map map))
 191
 192 (defvar ada-indent 4 "*Value is the number of columns to indent in Ada-Mode.")
 193
 194 (defvar ada-comment-end-column)
 195
 196 ;;;###autoload
 197 (defun ada-mode ()
 198 "This is a mode intended to support program development in Ada.
 199 Most control constructs and declarations of Ada can be inserted in the buffer
 200 by typing Control-C followed by a character mnemonic for the construct.
 201
 202 \\<ada-mode-map>\\[ada-array] array             \\[ada-exception-block]    exception block
 203 \\[ada-exception]  exception      \\[ada-declare-block]    declare block
 204 \\[ada-package-spec]  package spec   \\[ada-package-body]    package body
 205 \\[ada-procedure-spec]  procedure spec \\[ada-subprogram-body]    proc/func body
 206 \\[ada-function-spec]  func spec      \\[ada-for-loop]    for loop
 207                         \\[ada-if]    if
 208                         \\[ada-elsif]    elsif
 209                         \\[ada-else]    else
 210 \\[ada-private]  private        \\[ada-loop]    loop
 211 \\[ada-record]  record         \\[ada-case]    case
 212 \\[ada-subtype]  subtype        \\[ada-separate]    separate
 213 \\[ada-type]  type           \\[ada-tabsize]    tab spacing for indents
 214 \\[ada-when]  when           \\[ada-while]    while
 215                         \\[ada-exit]    exit
 216 \\[ada-paired-parens]    paired parens  \\[ada-inline-comment]    inline comment
 217                         \\[ada-header]    header spec
 218 \\[ada-compile]    compile        \\[ada-bind]    bind
 219 \\[ada-find-listing]    find error list
 220 \\[ada-library-name]    name library   \\[ada-options-for-bind]    options for bind
 221
 222 \\[ada-backward-to-same-indent] and \\[ada-forward-to-same-indent] move backward and forward respectively to the next line
 223 having the same (or lesser) level of indentation.
 224
 225 Variable `ada-indent' controls the number of spaces for indent/undent."
 226   (interactive)
 227   (kill-all-local-variables)
 228   (use-local-map ada-mode-map)
 229   (setq major-mode 'ada-mode)
 230   (setq mode-name "Ada")
 231   (make-local-variable 'comment-column)
 232   (setq comment-column 41)
 233   (make-local-variable 'ada-comment-end-column)
 234   (setq ada-comment-end-column 72)
 235   (set-syntax-table ada-mode-syntax-table)
 236   (make-local-variable 'paragraph-start)
 237   (setq paragraph-start (concat "^$\\|" page-delimiter))
 238   (make-local-variable 'paragraph-separate)
 239   (setq paragraph-separate paragraph-start)
 240   (make-local-variable 'paragraph-ignore-fill-prefix)
 241   (setq paragraph-ignore-fill-prefix t)
 242 ;  (make-local-variable 'indent-line-function)
 243 ;  (setq indent-line-function 'c-indent-line)
 244   (make-local-variable 'require-final-newline)
 245   (setq require-final-newline t)
 246   (make-local-variable 'comment-start)
 247   (setq comment-start "--")
 248   (make-local-variable 'comment-end)
 249   (setq comment-end "")
 250   (make-local-variable 'comment-column)
 251   (setq comment-column 41)
 252   (make-local-variable 'comment-start-skip)
 253   (setq comment-start-skip "--+ *")
 254   (make-local-variable 'comment-indent-function)
 255   (setq comment-indent-function 'c-comment-indent)
 256   (make-local-variable 'parse-sexp-ignore-comments)
 257   (setq parse-sexp-ignore-comments t)
 258   (make-local-variable 'font-lock-defaults)
 259   (setq font-lock-defaults '(ada-font-lock-keywords nil t ((?\_ . "w"))))
 260   (run-hooks 'ada-mode-hook))
 261
 262 (defun ada-tabsize (s)
 263   "Changes spacing used for indentation.
 264 The prefix argument is used as the new spacing."
 265   (interactive "p")
 266   (setq ada-indent s))
 267
 268 (defun ada-newline ()
 269   "Start new line and indent to current tab stop."
 270   (interactive)
 271   (let ((ada-cc (current-indentation)))
 272     (newline)
 273     (indent-to ada-cc)))
 274
 275 (defun ada-tab ()
 276   "Indent to next tab stop."
 277   (interactive)
 278   (indent-to (* (1+ (/ (current-indentation) ada-indent)) ada-indent)))
 279
 280 (defun ada-untab ()
 281   "Delete backwards to previous tab stop."
 282   (interactive)
 283   (backward-delete-char-untabify ada-indent nil))
 284
 285 (defun ada-go-to-this-indent (step indent-level)
 286   "Move point repeatedly by STEP lines until the current line has
 287 given INDENT-LEVEL or less, or the start or end of the buffer is reached.
 288 Ignore blank lines, statement labels and block or loop names."
 289   (while (and
 290           (zerop (forward-line step))
 291           (or (looking-at "^[   ]*$")
 292               (looking-at "^[   ]*--")
 293               (looking-at "^<<[A-Za-z0-9_]+>>")
 294               (looking-at "^[A-Za-z0-9_]+:")
 295               (> (current-indentation) indent-level)))
 296     nil))
 297
 298 (defun ada-backward-to-same-indent ()
 299   "Move point backwards to nearest line with same indentation or less.
 300 If not found, point is left at the top of the buffer."
 301   (interactive)
 302   (ada-go-to-this-indent -1 (current-indentation))
 303   (back-to-indentation))
 304
 305 (defun ada-forward-to-same-indent ()
 306   "Move point forwards to nearest line with same indentation or less.
 307 If not found, point is left at the start of the last line in the buffer."
 308   (interactive)
 309   (ada-go-to-this-indent 1 (current-indentation))
 310   (back-to-indentation))
 311
 312 (defun ada-array ()
 313   "Insert array type definition.  Uses the minibuffer to prompt
 314 for component type and index subtypes."
 315   (interactive)
 316   (insert "array ()")
 317   (backward-char)
 318   (insert (read-string "index subtype[s]: "))
 319   (end-of-line)
 320   (insert " of ;")
 321   (backward-char)
 322   (insert (read-string "component-type: "))
 323   (end-of-line))
 324
 325 (defun ada-case ()
 326   "Build skeleton case statement.
 327 Uses the minibuffer to prompt for the selector expression.
 328 Also builds the first when clause."
 329   (interactive)
 330   (insert "case ")
 331   (insert (read-string "selector expression: ") " is")
 332   (ada-newline)
 333   (ada-newline)
 334   (insert "end case;")
 335   (end-of-line 0)
 336   (ada-tab)
 337   (ada-tab)
 338   (ada-when))
 339
 340 (defun ada-declare-block ()
 341   "Insert a block with a declare part.
 342 Indent for the first declaration."
 343   (interactive)
 344   (let ((ada-block-name (read-string "[block name]: ")))
 345     (insert "declare")
 346     (cond
 347      ( (not (string-equal ada-block-name ""))
 348        (beginning-of-line)
 349        (open-line 1)
 350        (insert ada-block-name ":")
 351        (next-line 1)
 352        (end-of-line)))
 353     (ada-newline)
 354     (ada-newline)
 355     (insert "begin")
 356     (ada-newline)
 357     (ada-newline)
 358     (if (string-equal ada-block-name "")
 359         (insert "end;")
 360       (insert "end " ada-block-name ";"))
 361     )
 362   (end-of-line -2)
 363   (ada-tab))
 364
 365 (defun ada-exception-block ()
 366   "Insert a block with an exception part.
 367 Indent for the first line of code."
 368   (interactive)
 369   (let ((block-name (read-string "[block name]: ")))
 370     (insert "begin")
 371     (cond
 372      ( (not (string-equal block-name ""))
 373        (beginning-of-line)
 374        (open-line 1)
 375        (insert block-name ":")
 376        (next-line 1)
 377        (end-of-line)))
 378     (ada-newline)
 379     (ada-newline)
 380     (insert "exception")
 381     (ada-newline)
 382     (ada-newline)
 383     (cond
 384      ( (string-equal block-name "")
 385        (insert "end;"))
 386      ( t
 387        (insert "end " block-name ";")))
 388     )
 389   (end-of-line -2)
 390   (ada-tab))
 391
 392 (defun ada-exception ()
 393   "Insert an indented exception part into a block."
 394   (interactive)
 395   (ada-untab)
 396   (insert "exception")
 397   (ada-newline)
 398   (ada-tab))
 399
 400 (defun ada-else ()
 401   "Add an else clause inside an if-then-end-if clause."
 402   (interactive)
 403   (ada-untab)
 404   (insert "else")
 405   (ada-newline)
 406   (ada-tab))
 407
 408 (defun ada-exit ()
 409   "Insert an exit statement, prompting for loop name and condition."
 410   (interactive)
 411   (insert "exit")
 412   (let ((ada-loop-name (read-string "[name of loop to exit]: ")))
 413     (if (not (string-equal ada-loop-name "")) (insert " " ada-loop-name)))
 414   (let ((ada-exit-condition (read-string "[exit condition]: ")))
 415     (if (not (string-equal ada-exit-condition ""))
 416         (if (string-match "^ *[Ww][Hh][Ee][Nn] +" ada-exit-condition)
 417             (insert " " ada-exit-condition)
 418           (insert " when " ada-exit-condition))))
 419   (insert ";"))
 420
 421 (defun ada-when ()
 422   "Start a case statement alternative with a when clause."
 423   (interactive)
 424   (ada-untab)     ; we were indented in code for the last alternative.
 425   (insert "when ")
 426   (insert (read-string "'|'-delimited choice list: ") " =>")
 427   (ada-newline)
 428   (ada-tab))
 429
 430 (defun ada-for-loop ()
 431   "Build a skeleton for-loop statement, prompting for the loop parameters."
 432   (interactive)
 433   (insert "for ")
 434   (let* ((ada-loop-name (read-string "[loop name]: "))
 435          (ada-loop-is-named (not (string-equal ada-loop-name ""))))
 436     (if ada-loop-is-named
 437         (progn
 438           (beginning-of-line)
 439           (open-line 1)
 440           (insert ada-loop-name ":")
 441           (next-line 1)
 442           (end-of-line 1)))
 443     (insert (read-string "loop variable: ") " in ")
 444     (insert (read-string "range: ") " loop")
 445     (ada-newline)
 446     (ada-newline)
 447     (insert "end loop")
 448     (if ada-loop-is-named (insert " " ada-loop-name))
 449     (insert ";"))
 450   (end-of-line 0)
 451   (ada-tab))
 452
 453 (defun ada-header ()
 454   "Insert a comment block containing the module title, author, etc."
 455   (interactive)
 456   (insert "--\n--  Title: \t")
 457   (insert (read-string "Title: "))
 458   (insert "\n--  Created:\t" (current-time-string))
 459   (insert "\n--  Author: \t" (user-full-name))
 460   (insert "\n--\t\t<" (user-login-name) "@" (system-name) ">\n--\n"))
 461
 462 (defun ada-if ()
 463   "Insert skeleton if statment, prompting for a boolean-expression."
 464   (interactive)
 465   (insert "if ")
 466   (insert (read-string "condition: ") " then")
 467   (ada-newline)
 468   (ada-newline)
 469   (insert "end if;")
 470   (end-of-line 0)
 471   (ada-tab))
 472
 473 (defun ada-elsif ()
 474   "Add an elsif clause to an if statement, prompting for the boolean-expression."
 475   (interactive)
 476   (ada-untab)
 477   (insert "elsif ")
 478   (insert (read-string "condition: ") " then")
 479   (ada-newline)
 480   (ada-tab))
 481
 482 (defun ada-loop ()
 483   "Insert a skeleton loop statement.  The exit statement is added by hand."
 484   (interactive)
 485   (insert "loop ")
 486   (let* ((ada-loop-name (read-string "[loop name]: "))
 487          (ada-loop-is-named (not (string-equal ada-loop-name ""))))
 488     (if ada-loop-is-named
 489         (progn
 490           (beginning-of-line)
 491           (open-line 1)
 492           (insert ada-loop-name ":")
 493           (forward-line 1)
 494           (end-of-line 1)))
 495     (ada-newline)
 496     (ada-newline)
 497     (insert "end loop")
 498     (if ada-loop-is-named (insert " " ada-loop-name))
 499     (insert ";"))
 500   (end-of-line 0)
 501   (ada-tab))
 502
 503 (defun ada-package-spec ()
 504   "Insert a skeleton package specification."
 505   (interactive)
 506   (insert "package ")
 507   (let ((ada-package-name (read-string "package name: " )))
 508     (insert ada-package-name " is")
 509     (ada-newline)
 510     (ada-newline)
 511     (insert "end " ada-package-name ";")
 512     (end-of-line 0)
 513     (ada-tab)))
 514
 515 (defun ada-package-body ()
 516   "Insert a skeleton package body --  includes a begin statement."
 517   (interactive)
 518   (insert "package body ")
 519   (let ((ada-package-name (read-string "package name: " )))
 520     (insert ada-package-name " is")
 521     (ada-newline)
 522     (ada-newline)
 523     (insert "begin")
 524     (ada-newline)
 525     (insert "end " ada-package-name ";")
 526     (end-of-line -1)
 527     (ada-tab)))
 528
 529 (defun ada-private ()
 530   "Undent and start a private section of a package spec. Reindent."
 531   (interactive)
 532   (ada-untab)
 533   (insert "private")
 534   (ada-newline)
 535   (ada-tab))
 536
 537 (defun ada-get-arg-list ()
 538   "Read from the user a procedure or function argument list.
 539 Add parens unless arguments absent, and insert into buffer.
 540 Individual arguments are arranged vertically if entered one at a time.
 541 Arguments ending with `;' are presumed single and stacked."
 542   (insert " (")
 543   (let ((ada-arg-indent (current-column))
 544         (ada-args (read-string "[arguments]: ")))
 545     (if (string-equal ada-args "")
 546         (backward-delete-char 2)
 547       (progn
 548         (while (string-match ";$" ada-args)
 549           (insert ada-args)
 550           (newline)
 551           (indent-to ada-arg-indent)
 552           (setq ada-args (read-string "next argument: ")))
 553         (insert ada-args ")")))))
 554
 555 (defun ada-function-spec ()
 556   "Insert a function specification.  Prompts for name and arguments."
 557   (interactive)
 558   (insert "function ")
 559   (insert (read-string "function name: "))
 560   (ada-get-arg-list)
 561   (insert " return ")
 562   (insert (read-string "result type: ")))
 563
 564 (defun ada-procedure-spec ()
 565   "Insert a procedure specification, prompting for its name and arguments."
 566   (interactive)
 567   (insert "procedure ")
 568   (insert (read-string "procedure name: " ))
 569   (ada-get-arg-list))
 570
 571 (defun get-ada-subprogram-name ()
 572   "Return (without moving point or mark) a pair whose CAR is the name of
 573 the function or procedure whose spec immediately precedes point, and whose
 574 CDR is the column number where the procedure/function keyword was found."
 575   (save-excursion
 576     (let ((ada-proc-indent 0))
 577       (if (re-search-backward
 578   ;;;; Unfortunately, comments are not ignored in this string search.
 579              "[PpFf][RrUu][OoNn][Cc][EeTt][DdIi][UuOo][RrNn]" nil t)
 580           (if (or (looking-at "\\<[Pp][Rr][Oo][Cc][Ee][Dd][Uu][Rr][Ee]\\>")
 581                   (looking-at "\\<[Ff][Uu][Nn][Cc][Tt][Ii][Oo][Nn]\\>"))
 582               (progn
 583                 (setq ada-proc-indent (current-column))
 584                 (forward-word 2)
 585                 (let ((p2 (point)))
 586                   (forward-word -1)
 587                   (cons (buffer-substring (point) p2) ada-proc-indent)))
 588               (get-ada-subprogram-name))
 589            (cons "NAME?" ada-proc-indent)))))
 590
 591 (defun ada-subprogram-body ()
 592   "Insert frame for subprogram body.
 593 Invoke right after `ada-function-spec' or `ada-procedure-spec'."
 594   (interactive)
 595   (insert " is")
 596   (let ((ada-subprogram-name-col (get-ada-subprogram-name)))
 597     (newline)
 598     (indent-to (cdr ada-subprogram-name-col))
 599     (ada-newline)
 600     (insert "begin")
 601     (ada-newline)
 602     (ada-newline)
 603     (insert "end " (car ada-subprogram-name-col) ";"))
 604   (end-of-line -2)
 605   (ada-tab))
 606
 607 (defun ada-separate ()
 608   "Finish a body stub with `is separate'."
 609   (interactive)
 610   (insert " is")
 611   (ada-newline)
 612   (ada-tab)
 613   (insert "separate;")
 614   (ada-newline)
 615   (ada-untab))
 616
 617 ;(defun ada-with ()
 618 ;  "Inserts a with clause, prompting for the list of units depended upon."
 619 ;  (interactive)
 620 ;  (insert "with ")
 621 ;  (insert (read-string "list of units depended upon: ") ";"))
 622 ;
 623 ;(defun ada-use ()
 624 ;  "Inserts a use clause, prompting for the list of packages used."
 625 ;  (interactive)
 626 ;  (insert "use ")
 627 ;  (insert (read-string "list of packages to use: ") ";"))
 628
 629 (defun ada-record ()
 630   "Insert a skeleton record type declaration."
 631   (interactive)
 632   (insert "record")
 633   (ada-newline)
 634   (ada-newline)
 635   (insert "end record;")
 636   (end-of-line 0)
 637   (ada-tab))
 638
 639 (defun ada-subtype ()
 640   "Start insertion of a subtype declaration, prompting for the subtype name."
 641   (interactive)
 642   (insert "subtype " (read-string "subtype name: ") " is ;")
 643   (backward-char)
 644   (message "insert subtype indication."))
 645
 646 (defun ada-type ()
 647   "Start insertion of a type declaration, prompting for the type name."
 648   (interactive)
 649   (insert "type " (read-string "type name: "))
 650   (let ((disc-part (read-string "discriminant specs: ")))
 651     (if (not (string-equal disc-part ""))
 652         (insert "(" disc-part ")")))
 653   (insert " is ")
 654   (message "insert type definition."))
 655
 656 (defun ada-while-loop ()
 657   (interactive)
 658   (insert "while ")
 659   (let* ((ada-loop-name (read-string "loop name: "))
 660          (ada-loop-is-named (not (string-equal ada-loop-name ""))))
 661     (if ada-loop-is-named
 662         (progn
 663           (beginning-of-line)
 664           (open-line 1)
 665           (insert ada-loop-name ":")
 666           (next-line 1)
 667           (end-of-line 1)))
 668     (insert (read-string "entry condition: ") " loop")
 669     (ada-newline)
 670     (ada-newline)
 671     (insert "end loop")
 672     (if ada-loop-is-named (insert " " ada-loop-name))
 673     (insert ";"))
 674   (end-of-line 0)
 675   (ada-tab))
 676
 677 (defun ada-paired-parens ()
 678   "Insert a pair of round parentheses, placing point between them."
 679   (interactive)
 680   (insert "()")
 681   (backward-char))
 682
 683 (defun ada-inline-comment ()
 684   "Start a comment after the end of the line, indented at least
 685 `comment-column' spaces.  If starting after `end-comment-column',
 686 start a new line."
 687   (interactive)
 688   (end-of-line)
 689   (if (> (current-column) ada-comment-end-column) (newline))
 690   (if (< (current-column) comment-column) (indent-to comment-column))
 691   (insert " -- "))
 692
 693 (defun ada-display-comment ()
 694 "Inserts three comment lines, making a display comment."
 695   (interactive)
 696   (insert "--\n-- \n--")
 697   (end-of-line 0))
 698
 699 ;; Much of this is specific to Ada-Ed
 700
 701 (defvar ada-lib-dir-name "lib" "*Current Ada program library directory.")
 702 (defvar ada-bind-opts "" "*Options to supply for binding.")
 703
 704 (defun ada-library-name (ada-lib-name)
 705   "Specify name of Ada library directory for later compilations."
 706   (interactive "DName of Ada library directory: ")
 707   (setq ada-lib-dir-name ada-lib-name))
 708
 709 (defun ada-options-for-bind ()
 710   "Specify options, such as -m and -i, needed for `ada-bind'."
 711   (setq ada-bind-opts (read-string "-m and -i options for `ada-bind': ")))
 712
 713 (defun ada-compile (arg)
 714   "Save the current buffer and compile it into the current program library.
 715 Initialize the library if a prefix arg is given."
 716   (interactive "P")
 717   (let* ((ada-init (if (null arg) "" "-n "))
 718         (ada-source-file (buffer-name)))
 719     (compile
 720      (concat "adacomp " ada-init "-l " ada-lib-dir-name " " ada-source-file))))
 721
 722 (defun ada-find-listing ()
 723   "Find listing file for ada source in current buffer, using other window."
 724   (interactive)
 725   (find-file-other-window (concat (substring (buffer-name) 0 -4) ".lis"))
 726   (search-forward "*** ERROR"))
 727
 728 (defun ada-bind ()
 729   "Bind the current program library, using the current binding options."
 730   (interactive)
 731   (compile (concat "adabind " ada-bind-opts " " ada-lib-dir-name)))
 732
 733 ;;; ada.el ends here