xemacs-beta: lisp/modes/ada-mode.el comparison

comparison lisp/modes/ada-mode.el @ 189:489f57a838ef r20-3b21

Import from CVS: tag r20-3b21

author	cvs
date	Mon, 13 Aug 2007 09:57:07 +0200
parents	28f395d8dc7a
children

comparison

equal deleted inserted replaced

-:e29a8e7498d9
+:489f57a838ef
 ;;; ada-mode.el --- An Emacs major-mode for editing Ada source.
-;;; Copyright (C) 1994, 1995 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 1995, 1997 Free Software Foundation, Inc.
-;;; Authors: Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de>
-;;;          Rolf Ebert      <ebert@inf.enst.fr>
+;; Authors: Rolf Ebert      <ebert@inf.enst.fr>
+;;          Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de>
-;;; This file is part of XEmacs.
+;; Keywords: languages oop ada
+;; Rolf Ebert's version: 2.27
-;; XEmacs is free software; you can redistribute it and/or modify it
-;; under the terms of the GNU General Public License as published by
+;; This file is part of XEmacs
+;; XEmacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
 ;; the Free Software Foundation; either version 2, or (at your option)
 ;; any later version.
-;; XEmacs is distributed in the hope that it will be useful, but
+;; XEmacs is distributed in the hope that it will be useful,
-;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-;; General Public License for more details.
+;; GNU General Public License for more details.
 ;; You should have received a copy of the GNU General Public License
-;; along with XEmacs; see the file COPYING.  If not, write to the Free
+;; along with XEmacs; see the file COPYING.  If not, write to the
-;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; 02111-1307, USA.
+;; Boston, MA 02111-1307, USA.
 ;;; This mode is a complete rewrite of a major mode for editing Ada 83
 ;;; and Ada 95 source code under Emacs-19.  It contains completely new
 ;;; indenting code and support for code browsing (see ada-xref).
-;;; Synched up with: FSF 19.34.
+;;; Synched up with: FSF 20.1
 ;;; USAGE
 ;;; =====
-;;; Emacs should enter ada-mode when you load an ada source (*.ad[abs]).
+;;; Emacs should enter Ada mode when you load an Ada source (*.ad[abs]).
 ;;;
 ;;; When you have entered ada-mode, you may get more info by pressing
 ;;; C-h m. You may also get online help describing various functions by:
 ;;; C-h d <Name of function you want described>
 ;;; written by Steven D. Litvintchouk and Steven M. Rosen for the
 ;;; Gosling Emacs. L. Slater based his development on ada.el and
 ;;; electric-ada.el.
 ;;;
 ;;; The current Ada mode is a complete rewrite by M. Heritsch and
-;;; R. Ebert.  Some ideas from the ada-mode mailing list have been
+;;; R. Ebert.  Some ideas from the Ada mode mailing list have been
 ;;; added.  Some of the functionality of L. Slater's mode has not
 ;;; (yet) been recoded in this new mode.  Perhaps you prefer sticking
 ;;; to his version.
 ;;; ==========
 ;;;
 ;;; In the presence of comments and/or incorrect syntax
 ;;; ada-format-paramlist produces weird results.
 ;;; -------------------
-;;; Indenting of some tasking constructs is still buggy.
+;;; Character constants with otherwise syntactic relevant characters
+;;; like `(' or `"' throw indentation off the track.  Fontification
+;;; should work now in Emacs-19.35
+;;; C : constant Character := Character'('"');
 ;;; -------------------
-;;; package Test is
-;;;    -- If I hit return on the "type" line it will indent the next line
-;;;    -- in another 3 space instead of heading out to the "(". If I hit
+;;; TODO
-;;;    -- tab or return it reindents the line correctly but does not initially.
+;;; ====
-;;;    type Wait_Return is (Read_Success, Read_Timeout, Wait_Timeout,
+;;;
-;;;       Nothing_To_Wait_For_In_Wait_List);
+;;; o bodify-single-subprogram
-;;; -------------------
+;;; o make a function "separate" and put it in the corresponding file.
 ;;; CREDITS
 ;;; =======
 ;;;--------------------
 ;;;    USER OPTIONS
 ;;;--------------------
+;; ---- customize support
+(defgroup ada nil
+"Major mode for editing Ada source in Emacs"
+:group 'languages)
 ;; ---- configure indentation
-(defvar ada-indent 3
+(defcustom ada-indent 3
-"*Defines the size of Ada indentation.")
+"*Defines the size of Ada indentation."
+:type 'integer
-(defvar ada-broken-indent 2
+:group 'ada)
-"*# of columns to indent the continuation of a broken line.")
+(defcustom ada-broken-indent 2
-(defvar ada-label-indent -4
+"*# of columns to indent the continuation of a broken line."
-"*# of columns to indent a label.")
+:type 'integer
+:group 'ada)
-(defvar ada-stmt-end-indent 0
+(defcustom ada-label-indent -4
+"*# of columns to indent a label."
+:type 'integer
+:group 'ada)
+(defcustom ada-stmt-end-indent 0
 "*# of columns to indent a statement end keyword in a separate line.
-Examples are 'is', 'loop', 'record', ...")
+Examples are 'is', 'loop', 'record', ..."
+:type 'integer
-(defvar ada-when-indent 3
+:group 'ada)
-"*Defines the indentation for 'when' relative to 'exception' or 'case'.")
+(defcustom ada-when-indent 3
-(defvar ada-indent-record-rel-type 3
+"*Defines the indentation for 'when' relative to 'exception' or 'case'."
-"*Defines the indentation for 'record' relative to 'type' or 'use'.")
+:type 'integer
+:group 'ada)
-(defvar ada-indent-comment-as-code t
-"*If non-nil, comment-lines get indented as Ada code.")
+(defcustom ada-indent-record-rel-type 3
+"*Defines the indentation for 'record' relative to 'type' or 'use'."
-(defvar ada-indent-is-separate t
+:type 'integer
-"*If non-nil, 'is separate' or 'is abstract' on a single line are indented.")
+:group 'ada)
-(defvar ada-indent-to-open-paren t
+(defcustom ada-indent-comment-as-code t
-"*If non-nil, indent according to the innermost open parenthesis.")
+"*If non-nil, comment-lines get indented as Ada code."
+:type 'boolean
-(defvar ada-search-paren-char-count-limit 3000
+:group 'ada)
-"*Search that many characters for an open parenthesis.")
+(defcustom ada-indent-is-separate t
+"*If non-nil, 'is separate' or 'is abstract' on a single line are indented."
+:type 'boolean
+:group 'ada)
+(defcustom ada-indent-to-open-paren t
+"*If non-nil, indent according to the innermost open parenthesis."
+:type 'boolean
+:group 'ada)
+(defcustom ada-search-paren-char-count-limit 3000
+"*Search that many characters for an open parenthesis."
+:type 'integer
+:group 'ada)
 ;; ---- other user options
-(defvar ada-tab-policy 'indent-auto
+(defcustom ada-tab-policy 'indent-auto
 "*Control behaviour of the TAB key.
 Must be one of `indent-rigidly', `indent-auto', `gei', `indent-af'
 or `always-tab'.
 `indent-rigidly' : always adds ada-indent blanks at the beginning of the line.
 `indent-auto'    : use indentation functions in this file.
 `gei'            : use David K�gedal's Generic Indentation Engine.
 `indent-af'      : use Gary E. Barnes' ada-format.el
-`always-tab'     : do indent-relative.")
+`always-tab'     : do indent-relative."
+:type '(choice (const indent-auto)
-(defvar ada-move-to-declaration nil
+(const indent-rigidly)
+(const gei)
+(const indent-af)
+(const always-tab))
+:group 'ada)
+(defcustom ada-move-to-declaration nil
 "*If non-nil, `ada-move-to-start' moves point to the subprog declaration,
-not to 'begin'.")
+not to 'begin'."
+:type 'boolean
-(defvar ada-spec-suffix ".ads"
+:group 'ada)
-"*Suffix of Ada specification files.")
+(defcustom ada-spec-suffix ".ads"
-(defvar ada-body-suffix ".adb"
+"*Suffix of Ada specification files."
-"*Suffix of Ada body files.")
+:type 'string
+:group 'ada)
-(defvar ada-language-version 'ada95
-"*Do we program in `ada83' or `ada95'?")
+(defcustom ada-body-suffix ".adb"
+"*Suffix of Ada body files."
-(defvar ada-case-keyword 'downcase-word
+:type 'string
+:group 'ada)
+(defcustom ada-spec-suffix-as-regexp "\\.ads$"
+"*Regexp to find Ada specification files."
+:type 'string
+:group 'ada)
+(defcustom ada-body-suffix-as-regexp "\\.adb$"
+"*Regexp to find Ada body files."
+:type 'string
+:group 'ada)
+(defvar ada-other-file-alist
+(list
+(list ada-spec-suffix-as-regexp (list ada-body-suffix))
+(list ada-body-suffix-as-regexp (list ada-spec-suffix))
+)
+"*Alist of extensions to find given the current file's extension.
+This list should contain the most used extensions before the others,
+since the search algorithm searches sequentially through each directory
+specified in `ada-search-directories'.  If a file is not found, a new one
+is created with the first matching extension (`.adb' yields `.ads').")
+(defcustom ada-search-directories
+'("." "/usr/adainclude" "/usr/local/adainclude" "/opt/gnu/adainclude")
+"*List of directories to search for Ada files.
+See the description for the `ff-search-directories' variable."
+:type '(repeat (choice :tag "Directory"
+(const :tag "default" nil)
+(directory :format "%v")))
+:group 'ada)
+(defcustom ada-language-version 'ada95
+"*Do we program in `ada83' or `ada95'?"
+:type '(choice (const ada83)
+(const ada95))
+:group 'ada)
+(defcustom ada-case-keyword 'downcase-word
 "*Function to call to adjust the case of Ada keywords.
 It may be `downcase-word', `upcase-word', `ada-loose-case-word' or
-`capitalize-word'.")
+`capitalize-word'."
+:type '(choice (const downcase-word)
-(defvar ada-case-identifier 'ada-loose-case-word
+(const upcase-word)
+(const capitalize-word)
+(const ada-loose-case-word))
+:group 'ada)
+(defcustom ada-case-identifier 'ada-loose-case-word
 "*Function to call to adjust the case of an Ada identifier.
 It may be `downcase-word', `upcase-word', `ada-loose-case-word' or
-`capitalize-word'.")
+`capitalize-word'."
+:type '(choice (const downcase-word)
-(defvar ada-case-attribute 'capitalize-word
+(const upcase-word)
+(const capitalize-word)
+(const ada-loose-case-word))
+:group 'ada)
+(defcustom ada-case-attribute 'capitalize-word
 "*Function to call to adjust the case of Ada attributes.
 It may be `downcase-word', `upcase-word', `ada-loose-case-word' or
-`capitalize-word'.")
+`capitalize-word'."
+:type '(choice (const downcase-word)
-(defvar ada-auto-case t
+(const upcase-word)
+(const capitalize-word)
+(const ada-loose-case-word))
+:group 'ada)
+(defcustom ada-auto-case t
 "*Non-nil automatically changes case of preceding word while typing.
 Casing is done according to `ada-case-keyword', `ada-case-identifier'
-and `ada-cacse-attribute'.")
+and `ada-case-attribute'."
+:type 'boolean
-(defvar ada-clean-buffer-before-saving  nil
+:group 'ada)
-"*If non-nil, `remove-trailing-spaces' and `untabify' buffer before saving.")
+(defcustom ada-clean-buffer-before-saving t
+"*If non-nil, `remove-trailing-spaces' and `untabify' buffer before saving."
+:type 'boolean
+:group 'ada)
 (defvar ada-mode-hook nil
-"*List of functions to call when Ada Mode is invoked.
+"*List of functions to call when Ada mode is invoked.
 This is a good place to add Ada environment specific bindings.")
-(defvar ada-external-pretty-print-program "aimap"
+(defcustom ada-external-pretty-print-program "aimap"
-"*External pretty printer to call from within Ada Mode.")
+"*External pretty printer to call from within Ada mode."
+:type 'string
-(defvar ada-tmp-directory "/tmp/"
+:group 'ada)
-"*Directory to store the temporary file for the Ada pretty printer.")
+(defcustom ada-tmp-directory "/tmp/"
-(defvar ada-fill-comment-prefix "-- "
+"*Directory to store the temporary file for the Ada pretty printer."
-"*This is inserted in the first columns when filling a comment paragraph.")
+:type 'string
+:group 'ada)
-(defvar ada-fill-comment-postfix " --"
-"*This is inserted at the end of each line when filling a comment paragraph
+(defcustom ada-compile-options "-c"
-with `ada-fill-comment-paragraph-postfix'.")
+"*Buffer local options passed to the Ada compiler.
+These options are used when the compiler is invoked on the current buffer."
-(defvar ada-krunch-args "0"
+:type 'string
-"*Argument of gnatk8, a string containing the max number of characters.
+:group 'ada)
-Set to 0, if you don't use crunched filenames.")
+(make-variable-buffer-local 'ada-compile-options)
+(defcustom ada-make-options "-c"
+"*Buffer local options passed to `ada-compiler-make' (usually `gnatmake').
+These options are used when `gnatmake' is invoked on the current buffer."
+:type 'string
+:group 'ada)
+(make-variable-buffer-local 'ada-make-options)
+(defcustom ada-compiler-syntax-check "gcc -c -gnats"
+"*Compiler command with options for syntax checking."
+:type 'string
+:group 'ada)
+(defcustom ada-compiler-make "gnatmake"
+"*The `make' command for the given compiler."
+:type 'string
+:group 'ada)
+(defcustom ada-fill-comment-prefix "-- "
+"*This is inserted in the first columns when filling a comment paragraph."
+:type 'string
+:group 'ada)
+(defcustom ada-fill-comment-postfix " --"
+"*This is inserted at the end of each line when filling a comment paragraph.
+with `ada-fill-comment-paragraph-postfix'."
+:type 'string
+:group 'ada)
+(defcustom ada-krunch-args "0"
+"*Argument of gnatkr, a string containing the max number of characters.
+Set to 0, if you don't use crunched filenames."
+:type 'string
+:group 'ada)
 ;;; ---- end of user configurable variables
 (defvar ada-mode-abbrev-table nil
-"Abbrev table used in Ada Mode.")
+"Abbrev table used in Ada mode.")
 (define-abbrev-table 'ada-mode-abbrev-table ())
 (defvar ada-mode-map ()
-"Local keymap used for Ada Mode.")
+"Local keymap used for Ada mode.")
 (defvar ada-mode-syntax-table nil
 "Syntax table to be used for editing Ada source code.")
 (defvar ada-mode-symbol-syntax-table nil
 \\(\\(limited\\|abstract\\|tagged\\)[ \t]+\\)*record\\)\\>"
 "Regexp for keywords starting Ada blocks.")
 (defvar ada-end-stmt-re
 "\\(;\\|=>\\|^[ \t]*separate[ \t]+([a-zA-Z0-9_\\.]+)\\|\
-\\<\\(begin\\|else\\|record\\|loop\\|select\\|do\\|\
+\\<\\(begin\\|else\\|record\\|loop\\|select\\|do\\|then\\|\
 declare\\|generic\\|private\\)\\>\\|\
-^[ \t]*\\(package\\|procedure\\|function\\)[ \ta-zA-Z0-9_\\.]+is\\|\
+^[ \t]*\\(package\\|procedure\\|function\\)\\>[ \ta-zA-Z0-9_\\.]+\\<is\\>\\|\
 ^[ \t]*exception\\>\\)"
 "Regexp of possible ends for a non-broken statement.
 A new statement starts after these.")
 (defvar ada-loop-start-re
 (defvar ada-subprog-start-re
 "\\<\\(procedure\\|protected\\|package\\|function\\|\
 task\\|accept\\|entry\\)\\>"
 "Regexp for the start of a subprogram.")
+(defvar ada-named-block-re
+"[ \t]*[a-zA-Z_0-9]+ *:[^=]"
+"Regexp of the name of a block or loop.")
 ;; Written by Christian Egli <Christian.Egli@hcsd.hac.com>
 ;;
 (defvar ada-imenu-generic-expression
 '((nil "^\\s-*\\(procedure\\|function\\)\\s-+\\([A-Za-z0-9_]+\\)" 2)
-("Type Defs" "^\\s-*\\(sub\\)?type\\s-+\\([A-Za-z0-9_]+\\)" 2))
+	("Type Defs" "^\\s-*\\(sub\\)?type\\s-+\\([A-Za-z0-9_]+\\)" 2))
 "Imenu generic expression for Ada mode.  See `imenu-generic-expression'.")
 ;;;-------------
 ;;;  functions
 (defun ada-xemacs ()
 (or (string-match "Lucid"  emacs-version)
 (string-match "XEmacs" emacs-version)))
 (defun ada-create-syntax-table ()
-"Create the syntax table for Ada Mode."
+"Create the syntax table for Ada mode."
 ;; There are two different syntax-tables.  The standard one declares
 ;; `_' as a symbol constituent, in the second one, it is a word
 ;; constituent.  For some search and replacing routines we
 ;; temporarily switch between the two.
 (setq ada-mode-syntax-table (make-syntax-table))
 (set-syntax-table  ada-mode-syntax-table)
-;; define string brackets (% is alternative string bracket)
+;; define string brackets (`%' is alternative string bracket, but
-(modify-syntax-entry ?%  "\"" ada-mode-syntax-table)
+;; almost never used as such and throws font-lock and indentation
+;; off the track.)
+(modify-syntax-entry ?%  "$" ada-mode-syntax-table)
 (modify-syntax-entry ?\" "\"" ada-mode-syntax-table)
 (modify-syntax-entry ?\#  "$" ada-mode-syntax-table)
 (modify-syntax-entry ?:  "." ada-mode-syntax-table)
 ;; and \f and \n end a comment
 (modify-syntax-entry ?\f  ">   " ada-mode-syntax-table)
 (modify-syntax-entry ?\n  ">   " ada-mode-syntax-table)
-;; define what belongs in ada symbols
+;; define what belongs in Ada symbols
 (modify-syntax-entry ?_ "_" ada-mode-syntax-table)
 ;; define parentheses to match
 (modify-syntax-entry ?\( "()" ada-mode-syntax-table)
 (modify-syntax-entry ?\) ")(" ada-mode-syntax-table)
 )
 ;;;###autoload
 (defun ada-mode ()
-"Ada Mode is the major mode for editing Ada code.
+"Ada mode is the major mode for editing Ada code.
 Bindings are as follows: (Note: 'LFD' is control-j.)
 Indent line                                          '\\[ada-tab]'
 Indent line, insert newline and indent the new line. '\\[newline-and-indent]'
 Fill comment paragraph                               '\\[ada-fill-comment-paragraph]'
 Fill comment paragraph and justify each line         '\\[ada-fill-comment-paragraph-justify]'
 Fill comment paragraph, justify and append postfix   '\\[ada-fill-comment-paragraph-postfix]'
-Next func/proc/task '\\[ada-next-procedure]'    Previous func/proc/task '\\[ada-previous-procedure]'
+Next func/proc/task '\\[ada-next-procedure]'  Previous func/proc/task '\\[ada-previous-procedure]'
 Next package        '\\[ada-next-package]'  Previous package        '\\[ada-previous-package]'
 Goto matching start of current 'end ...;'            '\\[ada-move-to-start]'
 Goto end of current block                            '\\[ada-move-to-end]'
 (setq parse-sexp-ignore-comments t)
 (make-local-variable 'case-fold-search)
 (setq case-fold-search t)
+(make-local-variable 'outline-regexp)
+(setq outline-regexp "[^\n\^M]")
+(make-local-variable 'outline-level)
+(setq outline-level 'ada-outline-level)
 (make-local-variable 'fill-paragraph-function)
 (setq fill-paragraph-function 'ada-fill-comment-paragraph)
+;;(make-local-variable 'adaptive-fill-regexp)
 (make-local-variable 'imenu-generic-expression)
 (setq imenu-generic-expression ada-imenu-generic-expression)
-(make-local-variable 'font-lock-defaults)
+(if (ada-xemacs) nil ; XEmacs uses properties
-(setq font-lock-defaults '((ada-font-lock-keywords
+(make-local-variable 'font-lock-defaults)
-			      ada-font-lock-keywords-1
+(setq font-lock-defaults
-			      ada-font-lock-keywords-2)
+'((ada-font-lock-keywords
-			     nil t
+ada-font-lock-keywords-1 ada-font-lock-keywords-2)
-			     ((?\_ . "w"))
+nil t
-			     beginning-of-line))
+((?\_ . "w")(?\. . "w"))
+beginning-of-line
+(font-lock-syntactic-keywords . ada-font-lock-syntactic-keywords)))
+;; Set up support for find-file.el.
+(make-variable-buffer-local 'ff-other-file-alist)
+(make-variable-buffer-local 'ff-search-directories)
+(setq ff-other-file-alist   'ada-other-file-alist
+ff-search-directories 'ada-search-directories
+ff-pre-load-hooks     'ff-which-function-are-we-in
+ff-post-load-hooks    'ff-set-point-accordingly
+ff-file-created-hooks 'ada-make-body))
 (setq major-mode 'ada-mode)
 (setq mode-name "Ada")
-(setq blink-matching-paren t)
 (use-local-map ada-mode-map)
 (if ada-mode-syntax-table
 (set-syntax-table ada-mode-syntax-table)
 ((eq ada-language-version 'ada95)
 (setq ada-keywords ada-95-keywords)))
 (if ada-auto-case
 (ada-activate-keys-for-case)))
+;;;--------------------------
+;;;  Compile support
+;;;--------------------------
+(defun ada-check-syntax ()
+"Check syntax of the current buffer.
+Uses the function `compile' to execute `ada-compiler-syntax-check'."
+(interactive)
+(let ((old-compile-command compile-command))
+(setq compile-command (concat ada-compiler-syntax-check
+(if (eq ada-language-version 'ada83)
+"-gnat83 ")
+" " ada-compile-options " "
+(buffer-name)))
+(setq compile-command (read-from-minibuffer
+"enter command for syntax check: "
+compile-command))
+(compile compile-command)
+;; restore old compile-command
+(setq compile-command old-compile-command)))
+(defun ada-make-local ()
+"Bring current Ada unit up-to-date.
+Uses the function `compile' to execute `ada-compile-make'."
+(interactive)
+(let ((old-compile-command compile-command))
+(setq compile-command (concat ada-compiler-make
+" " ada-make-options " "
+(buffer-name)))
+(setq compile-command (read-from-minibuffer
+"enter command for local make: "
+compile-command))
+(compile compile-command)
+;; restore old compile-command
+(setq compile-command old-compile-command)))
 ;;;--------------------------
 ;;;  Fill Comment Paragraph
 ;;;--------------------------
 (defun ada-call-pretty-printer ()
 "Calls the external Pretty Printer.
 The name is specified in `ada-external-pretty-print-program'.  Saves the
 current buffer in a directory specified by `ada-tmp-directory',
-starts the pretty printer as an external process on that file and then
+starts the pretty printer as external process on that file and then
 reloads the beautified program in the buffer and cleans up
 `ada-tmp-directory'."
 (interactive)
 (let ((filename-with-path buffer-file-name)
 (curbuf (current-buffer))
 ;;;---------------
 ;;;  auto-casing
 ;;;---------------
 ;; from Philippe Waroquiers <philippe@cfmu.eurocontrol.be>
-;; modifiedby RE and MH
+;; modified by RE and MH
 (defun ada-after-keyword-p ()
 ;; returns t if cursor is after a keyword.
 (save-excursion
 (forward-word -1)
 (= (point) (point-min))
 (backward-char 1))
 (not (looking-at "_")))     ; (MH)
 (looking-at (concat ada-keywords "[^_]")))))
-(defun ada-after-char-p ()
+(defun ada-in-char-const-p ()
-;; returns t if after ada character "'". This is interpreted as being
+;; Returns t if point is inside a character constant.
-;; in a character constant.
+;; We assume to be in a constant if the previous and the next character
+;; are "'".
 (save-excursion
-(if (> (point) 2)
+(if (> (point) 1)
-(progn
+(and
-(forward-char -2)
+(progn
-(looking-at "'"))
+(forward-char 1)
+(looking-at "'"))
+(progn
+(forward-char -2)
+(looking-at "'")))
 nil)))
 (defun ada-adjust-case (&optional force-identifier)
 "Adjust the case of the word before the just typed character.
 `ada-case-attribute'.
 If FORCE-IDENTIFIER is non-nil then also adjust keyword as identifier." ; (MH)
 (forward-char -1)
 (if (and (> (point) 1) (not (or (ada-in-string-p)
 (ada-in-comment-p)
-(ada-after-char-p))))
+(ada-in-char-const-p))))
 (if (eq (char-syntax (char-after (1- (point)))) ?w)
 	  (if (save-excursion
 		(forward-word -1)
 		(or (= (point) (point-min))
 		    (backward-char 1))
 (defun ada-activate-keys-for-case ()
 ;; save original keybindings to allow swapping ret/lfd
 ;; when casing is activated
 ;; the 'or ...' is there to be sure that the value will not
-;; be changed again when Ada Mode is called more than once (MH)
+;; be changed again when Ada mode is called more than once (MH)
 (or ada-ret-binding
 (setq ada-ret-binding (key-binding "\C-M")))
 (or ada-lfd-binding
 (setq ada-lfd-binding (key-binding "\C-j")))
 ;; call case modifying function after certain keys.
 ;;
 ;; added by MH
 ;;
 (defun ada-loose-case-word (&optional arg)
 "Capitalizes the first letter and the letters following `_'.
 ARG is ignored, it's there to fit the standard casing functions' style."
 (let ((pos (point))
 (first t))
 (skip-chars-backward "a-zA-Z0-9_")
 (while (or first
 (goto-char pos)))
 ;;
 ;; added by MH
+;; modified by JSH to handle attributes
 ;;
 (defun ada-adjust-case-region (from to)
 "Adjusts the case of all words in the region.
 Attention: This function might take very long for big regions !"
 (interactive "*r")
 (let ((begin nil)
 (end nil)
 (keywordp nil)
-(reldiff nil))
+(attribp nil))
 (unwind-protect
 	(save-excursion
 	  (set-syntax-table ada-mode-symbol-syntax-table)
 	  (goto-char to)
 	  ;;
-	  ;; loop: look for all identifiers and keywords
+	  ;; loop: look for all identifiers, keywords, and attributes
 	  ;;
 	  (while (re-search-backward
 		  "[^a-zA-Z0-9_]\\([a-zA-Z0-9_]+\\)[^a-zA-Z0-9_]"
 		  from
 		  t)
 	    ;;
 	    ;; print status message
 	    ;;
-	    (setq reldiff (- (point) from))
+	    (message "adjusting case ... %5d characters left" (- (point) from))
-	    (message "adjusting case ... %5d characters left"
+	    (setq attribp (looking-at "'[a-zA-Z0-9_]+[^']"))
-		     (- (point) from))
 	    (forward-char 1)
 	    (or
 	     ;; do nothing if it is a string or comment
 	     (ada-in-string-or-comment-p)
 	     (progn
 	       ;;
-	       ;; get the identifier or keyword
+	       ;; get the identifier or keyword or attribute
 	       ;;
 	       (setq begin (point))
 	       (setq keywordp (looking-at (concat ada-keywords "[^_]")))
 	       (skip-chars-forward "a-zA-Z0-9_")
 	       ;;
 	       ;; casing according to user-option
 	       ;;
 	       (if keywordp
 		   (funcall ada-case-keyword -1)
-		 (funcall ada-case-identifier -1))
+		 (if attribp
+		     (funcall ada-case-attribute -1)
+		   (funcall ada-case-identifier -1)))
 	       (goto-char begin))))
 	  (message "adjusting case ... done"))
 (set-syntax-table ada-mode-syntax-table))))
 ;;
 ;; added by MH
 ;;
 (defun ada-adjust-case-buffer ()
 "Adjusts the case of all words in the whole buffer.
-Attention: This function might take very long for big buffers !"
+ATTENTION: This function might take very long for big buffers !"
 (interactive "*")
 (ada-adjust-case-region (point-min) (point-max)))
 ;;;------------------------;;;
 ;;; Format Parameter Lists ;;;
 ;;;------------------------;;;
 (defun ada-format-paramlist ()
-"Reformats a parameter-list.
+"Reformats a parameter list.
-Attention:  1) Comments inside the list are killed !
+ATTENTION:  1) Comments inside the list are killed !
 2) If the syntax is not correct (especially, if there are
 semicolons missing), it can get totally confused !
 In such a case, use `undo', correct the syntax and try again."
 (interactive)
 	      (error "not in parameter list"))
 	  ;;
 	  ;; find start of current parameter-list
 	  ;;
 	  (ada-search-ignore-string-comment
-	   (concat ada-subprog-start-re "\\|\\<body\\>" ) t nil)
+(concat ada-subprog-start-re "\\|\\<body\\>" ) t nil)
 	  (ada-search-ignore-string-comment "(" nil nil t)
 	  (backward-char 1)
 	  (setq begin (point))
 	  ;;
 (while (looking-at "\\<\\(in\\|out\\|access\\)\\>")
 (forward-word 1)
 (ada-goto-next-non-ws))
 ;;
 ;; read type of parameter
 ;;
-(looking-at "\\<[a-zA-Z0-9_\\.]+\\>")
+(looking-at "\\<[a-zA-Z0-9_\\.\\']+\\>")
 (setq param
 (append param
 (list
 (buffer-substring (match-beginning 0)
 (match-end 0)))))
 (forward-line 1)
 	  (setq block-done (1+ block-done))
 	  (setq lines-remaining (1- lines-remaining)))
 ;; show line number where the error occurred
 (error
-(error "line %d: %s" (1+ (count-lines (point-min) (point))) err)))
+(error "line %d: %s" (1+ (count-lines (point-min) (point))) err) nil))
 (message "indenting ... done")))
 (defun ada-indent-newline-indent ()
 "Indents the current line, inserts a newline and then indents the new line."
 (interactive "*")
-(let ((column)
+(ada-indent-current)
-(orgpoint))
+(newline)
+(ada-indent-current))
-(ada-indent-current)
-(newline)
-(delete-horizontal-space)
-(setq orgpoint (point))
-(unwind-protect
-	(progn
-	  (set-syntax-table ada-mode-symbol-syntax-table)
-	  (setq column (save-excursion
-			 (funcall (ada-indent-function) orgpoint))))
-;;
-;; restore syntax-table
-;;
-(set-syntax-table ada-mode-syntax-table))
-(indent-to column)
-;; The following is needed to ensure that indentation will still be
-;; correct if something follows behind point when typing LFD
-;; For example: Imagine point to be there (*) when LFD is typed:
-;;              while cond loop
-;;                 null; *end loop;
-;; Result without the following statement would be:
-;;              while cond loop
-;;                 null;
-;;                *end loop;
-;; You would then have to type TAB to correct it.
-;; If that doesn't bother you, you can comment out the following
-;; statement to speed up indentation a LITTLE bit.
-(if (not (looking-at "[ \t]*$"))
-(ada-indent-current))
-))
 (defun ada-indent-current ()
 "Indents current line as Ada code.
 This works by two steps:
 		  (forward-line 1)
 		  (setq line-end (point))
 		  (setq prev-indent
 			(save-excursion
 			  (funcall (ada-indent-function) line-end))))
-	      (progn                    ; first line of buffer -> set indent
+(progn                    ; first line of buffer -> set indent
-		(beginning-of-line)     ; to 0
+(beginning-of-line)     ; to 0
-		(delete-horizontal-space)
+(delete-horizontal-space)
-		(setq prevline nil))))
+(setq prevline nil))))
 	  (if prevline
 	      ;;
 	      ;; we are not in the first accessible line in the buffer
 	      ;;
 		;;
 		;; second step
 		;;
 		(back-to-indentation)
 		(setq cur-indent (ada-get-current-indent prev-indent))
-		;; only reindent if indentation is different then the current
+;; only reindent if indentation is different then the current
-		(if (= (current-column) cur-indent)
+(if (= (current-column) cur-indent)
-		    nil
+nil
 		  (delete-horizontal-space)
-		  (indent-to cur-indent))
+(indent-to cur-indent))
 		;;
 		;; restore position of point
 		;;
 		(goto-char orgpoint)
 		(if (< (current-column) (current-indentation))
-(back-to-indentation))))))
+		    (back-to-indentation))))))
 ;;
 ;; restore syntax-table
 ;;
 (set-syntax-table ada-mode-syntax-table)))
 ;;
 ;; end
 ;;
 ((looking-at "\\<end\\>")
-(save-excursion
+(let ((label 0))
-(ada-goto-matching-start 1)
+(save-excursion
+(ada-goto-matching-start 1)
-;;
-;; found 'loop' => skip back to 'while' or 'for'
+;;
-;;                 if 'loop' is not on a separate line
+;; found 'loop' => skip back to 'while' or 'for'
-;;
+;;                 if 'loop' is not on a separate line
-(if (and
+;;
-(looking-at "\\<loop\\>")
+(if (and
-(save-excursion
+(looking-at "\\<loop\\>")
-(back-to-indentation)
+(save-excursion
-(not (looking-at "\\<loop\\>"))))
+(back-to-indentation)
-(if (save-excursion
+(not (looking-at "\\<loop\\>"))))
-(and
+(if (save-excursion
-(setq match-cons
+(and
-(ada-search-ignore-string-comment
+(setq match-cons
-ada-loop-start-re t nil))
+(ada-search-ignore-string-comment
-(not (looking-at "\\<loop\\>"))))
+ada-loop-start-re t nil))
-(goto-char (car match-cons))))
+(not (looking-at "\\<loop\\>"))))
+(progn
-(current-indentation)))
+(goto-char (car match-cons))
+(save-excursion
+(beginning-of-line)
+(if (looking-at ada-named-block-re)
+(setq label (- ada-label-indent)))))))
+(+ (current-indentation) label))))
 ;;
 ;; exception
 ;;
 ((looking-at "\\<exception\\>")
 (save-excursion
 ;;
 ((looking-at "\\<begin\\>")
 (save-excursion
 (if (ada-goto-matching-decl-start t)
 (current-indentation)
-(progn
+prev-indent)))
-(message "no matching declaration start")
-prev-indent))))
 ;;
 ;; is
 ;;
 ((looking-at "\\<is\\>")
 (if (and
 ;; line according to the previous statement, ignoring the contents
 ;; of the current line after point.  Moves point to the beginning of
 ;; the current statement, if NOMOVE is nil.
 (let ((orgpoint (point))
-(func nil)
+(func nil))
-(stmt-start nil))
 ;;
 ;; inside a parameter-list
 ;;
 (if (ada-in-paramlist-p)
 (setq func 'ada-get-indent-paramlist)
 (progn
 ;;
 ;; move to beginning of current statement
 ;;
 (if (not nomove)
-(setq stmt-start (ada-goto-stmt-start)))
+(ada-goto-stmt-start))
 ;;
 ;; no beginning found => don't change indentation
 ;;
 (if (and
 (eq orgpoint (point))
 (not nomove))
 (setq func 'ada-get-indent-nochange)
 (cond
 ;;
 ((and
 ada-indent-to-open-paren
 ((looking-at ada-loop-start-re)
 (setq func 'ada-get-indent-loop))
 ;;
 ((looking-at ada-subprog-start-re)
 (setq func 'ada-get-indent-subprog))
-;;
-((looking-at "\\<package\\>")
-(setq func 'ada-get-indent-subprog)) ; maybe it needs a
-; special function
-; sometimes ?
 ;;
 ((looking-at ada-block-start-re)
 (setq func 'ada-get-indent-block-start))
 ;;
 ((looking-at "\\<type\\>")
 ;; ---- functions to return indentation for special cases
 (defun ada-get-indent-open-paren (orgpoint)
 ;; Returns the indentation (column #) for the new line after ORGPOINT.
-;; Assumes point to be behind an open paranthesis not yet closed.
+;; Assumes point to be behind an open parenthesis not yet closed.
 (ada-in-open-paren-p))
 (defun ada-get-indent-nochange (orgpoint)
 ;; Returns the indentation (column #) of the current line.
 ;; Assumes point to be at the beginning of an end-statement.
 ;; Therefore it has to find the corresponding start. This can be a little
 ;; slow, if it has to search through big files with many nested blocks.
 ;; Signals an error if the corresponding block-start doesn't match.
 (let ((defun-name nil)
+(label 0)
 (indent nil))
 ;;
 ;; is the line already terminated by ';' ?
 ;;
 (if (save-excursion
 (if (looking-at "\\<\\(loop\\|record\\)\\>")
 (progn
 (forward-word 1)
 (ada-goto-stmt-start)))
 ;; a label ? => skip it
-(if (looking-at "[a-zA-Z0-9_]+[ \n\t]+:")
+(if (looking-at ada-named-block-re)
 (progn
+(setq label (- ada-label-indent))
 (goto-char (match-end 0))
 (ada-goto-next-non-ws)))
 ;; really looking-at the right thing ?
 (or (looking-at (concat "\\<\\("
 "loop\\|select\\|if\\|case\\|"
 (ada-search-ignore-string-comment
 (concat "\\<\\("
 "loop\\|select\\|if\\|case\\|"
 "record\\|while\\|type\\)\\>")))
 (backward-word 1))
-(current-indentation)))
+(+ (current-indentation) label)))
 ;;
 ;; a named block end
 ;;
 ((looking-at ada-ident-re)
 (setq defun-name (buffer-substring (match-beginning 0)
 (+ (current-indentation) ada-broken-indent))))
 (defun ada-get-indent-case (orgpoint)
 ;; Returns the indentation (column #) for the new line after ORGPOINT.
-;; Assumes point to be at the beginning of an case-statement.
+;; Assumes point to be at the beginning of a case-statement.
 (let ((cur-indent (current-indentation))
 (match-cons nil)
 (opos (point)))
 (cond
 ;;
 ;; case..is..when..=>
 ;;
 ((save-excursion
-(setq match-cons (ada-search-ignore-string-comment
+(setq match-cons (and
-"[ \t\n]+=>" nil orgpoint)))
+;; the `=>' must be after the keyword `is'.
+(ada-search-ignore-string-comment
+"\\<is\\>" nil orgpoint)
+(ada-search-ignore-string-comment
+"[ \t\n]+=>" nil orgpoint))))
 (save-excursion
 (goto-char (car match-cons))
 (if (not (ada-search-ignore-string-comment "\\<when\\>" t opos))
 (error "missing 'when' between 'case' and '=>'"))
 (+ (current-indentation) ada-indent)))
 ;; is there an 'is' in front of point ?
 ;;
 (if (save-excursion
 (setq match-cons
 (ada-search-ignore-string-comment
-"\\<is\\>\\|\\<do\\>" nil orgpoint)))
+"\\<\\(is\\|do\\)\\>" nil orgpoint)))
 ;;
 ;; yes, then skip to its end
 ;;
 (progn
 (setq foundis t)
 (defun ada-get-indent-noindent (orgpoint)
 ;; Returns the indentation (column #) for the new line after ORGPOINT.
 ;; Assumes point to be at the beginning of a 'noindent statement'.
-(if (save-excursion
+(let ((label 0))
-(ada-search-ignore-string-comment ";" nil orgpoint))
+(save-excursion
-(current-indentation)
+(beginning-of-line)
-(+ (current-indentation) ada-broken-indent)))
+(if (looking-at ada-named-block-re)
+(setq label (- ada-label-indent))))
+(if (save-excursion
+(ada-search-ignore-string-comment ";" nil orgpoint))
+(+ (current-indentation) label)
+(+ (current-indentation) ada-broken-indent label))))
 (defun ada-get-indent-label (orgpoint)
 ;; Returns the indentation (column #) for the new line after ORGPOINT.
 ;; Assumes point to be at the beginning of a label or variable declaration.
 ;;
 ;; declare label
 ;;
 ((save-excursion
 (setq match-cons (ada-search-ignore-string-comment
-"\\<declare\\>" nil orgpoint)))
+"\\<declare\\|begin\\>" nil orgpoint)))
 (save-excursion
 (goto-char (car match-cons))
 (+ (current-indentation) ada-indent)))
 ;;
 ;; complete statement following colon
 (defun ada-get-indent-loop (orgpoint)
 ;; Returns the indentation (column #) for the new line after ORGPOINT.
 ;; Assumes point to be at the beginning of a loop statement
 ;; or (unfortunately) also a for ... use statement.
 (let ((match-cons nil)
-(pos (point)))
+(pos (point))
+(label (save-excursion
+(beginning-of-line)
+(if (looking-at ada-named-block-re)
+(- ada-label-indent)
+0))))
 (cond
 ;;
 ;; statement complete
 ;;
 ((save-excursion
 (ada-search-ignore-string-comment ";" nil orgpoint))
-(current-indentation))
+(+ (current-indentation) label))
 ;;
 ;; simple loop
 ;;
 ((looking-at "loop\\>")
-(ada-get-indent-block-start orgpoint))
+(+ (ada-get-indent-block-start orgpoint) label))
 ;;
 ;; 'for'- loop (or also a for ... use statement)
 ;;
 ((looking-at "for\\>")
 ;;
 (if (not (save-excursion
 (back-to-indentation)
 (looking-at "\\<loop\\>")))
 (goto-char pos))
-(+ (current-indentation) ada-indent))
+(+ (current-indentation) ada-indent label))
 ;;
 ;; for-statement is broken
 ;;
 (t
-(+ (current-indentation) ada-broken-indent))))
+(+ (current-indentation) ada-broken-indent label))))
 ;;
 ;; 'while'-loop
 ;;
 ((looking-at "while\\>")
 ;;
 (if (not (save-excursion
 (back-to-indentation)
 (looking-at "\\<loop\\>")))
 (goto-char pos))
-(+ (current-indentation) ada-indent))
+(+ (current-indentation) ada-indent label))
-(+ (current-indentation) ada-broken-indent))))))
+(+ (current-indentation) ada-broken-indent label))))))
 (defun ada-get-indent-type (orgpoint)
 ;; Returns the indentation (column #) for the new line after ORGPOINT.
 ;; Assumes point to be at the beginning of a type statement.
 ;; nothing follows => it's the end-statement directly in
 ;;                    front of point => search again
 ;;
 (setq match-dat (ada-search-prev-end-stmt limit)))
 ;;
-;; if found the correct end-stetement => goto next non-ws
+;; if found the correct end-statement => goto next non-ws
 ;;
 (if match-dat
 (goto-char (cdr match-dat)))
 (ada-goto-next-non-ws))
 ;; Moves point to previous end-statement.  Returns a cons cell whose
 ;; car is the beginning and whose cdr the end of the match.
 ;; End-statements are defined by 'ada-end-stmt-re'.  Checks for
 ;; certain keywords if they follow 'end', which means they are no
 ;; end-statement there.
-(interactive) ;; DEBUG
 (let ((match-dat nil)
 (pos nil)
 (found nil))
 ;;
 ;; search until found or beginning-of-buffer
 (setq match-dat (ada-search-ignore-string-comment ada-end-stmt-re
 t
 limit)))
 (goto-char (car match-dat))
 (if (not (ada-in-open-paren-p))
 ;;
 ;; check if there is an 'end' in front of the match
 ;;
 (if (not (and
-(looking-at "\\<\\(record\\|loop\\|select\\)\\>")
+(looking-at
+"\\<\\(record\\|loop\\|select\\|else\\|then\\)\\>")
 (save-excursion
 (ada-goto-previous-word)
-(looking-at "\\<end\\>"))))
+(looking-at "\\<\\(end\\|or\\|and\\)\\>"))))
-(setq found t)
+(save-excursion
+(goto-char (cdr match-dat))
+(ada-goto-next-word)
+(if (not (looking-at "\\<\\(separate\\|new\\)\\>"))
+(setq found t)))
 (forward-word -1)))) ; end of loop
 (if found
 match-dat
 nil)))
 (if (ada-search-ignore-string-comment ada-end-stmt-re nil limit)
 (point)
 nil))
-(defun ada-goto-previous-word ()
+(defun ada-goto-next-word (&optional backward)
-;; Moves point to the beginning of the previous word of Ada code.
+;; Moves point to the beginning of the next word of Ada code.
+;; If BACKWARD is non-nil, jump to the beginning of the previous word.
 ;; Returns the new position of point or nil if not found.
 (let ((match-cons nil)
 (orgpoint (point)))
+(if (not backward)
+(skip-chars-forward "_a-zA-Z0-9\\."))
 (if (setq match-cons
-(ada-search-ignore-string-comment "[^ \t\n]" t nil t))
+(ada-search-ignore-string-comment "\\w" backward nil t))
 ;;
 ;; move to the beginning of the word found
 ;;
 (progn
-(goto-char (cdr match-cons))
+(goto-char (car match-cons))
 (skip-chars-backward "_a-zA-Z0-9")
 (point))
 ;;
 ;; if not found, restore old position of point
 ;;
 (progn
 (goto-char orgpoint)
 'nil))))
+(defun ada-goto-previous-word ()
+;; Moves point to the beginning of the previous word of Ada code.
+;; Returns the new position of point or nil if not found.
+(ada-goto-next-word t))
 (defun ada-check-matching-start (keyword)
 ;; Signals an error if matching block start is not KEYWORD.
 ;; Moves point to the matching block start.
 ;; Checks if the name of the matching defun really is DEFUN-NAME.
 ;; Assumes point to be already positioned by 'ada-goto-matching-start'.
 ;; Moves point to the beginning of the declaration.
 ;;
-;; 'accept' or 'package' ?
+;; named block without a `declare'
 ;;
-(if (not (looking-at "\\<\\(accept\\|package\\|task\\|protected\\)\\>"))
+(if (save-excursion
-(ada-goto-matching-decl-start))
+(ada-goto-previous-word)
-;;
+(looking-at (concat "\\<" defun-name "\\> *:")))
-;; 'begin' of 'procedure'/'function'/'task' or 'declare'
+t ; do nothing
 ;;
-(save-excursion
+;; 'accept' or 'package' ?
 ;;
-;; a named 'declare'-block ?
+(if (not (looking-at "\\<\\(accept\\|package\\|task\\|protected\\)\\>"))
-;;
+(ada-goto-matching-decl-start))
-(if (looking-at "\\<declare\\>")
+;;
-(ada-goto-stmt-start)
+;; 'begin' of 'procedure'/'function'/'task' or 'declare'
 ;;
-;; no, => 'procedure'/'function'/'task'/'protected'
+(save-excursion
 ;;
-(progn
+;; a named 'declare'-block ?
-(forward-word 2)
+;;
-(backward-word 1)
+(if (looking-at "\\<declare\\>")
+(ada-goto-stmt-start)
 ;;
-;; skip 'body' 'protected' 'type'
+;; no, => 'procedure'/'function'/'task'/'protected'
 ;;
-(if (looking-at "\\<\\(body\\|type\\)\\>")
+(progn
-(forward-word 1))
+(forward-word 2)
-(forward-sexp 1)
+(backward-word 1)
-(backward-sexp 1)))
+;;
-;;
+;; skip 'body' 'type'
-;; should be looking-at the correct name
+;;
-;;
+(if (looking-at "\\<\\(body\\|type\\)\\>")
-(if (not (looking-at (concat "\\<" defun-name "\\>")))
+(forward-word 1))
-	(error "matching defun has different name: %s"
+(forward-sexp 1)
-	       (buffer-substring (point)
+(backward-sexp 1)))
-				 (progn (forward-sexp 1) (point)))))))
+;;
+;; should be looking-at the correct name
+;;
+(if (not (looking-at (concat "\\<" defun-name "\\>")))
+(error "matching defun has different name: %s"
+(buffer-substring (point)
+(progn (forward-sexp 1) (point))))))))
 (defun ada-goto-matching-decl-start (&optional noerror nogeneric)
 ;; Moves point to the matching declaration start of the current 'begin'.
 ;; If NOERROR is non-nil, it only returns nil if no match was found.
-(interactive) ;; DEBUG
 (let ((nest-count 1)
 (pos nil)
 (first t)
 (flag nil))
 ;;
 (setq nest-count (1- nest-count))
 (setq first nil))
 ;;
 ((looking-at "is")
 ;; check if it is only a type definition, but not a protected
-	;; type definition, which should be handled like a procedure.
+;; type definition, which should be handled like a procedure.
-(if (save-excursion
+(if (or (looking-at "is +<>")
-(ada-goto-previous-word)
+(save-excursion
-(skip-chars-backward "a-zA-Z0-9_.'")
+(ada-goto-previous-word)
-(if (save-excursion
+(skip-chars-backward "a-zA-Z0-9_.'")
-(backward-char 1)
+(if (save-excursion
-(looking-at ")"))
+(backward-char 1)
-(progn
+(looking-at ")"))
-(forward-char 1)
+(progn
-(backward-sexp 1)
+(forward-char 1)
-(skip-chars-backward "a-zA-Z0-9_.'")
+(backward-sexp 1)
-))
+(skip-chars-backward "a-zA-Z0-9_.'")
-(ada-goto-previous-word)
+))
-(and
+(ada-goto-previous-word)
-(looking-at "\\<type\\>")
+(and
-(save-match-data
+(looking-at "\\<type\\>")
-(ada-goto-previous-word)
+(save-match-data
-(not (looking-at "\\<protected\\>"))))
+(ada-goto-previous-word)
-); end of save-excursion
+(not (looking-at "\\<protected\\>"))))
+)); end of `or'
 (goto-char (match-beginning 0))
 (progn
 (setq nest-count (1- nest-count))
 (setq first nil))))
 ;; check if declaration-start is really found
 (if (not
 (and
 (zerop nest-count)
 (not flag)
-(progn
+(if (looking-at "is")
-(if (looking-at "is")
+(ada-search-ignore-string-comment ada-subprog-start-re t)
-(ada-search-ignore-string-comment
+(looking-at "declare\\|generic"))))
-ada-subprog-start-re t)
-(looking-at "declare\\|generic")))))
 (if noerror nil
-	  (error "no matching proc/func/task/declare/package/protected"))
+(error "no matching proc/func/task/declare/package/protected"))
 t)))
 (defun ada-goto-matching-start (&optional nest-level noerror gotothen)
 ;; Moves point to the beginning of a block-start.  Which block
 (save-excursion
 ;;
 ;; check if keyword follows 'end'
 ;;
 (ada-goto-previous-word)
-(if (looking-at "\\<end\\>")
+(if (looking-at "\\<end\\> *[^;]")
 ;; it ends a block => increase nest depth
 (progn
 (setq nest-count (1+ nest-count))
 (setq pos (point)))
 ;; it starts a block => decrease nest depth
 (save-excursion (end-of-line) (= (point-max) (point)))))
 (defun ada-in-comment-p ()
 ;; Returns t if inside a comment.
-;;  (save-excursion (and (re-search-backward "\\(--\\|\n\\)" nil 1)
-;;                       (looking-at "-"))))
 (nth 4 (parse-partial-sexp
 (save-excursion (beginning-of-line) (point))
 (point))))
 (defun ada-in-string-p ()
 ;; Returns t if point is inside a string
 ;; (Taken from pascal-mode.el, modified by MH).
 (save-excursion
 (beginning-of-line)
 (point)) (point)))
 ;; check if 'string quote' is only a character constant
 (progn
-(re-search-backward "\"" nil t) ; # not a string delimiter anymore
+(re-search-backward "\"" nil t) ; `#' is not taken as a string delimiter
 (not (= (char-after (1- (point))) ?'))))))
 (defun ada-in-string-or-comment-p ()
-;; Returns t if point is inside a string or a comment.
+;; Returns t if point is inside a string, a comment, or a character constant.
-(or (ada-in-comment-p)
+(let ((parse-result (parse-partial-sexp
-(ada-in-string-p)))
+(save-excursion (beginning-of-line) (point)) (point))))
+(or ;; in-comment-p
+(nth 4 parse-result)
+;; in-string-p
+(and
+(nth 3 parse-result)
+;; check if 'string quote' is only a character constant
+(progn
+(re-search-backward "\"" nil t) ; `#' not regarded a string delimiter
+(not (= (char-after (1- (point))) ?'))))
+;; in-char-const-p
+(ada-in-char-const-p))))
 (defun ada-in-paramlist-p ()
 ;; Returns t if point is inside a parameter-list
 ;; following 'function'/'procedure'/'package'.
 ;; not really a boolean function ...
 (defun ada-in-open-paren-p ()
 ;; If point is somewhere behind an open parenthesis not yet closed,
 ;; it returns the column # of the first non-ws behind this open
 ;; parenthesis, otherwise nil."
+(let ((start (if (<= (point) ada-search-paren-char-count-limit)
-(let ((start (if (< (point) ada-search-paren-char-count-limit)
+(point-min)
-1
+(save-excursion
-(- (point) ada-search-paren-char-count-limit)))
+(goto-char (- (point) ada-search-paren-char-count-limit))
+(beginning-of-line)
+(point))))
 parse-result
 (col nil))
 (setq parse-result (parse-partial-sexp start (point)))
 (if (nth 1 parse-result)
 (save-excursion
 ((eq ada-tab-policy 'always-tab) (error "not implemented"))
 ))
 (defun ada-indent-current-function ()
-"Ada Mode version of the indent-line-function."
+"Ada mode version of the indent-line-function."
 (interactive "*")
 (let ((starting-point (point-marker)))
 (ada-beginning-of-line)
 (ada-tab)
 (if (< (point) starting-point)
 "remove trailing spaces in the whole buffer."
 (interactive)
 (save-match-data
 (save-excursion
 (save-restriction
-	(widen)
+(widen)
-	(goto-char (point-min))
+(goto-char (point-min))
-	(while (re-search-forward "[ \t]+$" (point-max) t)
+(while (re-search-forward "[ \t]+$" (point-max) t)
-	  (replace-match "" nil nil))))))
+(replace-match "" nil nil))))))
 (defun ada-untabify-buffer ()
 ;; change all tabs to spaces
 (save-excursion
-(untabify (point-min) (point-max))))
+(untabify (point-min) (point-max))
+nil))
 (defun ada-uncomment-region (beg end)
 "delete `comment-start' at the beginning of a line in the region."
 (interactive "r")
 (defun ada-ff-other-window ()
 "Find other file in other window using `ff-find-other-file'."
 (interactive)
 (and (fboundp 'ff-find-other-file)
 (ff-find-other-file t)))
+;; inspired by Laurent.GUERBY@enst-bretagne.fr
+(defun ada-gnat-style ()
+"Clean up comments, `(' and `,' for GNAT style checking switch."
+(interactive)
+(save-excursion
+(goto-char (point-min))
+(while (re-search-forward "-- ?\\([^ -]\\)" nil t)
+(replace-match "--  \\1"))
+(goto-char (point-min))
+(while (re-search-forward "\\>(" nil t)
+(replace-match " ("))
+(goto-char (point-min))
+(while (re-search-forward ",\\<" nil t)
+(replace-match ", "))
+))
 ;;;-------------------------------;;;
 ;;; Moving To Procedures/Packages ;;;
 ;;;-------------------------------;;;
 (define-key ada-mode-map "\C-c\C-a" 'ada-move-to-start)
 (define-key ada-mode-map "\C-c\C-e" 'ada-move-to-end)
 ;; Compilation
 (define-key ada-mode-map "\C-c\C-c" 'compile)
+(define-key ada-mode-map "\C-c\C-v" 'ada-check-syntax)
+(define-key ada-mode-map "\C-c\C-m" 'ada-make-local)
 ;; Casing
 (define-key ada-mode-map "\C-c\C-r" 'ada-adjust-case-region)
 (define-key ada-mode-map "\C-c\C-b" 'ada-adjust-case-buffer)
+(define-key ada-mode-map "\177"     'backward-delete-char-untabify)
 ;; Use predefined function of emacs19 for comments (RE)
 (define-key ada-mode-map "\C-c;"    'comment-region)
 (define-key ada-mode-map "\C-c:"    'ada-uncomment-region)
 ;; Change basic functionality
-;; `substitute-key-definition' is not defined equally in GNU Emacs
+;; `substitute-key-definition' is not defined equally in Emacs
 ;; and XEmacs, you cannot put in an optional 4th parameter in
 ;; XEmacs.  I don't think it's necessary, so I leave it out for
-;; GNU Emacs as well.  If you encounter any problems with the
+;; Emacs as well.  If you encounter any problems with the
 ;; following three functions, please tell me. RE
 (mapcar (function (lambda (pair)
 			  (substitute-key-definition (car pair) (cdr pair)
 						     ada-mode-map)))
 	      '((beginning-of-line      . ada-beginning-of-line)
 		(end-of-line            . ada-end-of-line)
 		(forward-to-indentation . ada-forward-to-indentation)
 		))
-;; else GNU Emacs
+;; else Emacs
 ;;(mapcar (lambda (pair)
 ;;             (substitute-key-definition (car pair) (cdr pair)
 ;;				   ada-mode-map global-map))
 ))
 ;;;-------------------
 (require 'easymenu)
 (defun ada-add-ada-menu ()
-"Adds the menu 'Ada' to the menu bar in Ada Mode."
+"Adds the menu 'Ada' to the menu bar in Ada mode."
 (easy-menu-define ada-mode-menu ada-mode-map "Menu keymap for Ada mode."
 '("Ada"
 ["Next Package" ada-next-package t]
 ["Previous Package" ada-previous-package t]
 ["Next Procedure" ada-next-procedure t]
 ["Adjust Case Buffer" ada-adjust-case-buffer t]
 ["----------" nil nil]
 ["Comment   Region" comment-region t]
 ["Uncomment Region" ada-uncomment-region t]
 ["----------------" nil nil]
-["Compile" compile (fboundp 'compile)]
+["Global Make" compile (fboundp 'compile)]
+["Local Make" ada-make-local t]
+["Check Syntax" ada-check-syntax t]
 ["Next Error" next-error (fboundp 'next-error)]
 ["---------------" nil nil]
 ["Index" imenu (fboundp 'imenu)]
 ["--------------" nil nil]
 ["Other File Other Window" ada-ff-other-window
 (fboundp 'ff-find-other-file)]
 ["Other File" ff-find-other-file
 (fboundp 'ff-find-other-file)]))
 (if (ada-xemacs) (progn
 (easy-menu-add ada-mode-menu)
-(setq mode-popup-menu (cons "Ada Mode" ada-mode-menu)))))
+(setq mode-popup-menu (cons "Ada mode" ada-mode-menu)))))
 ;;;-------------------------------
 ;;; Define Some Support Functions
 ((eq ada-tab-policy 'indent-af) (af-forward-to-indentation arg))
 (t (forward-to-indentation arg))
 ))
 ;;;---------------------------------------------------
-;;; support for find-file
+;;; support for find-file.el
 ;;;---------------------------------------------------
 ;;;###autoload
 (defun ada-make-filename-from-adaname (adaname)
 "Determine the filename of a package/procedure from its own Ada name."
-;; this is done simply by calling gkrunch, when we work with GNAT. It
+;; this is done simply by calling `gnatkr', when we work with GNAT. It
 ;; must be a more complex function in other compiler environments.
 (interactive "s")
-;; things that should really be done by the external process
-;; since gnat-2.0, gnatk8 can do these things. If you still use a
-;; previous version, just uncomment the following lines.
 (let (krunch-buf)
 (setq krunch-buf (generate-new-buffer "*gkrunch*"))
 (save-excursion
 (set-buffer krunch-buf)
-;      (insert (downcase adaname))
+;; send adaname to external process `gnatkr'.
-;      (goto-char (point-min))
+(call-process "gnatkr" nil krunch-buf nil
-;      (while (search-forward "." nil t)
-;        (replace-match "-" nil t))
-;      (setq adaname (buffer-substring (point-min)
-;                                      (progn
-;                                        (goto-char (point-min))
-;                                        (end-of-line)
-;                                        (point))))
-;      ;; clean the buffer
-;      (delete-region (point-min) (point-max))
-;; send adaname to external process "gnatk8"
-(call-process "gnatk8" nil krunch-buf nil
 adaname ada-krunch-args)
 ;; fetch output of that process
 (setq adaname (buffer-substring
 (point-min)
 (progn
 						   (match-end 0)))
 	))))
 ;;;---------------------------------------------------
-;;; support for imenu
-;;;---------------------------------------------------
-(defun imenu-create-ada-index (&optional regexp)
-"Create index alist for Ada files."
-(let ((index-alist '())
-prev-pos char)
-(goto-char (point-min))
-;(imenu-progress-message prev-pos 0)
-;; Search for functions/procedures
-(save-match-data
-(while (re-search-forward
-(or regexp ada-procedure-start-regexp)
-nil t)
-;(imenu-progress-message prev-pos)
-;; do not store forward definitions
-;; right now we store them. We want to avoid them only in
-;; package bodies, not in the specs!! ???RE???
-(save-match-data
-;        (if (not (looking-at (concat
-;                              "[ \t\n]*" ; WS
-;                              "\([^)]+\)" ; parameterlist
-;                              "\\([ \n\t]+return[ \n\t]+"; potential return
-;                              "[a-zA-Z0-9_\\.]+\\)?"
-;                              "[ \t]*" ; WS
-;                              ";"  ;; THIS is what we really look for
-;                              )))
-;            ; (push (imenu-example--name-and-position) index-alist)
-(setq index-alist (cons (imenu-example--name-and-position)
-index-alist))
-;          )
-	)
-;(imenu-progress-message 100)
-))
-(nreverse index-alist)))
-;;;---------------------------------------------------
 ;;; support for font-lock
 ;;;---------------------------------------------------
-;; Strings are a real pain in Ada because both ' and " can appear in a
+;; Strings are a real pain in Ada because a single quote character is
-;; non-string quote context (the former as an operator, the latter as
+;; overloaded as a string quote and type/instance delimiter.  By default, a
-;; a character string).  We follow the least losing solution, in which
+;; single quote is given punctuation syntax in `ada-mode-syntax-table'.
-;; only " is a string quote.  Therefore a character string of the form
+;; So, for Font Lock mode purposes, we mark single quotes as having string
-;; '"' will throw fontification off on the wrong track.
+;; syntax when the gods that created Ada determine them to be.  sm.
+(defconst ada-font-lock-syntactic-keywords
+;; Mark single quotes as having string quote syntax in 'c' instances.
+'(("\\(\'\\).\\(\'\\)" (1 (7 . ?\')) (2 (7 . ?\')))))
 (defconst ada-font-lock-keywords-1
 (list
+;;
+;; handle "type T is access function return S;"
+;;
+(list "\\<\\(function[ \t]+return\\)\\>" '(1 font-lock-keyword-face) )
 ;;
 ;; accept, entry, function, package (body), protected (body|type),
 ;; pragma, procedure, task (body) plus name.
 (list (concat
 	  "\\<\\("
 	  "accept\\|"
 	  "entry\\|"
-	  "function\\|"
+"function\\|"
-	  "package[ \t]+body\\|"
+"package[ \t]+body\\|"
-	  "package\\|"
+"package\\|"
-	  "pragma\\|"
+"pragma\\|"
-	  "procedure\\|"
+"procedure\\|"
-	  "protected[ \t]+body\\|"
+"protected[ \t]+body\\|"
-	  "protected[ \t]+type\\|"
+"protected[ \t]+type\\|"
-	  "protected\\|"
+"protected\\|"
 ;;	  "p\\(\\(ackage\\|rotected\\)\\(\\|[ \t]+\\(body\\|type\\)\\)\
 ;;\\|r\\(agma\\|ocedure\\)\\)\\|"
-	  "task\\|"
 	  "task[ \t]+body\\|"
-	  "task[ \t]+type"
+	  "task[ \t]+type\\|"
+	  "task"
 ;;	  "task\\(\\|[ \t]+body\\)"
 	  "\\)\\>[ \t]*"
 	  "\\(\\sw+\\(\\.\\sw*\\)*\\)?")
 '(1 font-lock-keyword-face) '(2 font-lock-function-name-face nil t)))
 "Subdued level highlighting for Ada mode.")
 "l\\(iased\\|l\\)\\|nd\\|rray\\|t\\)\\|begin\\|case\\|"
 "d\\(e\\(clare\\|l\\(ay\\|ta\\)\\)\\|igits\\|o\\)\\|"
 "e\\(ls\\(e\\|if\\)\\|ntry\\|x\\(ception\\|it\\)\\)\\|for\\|"
 "generic\\|i[fns]\\|l\\(imited\\|oop\\)\\|mod\\|n\\(ot\\|ull\\)\\|"
 "o\\(r\\|thers\\|ut\\)\\|pr\\(ivate\\|otected\\)\\|"
-"r\\(ange\\|e\\(cord\\|m\\|names\\|queue\\|turn\\|verse\\)\\)\\|"
+"r\\(a\\(ise\\|nge\\)\\|e\\(cord\\|m\\|names\\|queue\\|turn\\|verse\\)\\)\\|"
 "se\\(lect\\|parate\\)\\|"
 "t\\(agged\\|erminate\\|hen\\)\\|until\\|" ; task removed
 	    "wh\\(ile\\|en\\)\\|xor" ; "when" added
 "\\)\\>")
 ;;
 ;; Anything following end and not already fontified is a body name.
-'("\\<\\(end\\)\\>[ \t]+\\([a-zA-Z0-9_\\.]+\\)?"
+'("\\<\\(end\\)\\>\\([ \t]+\\)?\\([a-zA-Z0-9_\\.]+\\)?"
-(1 font-lock-keyword-face) (2 font-lock-function-name-face nil t))
+(1 font-lock-keyword-face) (3 font-lock-function-name-face nil t))
 ;;
 ;; Variable name plus optional keywords followed by a type name.  Slow.
 ;    (list (concat "\\<\\(\\sw+\\)\\>[ \t]*:?[ \t]*"
 ;                 "\\(access\\|constant\\|in\\|in[ \t]+out\\|out\\)?[ \t]*"
 ;                 "\\(\\sw+\\)?")
 ;         '(1 font-lock-variable-name-face)
 ;         '(2 font-lock-keyword-face nil t) '(3 font-lock-type-face nil t))
 ;;
 ;; Optional keywords followed by a type name.
 (list (concat ; ":[ \t]*"
-"\\<\\(access\\|constant\\|in\\|in[ \t]+out\\|out\\)\\>"
+"\\<\\(access\\|constant\\|in[ \t]+out\\|in\\|out\\)\\>"
 "[ \t]*"
 "\\(\\sw+\\)?")
 '(1 font-lock-keyword-face nil t) '(2 font-lock-type-face nil t))
 ;;
 ;; Keywords followed by a type or function name.
 ;; Goto tags.
 '("<<\\(\\sw+\\)>>" 1 font-lock-reference-face)
 ))
 "Gaudy level highlighting for Ada mode.")
-;; XEmacs change
+(defvar ada-font-lock-keywords ada-font-lock-keywords-1
-(defvar ada-font-lock-keywords (if font-lock-maximum-decoration
+"Default expressions to highlight in Ada mode.")
-				   ada-font-lock-keywords-2
-				 ada-font-lock-keywords-1)
-"Default Expressions to highlight in Ada mode.
+;; set font-lock properties for XEmacs
-See the doc to `font-lock-maximum-decoration' for user configuration.")
+(if (ada-xemacs)
+(put 'ada-mode 'font-lock-defaults
-;; XEmacs change
+'(ada-font-lock-keywords
-(put 'ada-mode 'font-lock-defaults
+nil t ((?\_ . "w")(?\. . "w")) beginning-of-line)))
-		'(ada-font-lock-keywords nil t ((?\_ . "w"))))
 ;;;
-;;; ????
+;;; support for outline
+;;;
+;; used by outline-minor-mode
+(defun ada-outline-level ()
+(save-excursion
+(skip-chars-forward "\t ")
+(current-column)))
+;;;
+;;; generate body
 ;;;
 (defun ada-gen-comment-until-proc ()
 ;; comment until spec of a procedure or a function.
 (forward-line 1)
 (set-mark-command (point))

Mercurial > hg > xemacs-beta

comparison lisp/modes/ada-mode.el @ 189:489f57a838ef r20-3b21