-;;; ada-mode.el - An Emacs major-mode for editing Ada source.
-;;; Copyright (C) 1994 Free Software Foundation, Inc.
+;;; ada-mode.el --- An Emacs major-mode for editing Ada source.
-;;; Authors: Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de>
-;;; Rolf Ebert <ebert@inf.enst.fr>
+;; Copyright (C) 1994, 1995, 1997 Free Software Foundation, Inc.
-;;; This file is part of GNU Emacs.
+;; Authors: Rolf Ebert <re@waporo.muc.de>
+;; Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de>
+;; Keywords: languages oop ada
+;; Rolf Ebert's version: 2.27
+
+;; This file is part of GNU Emacs.
;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
;;; This mode is a complete rewrite of a major mode for editing Ada 83
-;;; and Ada 94 source code under Emacs-19. It contains completely new
+;;; and Ada 95 source code under Emacs-19. It contains completely new
;;; indenting code and support for code browsing (see ada-xref).
;;; USAGE
;;; =====
-;;; If you have modified your startup file as described above, emacs
-;;; should enter ada-mode when you load an ada source into emacs.
+;;; 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:
;;; HISTORY
;;; =======
-;;; The first Ada mode for GNU Emacs was written by V. Bowman in
-;;; 1985. He based his work on the already existing Modula-2 mode. The
-;;; file is called ada.el and is currently distributed with Emacs.
+;;; The first Ada mode for GNU Emacs was written by V. Broman in
+;;; 1985. He based his work on the already existing Modula-2 mode.
+;;; This was distributed as ada.el in versions of Emacs prior to 19.29.
;;;
;;; Lynn Slater wrote an extensive Ada mode in 1989. It consisted of
;;; several files with support for dired commands and other nice
;;; 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.
-;;; KNOWN BUGS / BUGREPORTS
-;;; =======================
+;;; KNOWN BUGS
+;;; ==========
;;;
;;; In the presence of comments and/or incorrect syntax
;;; ada-format-paramlist produces weird results.
-;;;
-;;; Indentation is sometimes wrong at the very beginning of the buffer.
-;;; So please try it on different locations. If it's still wrong then
-;;; report the bug.
-;;;
-;;; At the moment the browsing functions are limited to the use of the
-;;; separate packages "find-file.el" and "ada-xref.el" (ada-xref.el is
-;;; only for GNAT users).
-;;;
-;;; indenting of some tasking constructs is not yet supported.
-;;;
-;;; `reformat-region' sometimes generates some weird indentation.
-;;;
-;;;> I have the following suggestions for the function template: 1) I
-;;;> don't want it automatically assigning it a name for the return variable. I
-;;;> never want it to be called "Result" because that is nondescriptive. If you
-;;;> must define a variable, give me the ability to specify its name.
-;;;>
-;;;> 2) You do not provide a type for variable 'Result'. Its type is the same
-;;;> as the function's return type, which the template knows, so why force me
-;;;> to type it in?
-;;;>
-
-;;;As alwyas, different users have different tastes.
-;;;It would be nice if one could configure such layout details separately
-;;;without patching the LISP code. Maybe the metalanguage used in ada-stmt.el
-;;;could be taken even further, providing the user with some nice syntax
-;;;for describing layout. Then my own hacks would survive the next
-;;;update of the package :-)
-
-;;;By the way, there are som more quirks:
-
-;;;1) text entered in prompt mode (*) is not converted to upper case (I have
-;;; choosen upper case for indentifiers).
-;;; (*) I would like to suggest the term "template code" instead of
-;;; "pseudo code".
-
-;;; There are quite a few problems in the crossreferencing part. These
-;;; are partly due to errors in gnatf. One of the major bugs in
-;;; ada-xref is, that we do not wait for gnatf to rebuild the xref file.
-;;; We start the job, but do not wait for finishing.
-
-
-;;; LCD Archive Entry:
-;;; ada-mode|Rolf Ebert|<ebert@inf.enst.fr>
-;;; |Major-mode for Ada
-;;; |$Date: 1995/02/09 00:01:34 $|$Revision: 1.1 $|
+;;; -------------------
+;;; 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'('"');
+;;; -------------------
-\f
-(defconst ada-mode-version (substring "$Revision: 1.1 $" 11 -2)
- "$Id: ada-mode.el,v 1.1 1995/02/09 00:01:34 rms Exp rms $
-Report bugs to: Rolf Ebert <ebert@inf.enst.fr>")
+;;; TODO
+;;; ====
+;;;
+;;; o bodify-single-subprogram
+;;; o make a function "separate" and put it in the corresponding file.
+
+;;; CREDITS
+;;; =======
+;;;
+;;; Many thanks to
+;;; Philippe Waroquiers (PW) <philippe@cfmu.eurocontrol.be> in particular,
+;;; woodruff@stc.llnl.gov (John Woodruff)
+;;; jj@ddci.dk (Jesper Joergensen)
+;;; gse@ocsystems.com (Scott Evans)
+;;; comar@LANG8.CS.NYU.EDU (Cyrille Comar)
+;;; and others for their valuable hints.
+\f
;;;--------------------
;;; USER OPTIONS
;;;--------------------
+
+;; ---- customize support
+
+(defgroup ada nil
+ "Major mode for editing Ada source in Emacs"
+ :group 'languages)
+
;; ---- configure indentation
-(defvar ada-indent 3
- "*Defines the size of Ada indentation.")
+(defcustom ada-indent 3
+ "*Defines the size of Ada indentation."
+ :type 'integer
+ :group 'ada)
-(defvar ada-broken-indent 2
- "*# of columns to indent the continuation of a broken line.")
+(defcustom ada-broken-indent 2
+ "*# of columns to indent the continuation of a broken line."
+ :type 'integer
+ :group 'ada)
-(defvar ada-label-indent -4
- "*# of columns to indent a label.")
+(defcustom ada-label-indent -4
+ "*# of columns to indent a label."
+ :type 'integer
+ :group 'ada)
-(defvar ada-stmt-end-indent 0
+(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
+ :group 'ada)
-(defvar ada-when-indent 3
- "*Defines the indentation for 'when' relative to 'exception' or 'case'.")
+(defcustom ada-when-indent 3
+ "*Defines the indentation for 'when' relative to 'exception' or 'case'."
+ :type 'integer
+ :group 'ada)
-(defvar ada-indent-record-rel-type 3
- "*Defines the indentation for 'record' relative to 'type' or 'use'.")
+(defcustom ada-indent-record-rel-type 3
+ "*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-comment-as-code t
+ "*If non-nil, comment-lines get indented as Ada code."
+ :type 'boolean
+ :group 'ada)
-(defvar ada-indent-is-separate t
- "*If non-nil, 'is separate' or 'is abstract' on a separate line are
-indented.")
+(defcustom ada-indent-is-separate t
+ "*If non-nil, 'is separate' or 'is abstract' on a single line are indented."
+ :type 'boolean
+ :group 'ada)
-(defvar ada-indent-to-open-paren t
- "*If non-nil, following lines get indented according to the innermost
-open parenthesis.")
+(defcustom ada-indent-to-open-paren t
+ "*If non-nil, indent according to the innermost open parenthesis."
+ :type 'boolean
+ :group 'ada)
-(defvar ada-search-paren-line-count-limit 5
- "*Search that many non-blank non-comment lines for an open parenthesis.
-Values higher than about 5 horribly slow down the indenting.")
+(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.")
-
-(defvar ada-move-to-declaration nil
- "*If non-nil, ada-move-to-start moves point to the subprog-declaration,
-not to 'begin'.")
-
-(defvar ada-spec-suffix ".ads"
- "*Suffix of Ada specification files.")
-
-(defvar ada-body-suffix ".adb"
- "*Suffix of Ada body files.")
-
-(defvar ada-language-version 'ada94
- "*Do we program in 'ada83 or 'ada94?")
-
-(defvar ada-case-keyword 'downcase-word
- "*downcase-word, upcase-word, ada-loose-case-word or capitalize-word
-to adjust ada keywords case.")
-
-(defvar ada-case-identifier 'ada-loose-case-word
- "*downcase-word, upcase-word, ada-loose-case-word or capitalize-word
-to adjust ada identifier case.")
-
-(defvar ada-auto-case t
- "*Non-nil automatically changes casing of preceeding word while typing.
-Casing is done according to ada-case-keyword and ada-case-identifier.")
-
-(defvar ada-clean-buffer-before-saving nil
- "*If non-nil, remove-trailing-spaces and untabify buffer before saving.")
+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."
+ :type '(choice (const indent-auto)
+ (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'."
+ :type 'boolean
+ :group 'ada)
+
+(defcustom ada-spec-suffix ".ads"
+ "*Suffix of Ada specification files."
+ :type 'string
+ :group 'ada)
+
+(defcustom ada-body-suffix ".adb"
+ "*Suffix of Ada body files."
+ :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'."
+ :type '(choice (const downcase-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'."
+ :type '(choice (const downcase-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'."
+ :type '(choice (const downcase-word)
+ (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-case-attribute'."
+ :type 'boolean
+ :group 'ada)
+
+(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"
- "*External pretty printer to call from within Ada Mode.")
-
-(defvar ada-tmp-directory "/tmp/"
- "*Directory to store the temporary file for the Ada pretty printer.")
-
-(defvar ada-fill-comment-prefix "-- "
- "*This is inserted in the first columns when filling a comment paragraph.")
-
-(defvar ada-fill-comment-postfix " --"
- "*This is inserted at the end of each line when filling a comment paragraph
-with ada-fill-comment-paragraph postfix.")
-
-(defvar ada-krunch-args "250"
- "*Argument of gnatk8, a string containing the max number of characters.
-Set to a big number, if you dont use crunched filenames.")
+(defcustom ada-external-pretty-print-program "aimap"
+ "*External pretty printer to call from within Ada mode."
+ :type 'string
+ :group 'ada)
+
+(defcustom ada-tmp-directory "/tmp/"
+ "*Directory to store the temporary file for the Ada pretty printer."
+ :type 'string
+ :group 'ada)
+
+(defcustom ada-compile-options "-c"
+ "*Buffer local options passed to the Ada compiler.
+These options are used when the compiler is invoked on the current buffer."
+ :type 'string
+ :group 'ada)
+(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
\f
(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
+ "Syntax table for Ada, where `_' is a word constituent.")
+
(defconst ada-83-keywords
"\\<\\(abort\\|abs\\|accept\\|access\\|all\\|and\\|array\\|\
at\\|begin\\|body\\|case\\|constant\\|declare\\|delay\\|delta\\|\
private\\|procedure\\|raise\\|range\\|record\\|rem\\|renames\\|\
return\\|reverse\\|select\\|separate\\|subtype\\|task\\|terminate\\|\
then\\|type\\|use\\|when\\|while\\|with\\|xor\\)\\>"
- "regular expression for looking at Ada83 keywords.")
-
-(defconst ada-94-keywords
+; "\\<\\(a\\(b\\(ort\\|s\\)\\|cce\\(pt\\|ss\\)\\|ll\\|nd\\|rray\\|t\\)\\|\
+;b\\(egin\\|ody\\)\\|c\\(ase\\|onstant\\)\\|\
+;d\\(e\\(clare\\|l\\(ay\\|ta\\)\\)\\|igits\\|o\\)\\|\
+;e\\(ls\\(e\\|if\\)\\|n\\(d\\|try\\)\\|x\\(ception\\|it\\)\\)\\|\
+;f\\(or\\|unction\\)\\|g\\(eneric\\|oto\\)\\|i[fns]\\|l\\(imited\\|oop\\)\\|\
+;mod\\|n\\(ew\\|ot\\|ull\\)\\|o\\([fr]\\|thers\\|ut\\)\\|\
+;p\\(ackage\\|r\\(agma\\|ivate\\|ocedure\\)\\)\\|\
+;r\\(a\\(ise\\|nge\\)\\|e\\(cord\\|m\\|names\\|turn\\|verse\\)\\)\\|\
+;s\\(e\\(lect\\|parate\\)\\|ubtype\\)\\|use\\|
+;t\\(ask\\|erminate\\|hen\\|ype\\)\\|w\\(h\\(en\\|ile\\)\\|ith\\)\\|xor\\)\\>"
+ "Regular expression for looking at Ada83 keywords.")
+
+(defconst ada-95-keywords
"\\<\\(abort\\|abs\\|abstract\\|accept\\|access\\|aliased\\|\
all\\|and\\|array\\|at\\|begin\\|body\\|case\\|constant\\|declare\\|\
delay\\|delta\\|digits\\|do\\|else\\|elsif\\|end\\|entry\\|\
range\\|record\\|rem\\|renames\\|requeue\\|return\\|reverse\\|\
select\\|separate\\|subtype\\|tagged\\|task\\|terminate\\|then\\|\
type\\|until\\|use\\|when\\|while\\|with\\|xor\\)\\>"
- "regular expression for looking at Ad94 keywords.")
+ "Regular expression for looking at Ada95 keywords.")
-(defvar ada-keywords ada-94-keywords
- "regular expression for looking at Ada keywords.")
+(defvar ada-keywords ada-95-keywords
+ "Regular expression for looking at Ada keywords.")
(defvar ada-ret-binding nil
"Variable to save key binding of RET when casing is activated.")
;;; ---- Regexps to find procedures/functions/packages
+(defconst ada-ident-re
+ "[a-zA-Z0-9_\\.]+"
+ "Regexp matching Ada (qualified) identifiers.")
+
(defvar ada-procedure-start-regexp
"^[ \t]*\\(procedure\\|function\\|task\\)[ \t\n]+\\([a-zA-Z0-9_\\.]+\\)"
"Regexp used to find Ada procedures/functions.")
(defvar ada-block-start-re
"\\<\\(begin\\|select\\|declare\\|private\\|or\\|generic\\|\
-exception\\|loop\\|record\\|else\\)\\>"
- "Regexp for keywords starting ada-blocks.")
+exception\\|loop\\|else\\|\
+\\(\\(limited\\|abstract\\|tagged\\)[ \t]+\\)*record\\)\\>"
+ "Regexp for keywords starting Ada blocks.")
(defvar ada-end-stmt-re
- "\\(;\\|=>\\|\\<\\(begin\\|record\\|loop\\|select\\|do\\|\
-exception\\|declare\\|generic\\|private\\)\\>\\)"
+ "\\(;\\|=>\\|^[ \t]*separate[ \t]+([a-zA-Z0-9_\\.]+)\\|\
+\\<\\(begin\\|else\\|record\\|loop\\|select\\|do\\|then\\|\
+declare\\|generic\\|private\\)\\>\\|\
+^[ \t]*\\(package\\|procedure\\|function\\)\\>[ \ta-zA-Z0-9_\\.]+\\<is\\>\\|\
+^[ \t]*exception\\>\\)"
"Regexp of possible ends for a non-broken statement.
-'end' means that there has to start a new statement after these.")
+A new statement starts after these.")
(defvar ada-loop-start-re
"\\<\\(for\\|while\\|loop\\)\\>"
"Regexp for the start of a loop.")
(defvar ada-subprog-start-re
- "\\<\\(procedure\\|function\\|task\\|accept\\)\\>"
+ "\\<\\(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.")
+
+\f
+;; 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))
+
+ "Imenu generic expression for Ada mode. See `imenu-generic-expression'.")
\f
;;;-------------
;;; 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."
- ;; This syntax table is a merge of two syntax tables I found
- ;; in the two ada modes in the old ada.el and the old
- ;; electric-ada.el. (jsl)
- ;; There still remains the problem, if the underscore '_' is a word
- ;; constituent or not. (re)
- ;; The Emacs doc clearly states that it is a symbol, and that is what most
- ;; on the ada-mode list prefer. (re)
- ;; For some functions, the syntactical meaning of '_' is temporaryly
- ;; changed to 'w'. (mh)
+ "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)
- (modify-syntax-entry ?% "\"" ada-mode-syntax-table)
+ ;; define string brackets (`%' is alternative string bracket, but
+ ;; 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 ?\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)
+
+ (setq ada-mode-symbol-syntax-table (copy-syntax-table ada-mode-syntax-table))
+ (modify-syntax-entry ?_ "w" ada-mode-symbol-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.)
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 package '\\[ada-next-package]' Previous package '\\[ada-previous-package]'
+ 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]'
or '\\[ff-mouse-find-other-file]
Switch to other file in other window '\\[ada-ff-other-window]'
or '\\[ff-mouse-find-other-file-other-window]
+ If you use this function in a spec and no body is available, it gets created
+ with body stubs.
If you use ada-xref.el:
Goto declaration: '\\[ada-point-and-xref]' on the identifier
(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 'font-lock-defaults)
- (setq font-lock-defaults '(ada-font-lock-keywords nil t ((?\_ . "w"))))
+ ;;(make-local-variable 'adaptive-fill-regexp)
+
+ (make-local-variable 'imenu-generic-expression)
+ (setq imenu-generic-expression ada-imenu-generic-expression)
+ (setq imenu-case-fold-search t)
+
+ (if (ada-xemacs) nil ; XEmacs uses properties
+ (make-local-variable 'font-lock-defaults)
+ (setq font-lock-defaults
+ '((ada-font-lock-keywords
+ ada-font-lock-keywords-1 ada-font-lock-keywords-2)
+ nil t
+ ((?\_ . "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
(cond ((eq ada-language-version 'ada83)
(setq ada-keywords ada-83-keywords))
- ((eq ada-language-version 'ada94)
- (setq ada-keywords ada-94-keywords)))
+ ((eq ada-language-version 'ada95)
+ (setq ada-keywords ada-95-keywords)))
(if ada-auto-case
(ada-activate-keys-for-case)))
+\f
+;;;--------------------------
+;;; 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)))
+
+
+
\f
;;;--------------------------
;;; Fill Comment Paragraph
(defun ada-fill-comment-paragraph (&optional justify postfix)
"Fills the current comment paragraph.
If JUSTIFY is non-nil, each line is justified as well.
-If POSTFIX and JUSTIFY are non-nil, ada-fill-comment-postfix is appended
+If POSTFIX and JUSTIFY are non-nil, `ada-fill-comment-postfix' is appended
to each filled and justified line.
-If ada-indent-comment-as code is non-nil, the paragraph is idented."
+If `ada-indent-comment-as-code' is non-nil, the paragraph is idented."
(interactive "P")
(let ((opos (point-marker))
(begin nil)
(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 external process on that file and then
-reloads the beautyfied program in the buffer and cleans up
-ada-tmp-directory."
+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 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))
;;;---------------
;; 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.
(not (looking-at "_"))) ; (MH)
(looking-at (concat ada-keywords "[^_]")))))
-(defun ada-after-char-p ()
- ;; returns t if after ada character "'".
+(defun ada-in-char-const-p ()
+ ;; Returns t if point is inside a character constant.
+ ;; We assume to be in a constant if the previous and the next character
+ ;; are "'".
(save-excursion
- (if (> (point) 2)
- (progn
- (forward-char -2)
- (looking-at "'"))
+ (if (> (point) 1)
+ (and
+ (progn
+ (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,
-according to ada-case-keyword and ada-case-identifier
-If FORCE-IDENTIFIER is non-nil then also adjust keyword as
-identifier." ; (MH)
+ "Adjust the case of the word before the just typed character.
+Respect options `ada-case-keyword', `ada-case-identifier', and
+`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 (and
- (not force-identifier) ; (MH)
- (ada-after-keyword-p))
- (funcall ada-case-keyword -1)
- (funcall ada-case-identifier -1))))
+ (if (save-excursion
+ (forward-word -1)
+ (or (= (point) (point-min))
+ (backward-char 1))
+ (looking-at "'"))
+ (funcall ada-case-attribute -1)
+ (if (and
+ (not force-identifier) ; (MH)
+ (ada-after-keyword-p))
+ (funcall ada-case-keyword -1)
+ (funcall ada-case-identifier -1)))))
(forward-char 1))
;; 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
;; added by MH
;;
(defun ada-loose-case-word (&optional arg)
- "Capitalizes the first and the letters following _
+ "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))
;;
;; added by MH
+;; modified by JSH to handle attributes
;;
(defun ada-adjust-case-region (from to)
- "Adjusts the case of all identifiers and keywords in the region.
-ATTENTION: This function might take very long for big regions !"
+ "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))
- (save-excursion
- (goto-char to)
- ;;
- ;; loop: look for all identifiers and keywords
- ;;
- (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 (format "adjusting case ... %5d characters left"
- (- (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
- ;;
- (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))
- (goto-char begin))))
- (message "adjusting case ... done"))))
+ (attribp nil))
+ (unwind-protect
+ (save-excursion
+ (set-syntax-table ada-mode-symbol-syntax-table)
+ (goto-char to)
+ ;;
+ ;; 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
+ ;;
+ (message "adjusting case ... %5d characters left" (- (point) from))
+ (setq attribp (looking-at "'[a-zA-Z0-9_]+[^']"))
+ (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 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)
+ (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 identifiers and keywords in the whole buffer.
+ "Adjusts the case of all words in the whole buffer.
ATTENTION: This function might take very long for big buffers !"
- (interactive)
+ (interactive "*")
(ada-adjust-case-region (point-min) (point-max)))
\f
;;;------------------------;;;
(defun ada-format-paramlist ()
- "Re-formats a parameter-list.
+ "Reformats a parameter list.
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."
+In such a case, use `undo', correct the syntax and try again."
(interactive)
(let ((begin nil)
(end nil)
(delend nil)
(paramlist nil))
- ;;
- ;; ATTENTION: modify sntax-table temporary !
- ;;
- (modify-syntax-entry ?_ "w")
-
- ;; check if really inside parameter list
- (or (ada-in-paramlist-p)
- (error "not in parameter list"))
- ;;
- ;; find start of current parameter-list
- ;;
- (ada-search-ignore-string-comment
- (concat "\\<\\("
- "procedure\\|function\\|body\\|package\\|task\\|entry\\|accept"
- "\\)\\>") t nil)
- (ada-search-ignore-string-comment "(" nil nil t)
- (backward-char 1)
- (setq begin (point))
-
- ;;
- ;; find end of parameter-list
- ;;
- (forward-sexp 1)
- (setq delend (point))
- (delete-char -1)
-
- ;;
- ;; find end of last parameter-declaration
- ;;
- (ada-search-ignore-string-comment "[^ \t\n]" t nil t)
- (forward-char 1)
- (setq end (point))
-
- ;;
- ;; build a list of all elements of the parameter-list
- ;;
- (setq paramlist (ada-scan-paramlist (1+ begin) end))
-
- ;;
- ;; delete the original parameter-list
- ;;
- (delete-region begin (1- delend))
-
- ;;
- ;; insert the new parameter-list
- ;;
- (goto-char begin)
- (ada-insert-paramlist paramlist)
-
- ;;
- ;; restore syntax-table
- ;;
- (modify-syntax-entry ?_ "_")))
+ (unwind-protect
+ (progn
+ (set-syntax-table ada-mode-symbol-syntax-table)
+
+ ;; check if really inside parameter list
+ (or (ada-in-paramlist-p)
+ (error "not in parameter list"))
+ ;;
+ ;; find start of current parameter-list
+ ;;
+ (ada-search-ignore-string-comment
+ (concat ada-subprog-start-re "\\|\\<body\\>" ) t nil)
+ (ada-search-ignore-string-comment "(" nil nil t)
+ (backward-char 1)
+ (setq begin (point))
+
+ ;;
+ ;; find end of parameter-list
+ ;;
+ (forward-sexp 1)
+ (setq delend (point))
+ (delete-char -1)
+
+ ;;
+ ;; find end of last parameter-declaration
+ ;;
+ (ada-search-ignore-string-comment "[^ \t\n]" t nil t)
+ (forward-char 1)
+ (setq end (point))
+
+ ;;
+ ;; build a list of all elements of the parameter-list
+ ;;
+ (setq paramlist (ada-scan-paramlist (1+ begin) end))
+
+ ;;
+ ;; delete the original parameter-list
+ ;;
+ (delete-region begin (1- delend))
+
+ ;;
+ ;; insert the new parameter-list
+ ;;
+ (goto-char begin)
+ (ada-insert-paramlist paramlist))
+
+ ;;
+ ;; restore syntax-table
+ ;;
+ (set-syntax-table ada-mode-syntax-table)
+ )))
(defun ada-scan-paramlist (begin end)
;; of its contents.
;; The list has the following format:
;;
- ;; Name of Param in? out? accept? Name of Type Default-Exp or nil
+ ;; Name of Param in? out? access? Name of Type Default-Exp or nil
;;
;; ( ('Name_Param_1' t nil t Type_Param_1 ':= expression')
;; ('Name_Param_2' nil nil t Type_Param_2 nil) )
t)))))
;;
- ;; look for 'accept'
+ ;; look for 'access'
;;
(goto-char apos)
(setq param
(append param
(list
(consp
- (ada-search-ignore-string-comment "\\<accept\\>"
+ (ada-search-ignore-string-comment "\\<access\\>"
nil
epos
t)))))
;;
- ;; skip 'in'/'out'/'accept'
+ ;; skip 'in'/'out'/'access'
;;
(goto-char apos)
(ada-goto-next-non-ws)
- (while (looking-at "\\<\\(in\\|out\\|accept\\)\\>")
+ (while (looking-at "\\<\\(in\\|out\\|access\\)\\>")
(forward-word 1)
(ada-goto-next-non-ws))
;;
- ;; read type of parameter
+ ;; read type of parameter
;;
- (looking-at "\\<[a-zA-Z0-9_\\.]+\\>")
+ (looking-at "\\<[a-zA-Z0-9_\\.\\']+\\>")
(setq param
(append param
(list
(defun ada-insert-paramlist (paramlist)
;; Inserts a formatted PARAMLIST in the buffer.
- ;; See doc of ada-scan-paramlist for the format.
+ ;; See doc of `ada-scan-paramlist' for the format.
(let ((i (length paramlist))
(parlen 0)
(typlen 0)
(temp 0)
(inp nil)
(outp nil)
- (acceptp nil)
+ (accessp nil)
(column nil)
(orgpoint 0)
(firstcol nil))
(nth 2 (nth i paramlist))))
;;
- ;; is there any 'accept' ?
+ ;; is there any 'access' ?
;;
- (setq acceptp
- (or acceptp
+ (setq accessp
+ (or accessp
(nth 3 (nth i paramlist))))) ; end of loop
;;
(insert "in ")
(if (and
(or inp
- acceptp)
+ accessp)
(not (nth 3 (nth i paramlist))))
(insert " ")))
(insert "out ")
(if (and
(or outp
- acceptp)
+ accessp)
(not (nth 3 (nth i paramlist))))
(insert " ")))
;;
- ;; insert 'accept'
+ ;; insert 'access'
;;
(if (nth 3 (nth i paramlist))
- (insert "accept "))
+ (insert "access "))
(setq column (current-column))
;;;----------------------------;;;
(defun ada-move-to-start ()
- "Moves point to the matching start of the current end ... around point."
+ "Moves point to the matching start of the current Ada structure."
(interactive)
(let ((pos (point)))
- ;;
- ;; ATTENTION: modify sntax-table temporary !
- ;;
- (modify-syntax-entry ?_ "w")
-
- (message "searching for block start ...")
- (save-excursion
- ;;
- ;; do nothing if in string or comment or not on 'end ...;'
- ;; or if an error occurs during processing
- ;;
- (or
- (ada-in-string-or-comment-p)
- (and (progn
- (or (looking-at "[ \t]*\\<end\\>")
- (backward-word 1))
- (or (looking-at "[ \t]*\\<end\\>")
- (backward-word 1))
- (or (looking-at "[ \t]*\\<end\\>")
- (error "not on end ...;")))
- (ada-goto-matching-start 1)
- (setq pos (point))
-
- ;;
- ;; on 'begin' => go on, according to user option
- ;;
- ada-move-to-declaration
- (looking-at "\\<begin\\>")
- (ada-goto-matching-decl-start)
- (setq pos (point))))
-
- ) ; end of save-excursion
-
- ;; now really move to the found position
- (goto-char pos)
- (message "searching for block start ... done")
-
- ;;
- ;; restore syntax-table
- ;;
- (modify-syntax-entry ?_ "_")))
+ (unwind-protect
+ (progn
+ (set-syntax-table ada-mode-symbol-syntax-table)
+
+ (message "searching for block start ...")
+ (save-excursion
+ ;;
+ ;; do nothing if in string or comment or not on 'end ...;'
+ ;; or if an error occurs during processing
+ ;;
+ (or
+ (ada-in-string-or-comment-p)
+ (and (progn
+ (or (looking-at "[ \t]*\\<end\\>")
+ (backward-word 1))
+ (or (looking-at "[ \t]*\\<end\\>")
+ (backward-word 1))
+ (or (looking-at "[ \t]*\\<end\\>")
+ (error "not on end ...;")))
+ (ada-goto-matching-start 1)
+ (setq pos (point))
+
+ ;;
+ ;; on 'begin' => go on, according to user option
+ ;;
+ ada-move-to-declaration
+ (looking-at "\\<begin\\>")
+ (ada-goto-matching-decl-start)
+ (setq pos (point))))
+
+ ) ; end of save-excursion
+
+ ;; now really move to the found position
+ (goto-char pos)
+ (message "searching for block start ... done"))
+
+ ;;
+ ;; restore syntax-table
+ ;;
+ (set-syntax-table ada-mode-syntax-table))))
(defun ada-move-to-end ()
(let ((pos (point))
(decstart nil)
(packdecl nil))
- ;;
- ;; ATTENTION: modify sntax-table temporary !
- ;;
- (modify-syntax-entry ?_ "w")
-
- (message "searching for block end ...")
- (save-excursion
-
- (forward-char 1)
- (cond
- ;; directly on 'begin'
- ((save-excursion
- (ada-goto-previous-word)
- (looking-at "\\<begin\\>"))
- (ada-goto-matching-end 1))
- ;; on first line of defun declaration
- ((save-excursion
- (and (ada-goto-stmt-start)
- (looking-at "\\<function\\>\\|\\<procedure\\>" )))
- (ada-search-ignore-string-comment "\\<begin\\>"))
- ;; on first line of task declaration
- ((save-excursion
- (and (ada-goto-stmt-start)
- (looking-at "\\<task\\>" )
- (forward-word 1)
- (ada-search-ignore-string-comment "[^ \n\t]")
- (not (backward-char 1))
- (looking-at "\\<body\\>")))
- (ada-search-ignore-string-comment "\\<begin\\>"))
- ;; accept block start
- ((save-excursion
- (and (ada-goto-stmt-start)
- (looking-at "\\<accept\\>" )))
- (ada-goto-matching-end 0))
- ;; package start
- ((save-excursion
- (and (ada-goto-matching-decl-start t)
- (looking-at "\\<package\\>")))
- (ada-goto-matching-end 1))
- ;; inside a 'begin' ... 'end' block
- ((save-excursion
- (ada-goto-matching-decl-start t))
- (ada-search-ignore-string-comment "\\<begin\\>"))
- ;; (hopefully ;-) everything else
- (t
- (ada-goto-matching-end 1)))
- (setq pos (point))
-
- ) ; end of save-excursion
-
- ;; now really move to the found position
- (goto-char pos)
- (message "searching for block end ... done")
-
- ;;
- ;; restore syntax-table
- ;;
- (modify-syntax-entry ?_ "_")))
+ (unwind-protect
+ (progn
+ (set-syntax-table ada-mode-symbol-syntax-table)
+
+ (message "searching for block end ...")
+ (save-excursion
+
+ (forward-char 1)
+ (cond
+ ;; directly on 'begin'
+ ((save-excursion
+ (ada-goto-previous-word)
+ (looking-at "\\<begin\\>"))
+ (ada-goto-matching-end 1))
+ ;; on first line of defun declaration
+ ((save-excursion
+ (and (ada-goto-stmt-start)
+ (looking-at "\\<function\\>\\|\\<procedure\\>" )))
+ (ada-search-ignore-string-comment "\\<begin\\>"))
+ ;; on first line of task declaration
+ ((save-excursion
+ (and (ada-goto-stmt-start)
+ (looking-at "\\<task\\>" )
+ (forward-word 1)
+ (ada-search-ignore-string-comment "[^ \n\t]")
+ (not (backward-char 1))
+ (looking-at "\\<body\\>")))
+ (ada-search-ignore-string-comment "\\<begin\\>"))
+ ;; accept block start
+ ((save-excursion
+ (and (ada-goto-stmt-start)
+ (looking-at "\\<accept\\>" )))
+ (ada-goto-matching-end 0))
+ ;; package start
+ ((save-excursion
+ (and (ada-goto-matching-decl-start t)
+ (looking-at "\\<package\\>")))
+ (ada-goto-matching-end 1))
+ ;; inside a 'begin' ... 'end' block
+ ((save-excursion
+ (ada-goto-matching-decl-start t))
+ (ada-search-ignore-string-comment "\\<begin\\>"))
+ ;; (hopefully ;-) everything else
+ (t
+ (ada-goto-matching-end 1)))
+ (setq pos (point))
+
+ ) ; end of save-excursion
+
+ ;; now really move to the found position
+ (goto-char pos)
+ (message "searching for block end ... done"))
+
+ ;;
+ ;; restore syntax-table
+ ;;
+ (set-syntax-table ada-mode-syntax-table))))
\f
;;;-----------------------------;;;
;; ---- main functions for indentation
(defun ada-indent-region (beg end)
- "Indents the region using ada-indent-current on each line."
+ "Indents the region using `ada-indent-current' on each line."
(interactive "*r")
(goto-char beg)
- ;; catch errors while indenting
- (condition-case err
- (while (< (point) end)
- (message (format "indenting ... %4d lines left"
- (count-lines (point) end)))
- (ada-indent-current)
- (forward-line 1))
- ;; show line number where the error occured
- (error
- (error (format "line %d: %s"
- (1+ (count-lines (point-min) (point)))
- err) nil)))
- (message "indenting ... done"))
+ (let ((block-done 0)
+ (lines-remaining (count-lines beg end))
+ (msg (format "indenting %4d lines %%4d lines remaining ..."
+ (count-lines beg end)))
+ (endmark (copy-marker end)))
+ ;; catch errors while indenting
+ (condition-case err
+ (while (< (point) endmark)
+ (if (> block-done 9)
+ (progn (message msg lines-remaining)
+ (setq block-done 0)))
+ (if (looking-at "^$") nil
+ (ada-indent-current))
+ (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) 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)
- (orgpoint))
-
- (ada-indent-current)
- (newline)
- (delete-horizontal-space)
- (setq orgpoint (point))
-
- ;;
- ;; ATTENTION: modify syntax-table temporary !
- ;;
- (modify-syntax-entry ?_ "w")
-
- (setq column (save-excursion
- (funcall (ada-indent-function) orgpoint)))
-
- ;;
- ;; restore syntax-table
- ;;
- (modify-syntax-entry ?_ "_")
-
- (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))
- ))
+ (ada-indent-current)
+ (newline)
+ (ada-indent-current))
(defun ada-indent-current ()
"Indents current line as Ada code.
This works by two steps:
- 1) It moves point to the end of the previous code-line.
+ 1) It moves point to the end of the previous code line.
Then it calls the function to calculate the indentation for the
following line as if a newline would be inserted there.
The calculated column # is saved and the old position of point
(interactive)
- ;;
- ;; ATTENTION: modify sntax-table temporary !
- ;;
- (modify-syntax-entry ?_ "w")
-
- (let ((line-end)
- (orgpoint (point-marker))
- (cur-indent)
- (prev-indent)
- (prevline t))
+ (unwind-protect
+ (progn
+ (set-syntax-table ada-mode-symbol-syntax-table)
+
+ (let ((line-end)
+ (orgpoint (point-marker))
+ (cur-indent)
+ (prev-indent)
+ (prevline t))
+
+ ;;
+ ;; first step
+ ;;
+ (save-excursion
+ (if (ada-goto-prev-nonblank-line t)
+ ;;
+ ;; we are not in the first accessible line in the buffer
+ ;;
+ (progn
+ ;;(end-of-line)
+ ;;(forward-char 1)
+ ;; we are already at the BOL
+ (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
+ (beginning-of-line) ; to 0
+ (delete-horizontal-space)
+ (setq prevline nil))))
+
+ (if prevline
+ ;;
+ ;; we are not in the first accessible line in the buffer
+ ;;
+ (progn
+ ;;
+ ;; second step
+ ;;
+ (back-to-indentation)
+ (setq cur-indent (ada-get-current-indent prev-indent))
+ ;; only reindent if indentation is different then the current
+ (if (= (current-column) cur-indent)
+ nil
+ (delete-horizontal-space)
+ (indent-to cur-indent))
+ ;;
+ ;; restore position of point
+ ;;
+ (goto-char orgpoint)
+ (if (< (current-column) (current-indentation))
+ (back-to-indentation))))))
;;
- ;; first step
+ ;; restore syntax-table
;;
- (save-excursion
- (if (ada-goto-prev-nonblank-line t)
- ;;
- ;; we are not in the first accessible line in the buffer
- ;;
- (progn
- (end-of-line)
- (forward-char 1)
- (setq line-end (point))
- (setq prev-indent (save-excursion
- (funcall (ada-indent-function) line-end))))
- (setq prevline nil)))
-
- (if prevline
- ;;
- ;; we are not in the first accessible line in the buffer
- ;;
- (progn
- ;;
- ;; second step
- ;;
- (back-to-indentation)
- (setq cur-indent (ada-get-current-indent prev-indent))
- (delete-horizontal-space)
- (indent-to cur-indent)
-
- ;;
- ;; restore position of point
- ;;
- (goto-char orgpoint)
- (if (< (current-column) (current-indentation))
- (back-to-indentation)))))
-
- ;;
- ;; restore syntax-table
- ;;
- (modify-syntax-entry ?_ "_"))
+ (set-syntax-table ada-mode-syntax-table)))
(defun ada-get-current-indent (prev-indent)
;; end
;;
((looking-at "\\<end\\>")
- (save-excursion
- (ada-goto-matching-start 1)
+ (let ((label 0))
+ (save-excursion
+ (ada-goto-matching-start 1)
- ;;
- ;; found 'loop' => skip back to 'while' or 'for'
- ;; if 'loop' is not on a separate line
- ;;
- (if (and
- (looking-at "\\<loop\\>")
- (save-excursion
- (back-to-indentation)
- (not (looking-at "\\<loop\\>"))))
- (if (save-excursion
- (and
- (setq match-cons
- (ada-search-ignore-string-comment
- ada-loop-start-re t nil))
- (not (looking-at "\\<loop\\>"))))
- (goto-char (car match-cons))))
+ ;;
+ ;; found 'loop' => skip back to 'while' or 'for'
+ ;; if 'loop' is not on a separate line
+ ;;
+ (if (and
+ (looking-at "\\<loop\\>")
+ (save-excursion
+ (back-to-indentation)
+ (not (looking-at "\\<loop\\>"))))
+ (if (save-excursion
+ (and
+ (setq match-cons
+ (ada-search-ignore-string-comment
+ ada-loop-start-re t nil))
+ (not (looking-at "\\<loop\\>"))))
+ (progn
+ (goto-char (car match-cons))
+ (save-excursion
+ (beginning-of-line)
+ (if (looking-at ada-named-block-re)
+ (setq label (- ada-label-indent)))))))
- (current-indentation)))
+ (+ (current-indentation) label))))
;;
;; exception
;;
(save-excursion
(if (ada-goto-matching-decl-start t)
(current-indentation)
- (progn
- (message "no matching declaration start")
- prev-indent))))
+ prev-indent)))
;;
;; is
;;
;; the current statement, if NOMOVE is nil.
(let ((orgpoint (point))
- (func nil)
- (stmt-start nil))
+ (func nil))
;;
;; inside a parameter-list
;;
;; 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)
+ (setq func 'ada-get-indent-nochange)
(cond
;;
((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\\>")
(setq func 'ada-get-indent-type))
;;
- ((looking-at "\\<if\\>")
+ ((looking-at "\\<\\(els\\)?if\\>")
(setq func 'ada-get-indent-if))
;;
- ((looking-at "\\<elsif\\>")
- (setq func 'ada-get-indent-if)) ; maybe it needs a special
- ; function sometimes ?
- ;;
((looking-at "\\<case\\>")
(setq func 'ada-get-indent-case))
;;
((looking-at "[a-zA-Z0-9_]+[ \t\n]*:[^=]")
(setq func 'ada-get-indent-label))
;;
+ ((looking-at "\\<separate\\>")
+ (setq func 'ada-get-indent-nochange))
(t
(setq func 'ada-get-indent-noindent))))))
(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))
;; 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 ';' ?
(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 ?
"loop\\|select\\|if\\|case\\|"
"record\\|while\\|type\\)\\>")))
(backward-word 1))
- (current-indentation)))
+ (+ (current-indentation) label)))
;;
;; a named block end
;;
- ((looking-at "[a-zA-Z0-9_]+")
+ ((looking-at ada-ident-re)
(setq defun-name (buffer-substring (match-beginning 0)
(match-end 0)))
(save-excursion
(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)))
;; case..is..when..=>
;;
((save-excursion
- (setq match-cons (ada-search-ignore-string-comment
- "[ \t\n]+=>" nil orgpoint)))
+ (setq match-cons (and
+ ;; 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))
(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
;;
"\\<\\(separate\\|new\\|abstract\\)\\>"
nil orgpoint))))
(goto-char (car match-cons))
- (ada-search-ignore-string-comment (concat ada-subprog-start-re
- "\\|\\<package\\>") t)
+ (ada-search-ignore-string-comment ada-subprog-start-re t)
(ada-get-indent-noindent orgpoint))
;;
;; something follows 'is'
(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
- (ada-search-ignore-string-comment ";" nil orgpoint))
- (current-indentation)
- (+ (current-indentation) ada-broken-indent)))
+ (let ((label 0))
+ (save-excursion
+ (beginning-of-line)
+ (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)
;;
((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)))
;; 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
;;
;;
((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)
(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
(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)
(ada-search-ignore-string-comment ";" nil orgpoint))
(current-indentation))
;;
- ;; type ... is
+ ;; "type ... is", but not "type ... is ...", which is broken
;;
((save-excursion
- (ada-search-ignore-string-comment "\\<is\\>" nil orgpoint))
+ (and
+ (ada-search-ignore-string-comment "\\<is\\>" nil orgpoint)
+ (not (ada-search-ignore-string-comment "[^ \t\n]" nil orgpoint))))
(+ (current-indentation) ada-indent))
;;
;; broken statement
;;
(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)))
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\\>"))))
- (setq found t)
-
- (backward-word 1)))) ; end of loop
+ (looking-at "\\<\\(end\\|or\\|and\\)\\>"))))
+ (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))
-(defun ada-goto-previous-word ()
- ;; Moves point to the beginning of the previous word of ada-code.
+(defun ada-goto-next-word (&optional backward)
+ ;; 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))
;;
'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.
(ada-goto-matching-start 0)
(if (not (looking-at (concat "\\<" keyword "\\>")))
- (error (concat
- "matching start is not '"
- keyword "'"))))
+ (error "matching start is not '%s'" keyword)))
(defun ada-check-defun-name (defun-name)
;; Moves point to the beginning of the declaration.
;;
- ;; 'accept' or 'package' ?
+ ;; named block without a `declare'
;;
- (if (not (looking-at "\\<\\(accept\\|package\\|task\\)\\>"))
- (ada-goto-matching-decl-start))
- ;;
- ;; 'begin' of 'procedure'/'function'/'task' or 'declare'
- ;;
- (save-excursion
+ (if (save-excursion
+ (ada-goto-previous-word)
+ (looking-at (concat "\\<" defun-name "\\> *:")))
+ t ; do nothing
;;
- ;; a named 'declare'-block ?
+ ;; 'accept' or 'package' ?
;;
- (if (looking-at "\\<declare\\>")
- (ada-goto-stmt-start)
+ (if (not (looking-at "\\<\\(accept\\|package\\|task\\|protected\\)\\>"))
+ (ada-goto-matching-decl-start))
+ ;;
+ ;; 'begin' of 'procedure'/'function'/'task' or 'declare'
+ ;;
+ (save-excursion
;;
- ;; no, => 'procedure'/'function'/'task'
+ ;; a named 'declare'-block ?
;;
- (progn
- (forward-word 2)
- (backward-word 1)
+ (if (looking-at "\\<declare\\>")
+ (ada-goto-stmt-start)
;;
- ;; skip 'body' or 'type'
+ ;; no, => 'procedure'/'function'/'task'/'protected'
;;
- (if (looking-at "\\<\\(body\\|type\\)\\>")
- (forward-word 1))
- (forward-sexp 1)
- (backward-sexp 1)))
- ;;
- ;; should be looking-at the correct name
- ;;
- (if (not (looking-at (concat "\\<" defun-name "\\>")))
- (error
- (concat
- "matching defun has different name: "
- (buffer-substring
- (point)
- (progn
- (forward-sexp 1)
- (point))))))))
+ (progn
+ (forward-word 2)
+ (backward-word 1)
+ ;;
+ ;; skip 'body' 'type'
+ ;;
+ (if (looking-at "\\<\\(body\\|type\\)\\>")
+ (forward-word 1))
+ (forward-sexp 1)
+ (backward-sexp 1)))
+ ;;
+ ;; 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)
;;
((looking-at "end")
(ada-goto-matching-start 1 noerror)
- (if (progn
- (looking-at "begin"))
+ (if (looking-at "begin")
(setq nest-count (1+ nest-count))))
;;
((looking-at "declare\\|generic")
(setq first nil))
;;
((looking-at "is")
- ;; check if it is only a type definition
- (if (save-excursion
- (ada-goto-previous-word)
- (skip-chars-backward "a-zA-Z0-9_.'")
- (if (save-excursion
- (backward-char 1)
- (looking-at ")"))
- (progn
- (forward-char 1)
- (backward-sexp 1)
- (skip-chars-backward "a-zA-Z0-9_.'")
- ))
- (ada-goto-previous-word)
- (looking-at "\\<type\\>")) ; end of save-excursion
+ ;; check if it is only a type definition, but not a protected
+ ;; type definition, which should be handled like a procedure.
+ (if (or (looking-at "is +<>")
+ (save-excursion
+ (ada-goto-previous-word)
+ (skip-chars-backward "a-zA-Z0-9_.'")
+ (if (save-excursion
+ (backward-char 1)
+ (looking-at ")"))
+ (progn
+ (forward-char 1)
+ (backward-sexp 1)
+ (skip-chars-backward "a-zA-Z0-9_.'")
+ ))
+ (ada-goto-previous-word)
+ (and
+ (looking-at "\\<type\\>")
+ (save-match-data
+ (ada-goto-previous-word)
+ (not (looking-at "\\<protected\\>"))))
+ )); end of `or'
(goto-char (match-beginning 0))
(progn
(setq nest-count (1- nest-count))
(and
(zerop nest-count)
(not flag)
- (progn
- (if (looking-at "is")
- (ada-search-ignore-string-comment
- "\\<\\(procedure\\|function\\|task\\|package\\)\\>" t)
- (looking-at "declare\\|generic")))))
+ (if (looking-at "is")
+ (ada-search-ignore-string-comment ada-subprog-start-re t)
+ (looking-at "declare\\|generic"))))
(if noerror nil
- (error "no matching procedure/function/task/declare/package"))
+ (error "no matching proc/func/task/declare/package/protected"))
t)))
(not found)
(ada-search-ignore-string-comment
(concat "\\<\\("
- "end\\|loop\\|select\\|begin\\|case\\|"
- "if\\|task\\|package\\|record\\|do\\)\\>")
+ "end\\|loop\\|select\\|begin\\|case\\|do\\|"
+ "if\\|task\\|package\\|record\\|protected\\)\\>")
t))
;;
;; 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))
(progn
(re-search-backward "--" nil 1)
(goto-char (match-beginning 0)))
- (progn
- (forward-line 1)
- (beginning-of-line))))
+ (forward-line 1)
+ ;; Used to have (beginning-of-line) here,
+ ;; but that caused trouble at end of buffer with no newline.
+ ))
;;
;; found in string => skip it
;;
((ada-in-string-p)
(if backward
(progn
- (re-search-backward "\"\\|#" nil 1)
+ (re-search-backward "\"" nil 1) ; "\"\\|#" don't treat #
(goto-char (match-beginning 0))))
- (re-search-forward "\"\\|#" nil 1))
+ (re-search-forward "\"" nil 1))
;;
;; found character constant => ignore it
;;
(defun ada-goto-prev-nonblank-line ( &optional ignore-comment)
- ;; Moves point to previous non-blank line,
+ ;; Moves point to the beginning of previous non-blank line,
;; ignoring comments if IGNORE-COMMENT is non-nil.
;; It returns t if a matching line was found.
(let ((notfound t)
(or (looking-at "[ \t]*$")
(and (looking-at "[ \t]*--")
ignore-comment)))
- (not (in-limit-line-p)))
+ (not (ada-in-limit-line-p)))
(forward-line -1)
- (beginning-of-line)
+ ;;(beginning-of-line)
(setq newpoint (point))) ; end of loop
)) ; end of if
(or (looking-at "[ \t]*$")
(and (looking-at "[ \t]*--")
ignore-comment)))
- (not (in-limit-line-p)))
+ (not (ada-in-limit-line-p)))
(forward-line 1)
(beginning-of-line)
(setq newpoint (point))) ; end of loop
(looking-at "\\<private\\>")))))
-(defun in-limit-line-p ()
- ;; Returns t if point is in first or last accessible line.
- (or
- (>= 1 (count-lines (point-min) (point)))
- (>= 1 (count-lines (point) (point-max)))))
+;;; make a faster??? ada-in-limit-line-p not using count-lines
+(defun ada-in-limit-line-p ()
+ ;; return t if point is in first or last accessible line.
+ (or (save-excursion (beginning-of-line) (= (point-min) (point)))
+ (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 ()
(point)) (point)))
;; check if 'string quote' is only a character constant
(progn
- (re-search-backward "\"\\|#" nil t)
+ (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.
- (or (ada-in-comment-p)
- (ada-in-string-p)))
+ ;; Returns t if point is inside a string, a comment, or a character constant.
+ (let ((parse-result (parse-partial-sexp
+ (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 ()
;; inside parentheses ?
(looking-at "(")
(backward-word 2)
- ;; right keyword before paranthesis ?
+ ;; right keyword before parenthesis ?
(looking-at (concat "\\<\\("
"procedure\\|function\\|body\\|package\\|"
"task\\|entry\\|accept\\)\\>"))
;; 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 ((nest-count 1)
- (limit nil)
- (found nil)
- (pos nil)
- (col nil)
- (counter ada-search-paren-line-count-limit))
-
- ;;
- ;; get search-limit
- ;;
- (if ada-search-paren-line-count-limit
- (setq limit
- (save-excursion
- (while (not (zerop counter))
- (ada-goto-prev-nonblank-line)
- (setq counter (1- counter)))
- (beginning-of-line)
- (point))))
-
- (save-excursion
-
- ;;
- ;; loop until found or limit
- ;;
- (while (and
- (not found)
- (ada-search-ignore-string-comment "(\\|)" t limit t))
- (setq nest-count
- (if (looking-at ")")
- (1+ nest-count)
- (1- nest-count)))
- (setq found (zerop nest-count))) ; end of loop
-
- (if found
- ;; if found => return column of first non-ws after the parenthesis
- (progn
- (forward-char 1)
- (if (save-excursion
- (re-search-forward "[^ \t]" nil 1)
- (backward-char 1)
- (and
- (not (looking-at "\n"))
- (setq col (current-column))))
- col
- (current-column)))
- nil))))
-
-\f
-;;;-----------------------------;;;
-;;; Simple Completion Functions ;;;
-;;;-----------------------------;;;
-
-;; These are my first steps in Emacs-Lisp ... :-) They can be replaced
-;; by functions based on the output of the Gnatf Tool that comes with
-;; the GNAT Ada compiler. See the file ada-xref.el (MH) But you might
-;; use these functions if you don't use GNAT
-
-(defun ada-use-last-with ()
- "Inserts the package name of the last 'with' statement after use."
- (interactive)
- (let ((pakname nil))
- (save-excursion
- (forward-word -1)
- (if (looking-at "use")
- ;;
- ;; find last 'with'
- ;;
- (progn (re-search-backward
- "\\(\\<with\\s-+\\)\\([a-zA-Z0-9_.]+\\)\\(\\s-*;\\)")
- ;;
- ;; get the name of the package
- ;;
- (setq pakname (concat
- (buffer-substring (match-beginning 2)
- (match-end 2))
- ";")))
- (setq pakname "")))
- (insert pakname)))
-
-
-(defun ada-complete-symbol (symboldef position symalist)
- ;; Tries to complete a symbol in the buffer.
- ;; SYMBOLDEF is the regexp to find the definition of the desired symbol.
- ;; POSITION is the position of the subexpression in SYMBOLDEF to match
- ;; the symbol itself.
- ;; SYMALIST is an alist with possibly predefined completions."
- (let ((sofar nil)
- (completed nil)
- (insertpos nil))
- (save-excursion
- ;;
- ;; get the part of the symbol already typed
- ;;
- (re-search-backward "\\([^a-zA-Z0-9_\\.]\\)\\([a-zA-Z0-9_\\.]+\\)")
- (setq sofar (buffer-substring (match-beginning 2)
- (match-end 2)))
- ;;
- ;; delete it
- ;;
- (delete-region (setq insertpos (match-beginning 2))
- (match-end 2))
- ;;
- ;; find all possible completions by searching for definitions of
- ;; this kind of symbol
- ;;
- (while (re-search-backward symboldef nil t)
- ;;
- ;; build an alist of these possible completions
- ;;
- (setq symalist (cons (cons (buffer-substring (match-beginning position)
- (match-end position))
- nil)
- symalist)))
-
- (or
- ;;
- ;; symbol gets completed as far as possible
- ;;
- (stringp (setq completed (try-completion sofar symalist)))
- ;;
- ;; or is already complete
- ;;
- (setq completed sofar)))
- ;;
- ;; insert the completed symbol
- ;;
- (goto-char insertpos)
- (insert completed)))
-
-
-(defun ada-complete-use ()
- "Tries to complete the package name in an 'use' statement in the buffer.
-Searches through former 'with' statements for possible completions."
- (interactive)
- (ada-complete-symbol
- "\\(\\<with\\s-+\\)\\([a-zA-Z0-9_.]+\\)\\(\\s-*;\\)" 2 nil)
- (insert ";"))
-
-
-(defun ada-complete-procedure ()
- "Tries to complete a procedure/function name in the buffer."
- (interactive)
- (ada-complete-symbol ada-procedure-start-regexp 2 nil))
-
-
-(defun ada-complete-variable ()
- "Tries to complete a variable name in the buffer."
- (interactive)
- (ada-complete-symbol
- "\\([^a-zA-Z0-9_]\\)\\([a-zA-Z0-9_]+\\)[ \t\n]+\\(:\\)" 2 nil))
-
+ (let ((start (if (<= (point) ada-search-paren-char-count-limit)
+ (point-min)
+ (save-excursion
+ (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
+ (goto-char (1+ (nth 1 parse-result)))
+ (if (save-excursion
+ (re-search-forward "[^ \t]" nil 1)
+ (backward-char 1)
+ (and
+ (not (looking-at "\n"))
+ (setq col (current-column))))
+ col
+ (current-column)))
+ nil)))
-(defun ada-complete-type ()
- "Tries to complete a type name in the buffer."
- (interactive)
- (ada-complete-symbol "\\(type\\)[ \t\n]+\\([a-zA-Z0-9_\\.]+\\)"
- 2
- '(("Integer" nil)
- ("Long_Integer" nil)
- ("Natural" nil)
- ("Positive" nil)
- ("Short_Integer" nil))))
\f
;;;----------------------;;;
(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)
))
-
-
(defun ada-tab-hard ()
"Indent current line to next tab stop."
(interactive)
(indent-rigidly bol eol (- 0 ada-indent))))
-(defun ada-tabsize (s)
- "changes spacing used for indentation. Reads spacing from minibuffer."
- (interactive "nnew indentation spacing: ")
- (setq ada-indent s))
-
\f
;;;---------------;;;
;;; Miscellaneous ;;;
;;;---------------;;;
(defun ada-remove-trailing-spaces ()
-;; remove all trailing spaces at the end of lines.
"remove trailing spaces in the whole buffer."
(interactive)
- (save-excursion
- (goto-char (point-min))
- (while (re-search-forward "[ \t]+$" nil t)
- (replace-match "" nil nil))))
+ (save-match-data
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (while (re-search-forward "[ \t]+$" (point-max) t)
+ (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."
+ "delete `comment-start' at the beginning of a line in the region."
(interactive "r")
(comment-region beg end -1))
;; define a function to support find-file.el if loaded
(defun ada-ff-other-window ()
- "Find other file in other window using ff-find-other-file."
+ "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 ", "))
+ ))
+
+
\f
;;;-------------------------------;;;
;;; Moving To Procedures/Packages ;;;
(define-key ada-mode-map "\C-j" 'ada-indent-newline-indent)
(define-key ada-mode-map "\t" 'ada-tab)
(define-key ada-mode-map "\C-c\C-l" 'ada-indent-region)
- ;; How do I write this for working with Lucid Emacs?
- (define-key ada-mode-map [S-tab] 'ada-untab)
+ (if (ada-xemacs)
+ (define-key ada-mode-map '(shift tab) 'ada-untab)
+ (define-key ada-mode-map [S-tab] 'ada-untab))
(define-key ada-mode-map "\C-c\C-f" 'ada-format-paramlist)
(define-key ada-mode-map "\C-c\C-p" 'ada-call-pretty-printer)
;;; We don't want to make meta-characters case-specific.
;; Movement
;;; It isn't good to redefine these. What should be done instead? -- rms.
-;;; (define-key ada-mode-map "\M-e" 'ada-next-procedure)
-;;; (define-key ada-mode-map "\M-a" 'ada-previous-procedure)
- (define-key ada-mode-map "\M-\C-e" 'ada-next-package)
- (define-key ada-mode-map "\M-\C-a" 'ada-previous-package)
+;;; (define-key ada-mode-map "\M-e" 'ada-next-package)
+;;; (define-key ada-mode-map "\M-a" 'ada-previous-package)
+ (define-key ada-mode-map "\M-\C-e" 'ada-next-procedure)
+ (define-key ada-mode-map "\M-\C-a" 'ada-previous-procedure)
(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:" 'ada-uncomment-region)
;; Change basic functionality
- (mapcar (lambda (pair)
- (substitute-key-definition (car pair) (cdr pair)
- ada-mode-map global-map))
- '((beginning-of-line . ada-beginning-of-line)
- (end-of-line . ada-end-of-line)
- (forward-to-indentation . ada-forward-to-indentation)
- ))
+
+ ;; `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
+ ;; 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 Emacs
+ ;;(mapcar (lambda (pair)
+ ;; (substitute-key-definition (car pair) (cdr pair)
+ ;; ada-mode-map global-map))
+
))
\f
;;; define menu 'Ada'
;;;-------------------
+(require 'easymenu)
+
(defun ada-add-ada-menu ()
- "Adds the menu 'Ada' to the menu-bar in Ada Mode."
- (easy-menu-define t ada-mode-map t
+ "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]
- ["previous procedure" ada-previous-procedure t]
- ["goto start" ada-move-to-start t]
- ["goto end" ada-move-to-end t]
+ ["Next Package" ada-next-package t]
+ ["Previous Package" ada-previous-package t]
+ ["Next Procedure" ada-next-procedure t]
+ ["Previous Procedure" ada-previous-procedure t]
+ ["Goto Start" ada-move-to-start t]
+ ["Goto End" ada-move-to-end t]
["------------------" nil nil]
- ["indent current line (TAB)"
+ ["Indent Current Line (TAB)"
ada-indent-current-function t]
- ["indent lines in region" ada-indent-region t]
- ["format parameter list" ada-format-paramlist t]
- ["pretty print buffer" ada-call-pretty-printer t]
+ ["Indent Lines in Region" ada-indent-region t]
+ ["Format Parameter List" ada-format-paramlist t]
+ ["Pretty Print Buffer" ada-call-pretty-printer t]
["------------" nil nil]
- ["fill comment paragraph"
+ ["Fill Comment Paragraph"
ada-fill-comment-paragraph t]
- ["justify comment paragraph"
+ ["Justify Comment Paragraph"
ada-fill-comment-paragraph-justify t]
- ["postfix comment paragraph"
+ ["Postfix Comment Paragraph"
ada-fill-comment-paragraph-postfix t]
["------------" nil nil]
- ["adjust case region" ada-adjust-case-region t]
- ["adjust case buffer" ada-adjust-case-buffer t]
+ ["Adjust Case Region" ada-adjust-case-region t]
+ ["Adjust Case Buffer" ada-adjust-case-buffer t]
["----------" nil nil]
- ["comment region" comment-region t]
- ["uncomment region" ada-uncomment-region t]
+ ["Comment Region" comment-region t]
+ ["Uncomment Region" ada-uncomment-region t]
["----------------" nil nil]
- ["compile" compile (fboundp 'compile)]
- ["next error" next-error (fboundp 'next-error)]
+ ["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
+ ["Other File Other Window" ada-ff-other-window
(fboundp 'ff-find-other-file)]
- ["other file" ff-find-other-file
- (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)))))
+
\f
;;;-------------------------------
))
;;;---------------------------------------------------
-;;; support for find-file
+;;; support for find-file.el
;;;---------------------------------------------------
-(defvar ada-krunch-args "8"
- "*Argument of gnatk8, a string containing the max number of characters.
-Set to a big number, if you dont use crunched filenames.")
+;;;###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
+ "Determine the filename of a package/procedure from its own Ada name."
+ ;; 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
(let (krunch-buf)
(setq krunch-buf (generate-new-buffer "*gkrunch*"))
(save-excursion
(set-buffer krunch-buf)
- (insert (downcase adaname))
- (goto-char (point-min))
- (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
+ ;; send adaname to external process `gnatkr'.
+ (call-process "gnatkr" nil krunch-buf nil
adaname ada-krunch-args)
;; fetch output of that process
(setq adaname (buffer-substring
(setq adaname adaname) ;; can I avoid this statement?
)
-;;;---------------------------------------------------
-;;; 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)
- ;;(backward-up-list 1) ;; needed in Ada ????
- ;; do not store forward definitions
- (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)))
+;;; functions for placing the cursor on the corresponding subprogram
+(defun ada-which-function-are-we-in ()
+ "Determine whether we are on a function definition/declaration.
+If that is the case remember the name of that function."
+
+ (setq ff-function-name nil)
+
+ (save-excursion
+ (if (re-search-backward ada-procedure-start-regexp nil t)
+ (setq ff-function-name (buffer-substring (match-beginning 0)
+ (match-end 0)))
+ ; we didn't find a procedure start, perhaps there is a package
+ (if (re-search-backward ada-package-start-regexp nil t)
+ (setq ff-function-name (buffer-substring (match-beginning 0)
+ (match-end 0)))
+ ))))
+
;;;---------------------------------------------------
;;; support for font-lock
;;;---------------------------------------------------
-;; Strings are a real pain in Ada because both ' and " can appear in a
-;; non-string quote context (the former as an operator, the latter as
-;; a character string). We follow the least losing solution, in which
-;; only " is a string quote. Therefore a character string of the form
-;; '"' will throw fontification off on the wrong track.
+;; Strings are a real pain in Ada because a single quote character is
+;; overloaded as a string quote and type/instance delimiter. By default, a
+;; single quote is given punctuation syntax in `ada-mode-syntax-table'.
+;; So, for Font Lock mode purposes, we mark single quotes as having string
+;; 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
;;
- ;; Function, package (body), pragma, procedure, task (body) plus name.
- (list (concat "\\<\\("
- "function\\|"
- "p\\(ackage\\(\\|[ \t]+body\\)\\|r\\(agma\\|ocedure\\)\\)\\|"
- "task\\(\\|[ \t]+body\\)"
- "\\)\\>[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?")
- '(1 font-lock-keyword-face) '(6 font-lock-function-name-face nil t)))
- "For consideration as a value of `ada-font-lock-keywords'.
-This does fairly subdued highlighting.")
+ ;; 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\\|"
+ "package[ \t]+body\\|"
+ "package\\|"
+ "pragma\\|"
+ "procedure\\|"
+ "protected[ \t]+body\\|"
+ "protected[ \t]+type\\|"
+ "protected\\|"
+;; "p\\(\\(ackage\\|rotected\\)\\(\\|[ \t]+\\(body\\|type\\)\\)\
+;;\\|r\\(agma\\|ocedure\\)\\)\\|"
+ "task[ \t]+body\\|"
+ "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.")
(defconst ada-font-lock-keywords-2
(append ada-font-lock-keywords-1
"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\\(a\\(gged\\|sk\\)\\|erminate\\|hen\\)\\|until\\|while\\|xor"
+ "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]*\\(\\sw+\\)?"
- (1 font-lock-keyword-face) (2 font-lock-function-name-face nil t))
+ '("\\<\\(end\\)\\>\\([ \t]+\\)?\\([a-zA-Z0-9_\\.]+\\)?"
+ (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]*"
;;
;; 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))
font-lock-type-face) nil t))
;;
;; Keywords followed by a (comma separated list of) reference.
- (list (concat "\\<\\(goto\\|raise\\|use\\|when\\|with\\)\\>"
+ (list (concat "\\<\\(goto\\|raise\\|use\\|with\\)\\>" ; "when" removed
; "[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?") ; RE
"[ \t]*\\([a-zA-Z0-9_\\.\\|, ]+\\)\\W")
- '(1 font-lock-keyword-face) '(2 font-lock-reference-face nil t))
+ '(1 font-lock-keyword-face) '(2 font-lock-constant-face nil t))
;;
;; Goto tags.
- '("<<\\(\\sw+\\)>>" 1 font-lock-reference-face)
+ '("<<\\(\\sw+\\)>>" 1 font-lock-constant-face)
))
- "For consideration as a value of `ada-font-lock-keywords'.
-This does a lot more highlighting.")
+ "Gaudy level highlighting for Ada mode.")
+
+(defvar ada-font-lock-keywords ada-font-lock-keywords-1
+ "Default expressions to highlight in Ada mode.")
-(defvar ada-font-lock-keywords ada-font-lock-keywords-2
- "*Expressions to highlight in Ada mode.")
+
+;; set font-lock properties for XEmacs
+(if (ada-xemacs)
+ (put 'ada-mode 'font-lock-defaults
+ '(ada-font-lock-keywords
+ nil t ((?\_ . "w")(?\. . "w")) beginning-of-line)))
+
+;;;
+;;; 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.
(error "No more functions/procedures")))
-(defun ada-gen-treat-proc nil
+(defun ada-gen-treat-proc (match)
;; make dummy body of a procedure/function specification.
- (goto-char (match-end 0))
- (let ((wend (point))
- (wstart (progn (re-search-backward "[ ][a-zA-Z0-9_\"]+" nil t)
- (+ (match-beginning 0) 1)))) ; delete leading WS
- (copy-region-as-kill wstart wend) ; store proc name in kill-buffer
-
-
- ;; if the next notWS char is '(' ==> parameterlist follows
- ;; if the next notWS char is ';' ==> no paramterlist
- ;; if the next notWS char is 'r' ==> paramterless function, search ';'
-
- ;; goto end of regex before last (= end of procname)
- (goto-char (match-end 0))
+ ;; MATCH is a cons cell containing the start and end location of the
+ ;; last search for ada-procedure-start-regexp.
+ (goto-char (car match))
+ (let (proc-found func-found procname functype)
+ (cond
+ ((or (setq proc-found (looking-at "^[ \t]*procedure"))
+ (setq func-found (looking-at "^[ \t]*function")))
+ ;; treat it as a proc/func
+ (forward-word 2)
+ (forward-word -1)
+ (setq procname (buffer-substring (point) (cdr match))) ; store proc name
+
+ ;; goto end of procname
+ (goto-char (cdr match))
+
+ ;; skip over parameterlist
+ (forward-sexp)
+ ;; if function, skip over 'return' and result type.
+ (if func-found
+ (progn
+ (forward-word 1)
+ (skip-chars-forward " \t\n")
+ (setq functype (buffer-substring (point)
+ (progn
+ (skip-chars-forward
+ "a-zA-Z0-9_\.")
+ (point))))))
;; look for next non WS
- (backward-char)
- (re-search-forward "[ ]*.")
- (if (char-equal (char-after (match-end 0)) ?\;)
- (delete-char 1) ;; delete the ';'
+ (cond
+ ((looking-at "[ \t]*;")
+ (delete-region (match-beginning 0) (match-end 0)) ;; delete the ';'
+ (ada-indent-newline-indent)
+ (insert " is")
+ (ada-indent-newline-indent)
+ (if func-found
+ (progn
+ (insert "Result : ")
+ (insert functype)
+ (insert ";")
+ (ada-indent-newline-indent)))
+ (insert "begin -- ")
+ (insert procname)
+ (ada-indent-newline-indent)
+ (insert "null;")
+ (ada-indent-newline-indent)
+ (if func-found
+ (progn
+ (insert "return Result;")
+ (ada-indent-newline-indent)))
+ (insert "end ")
+ (insert procname)
+ (insert ";")
+ (ada-indent-newline-indent)
+ )
;; else
- ;; find ');' or 'return <id> ;'
- (re-search-forward
- "\\()[ \t]*;\\)\\|\\(return[ \t]+[a-zA-Z0-9_]+[ \t]*;\\)" nil t)
- (goto-char (match-end 0))
- (delete-backward-char 1) ;; delete the ';'
+ ((looking-at "[ \t\n]*is")
+ ;; do nothing
)
-
- (insert " is")
- ;; if it is a function, we should generate a return variable and a
- ;; return statement. Sth. like "Result : <return-type>;" and a
- ;; "return Result;".
- (ada-indent-newline-indent)
- (insert "begin -- ")
- (yank)
- (newline)
- (insert "null;")
- (newline)
- (insert "end ")
- (yank)
- (insert ";")
- (ada-indent-newline-indent))
-
-
-(defun ada-gen-make-bodyfile (spec-filename)
- "Create a new buffer containing the correspondig Ada body
-to the current specs."
- (interactive "b")
-;;; (let* (
-;;; (file-name (ada-body-filename spec-filename))
-;;; (buf (get-buffer-create file-name)))
-;;; (switch-to-buffer buf)
-;;; (ada-mode)
- (ff-find-other-file t t)
-;;; (if (= (buffer-size) 0)
-;;; (make-header)
-;;; ;; make nothing, autoinsert.el had put something in already
-;;; )
- (end-of-buffer)
- (let ((hlen (count-lines (point-min) (point-max))))
- (insert-buffer spec-filename)
- ;; hlen lines have already been inserted automatically
+ ((looking-at "[ \t\n]*rename")
+ ;; do nothing
)
+ (t
+ (message "unknown syntax")))
+ ))))
- (if (re-search-forward ada-package-start-regexp nil t)
- (progn (goto-char (match-end 1))
- (insert " body"))
+
+(defun ada-make-body ()
+ "Create an Ada package body in the current buffer.
+The potential old buffer contents is deleted first, then we copy the
+spec buffer in here and modify it to make it a body.
+
+This function typically is to be hooked into `ff-file-created-hooks'."
+ (interactive)
+ (delete-region (point-min) (point-max))
+ (insert-buffer (car (cdr (buffer-list))))
+ (ada-mode)
+
+ (let (found)
+ (if (setq found
+ (ada-search-ignore-string-comment ada-package-start-regexp))
+ (progn (goto-char (cdr found))
+ (insert " body")
+ ;; (forward-line -1)
+ ;;(comment-region (point-min) (point))
+ )
(error "No package"))
- ; (comment-until-proc)
- ; does not work correctly
- ; must be done by hand
-
- (while (re-search-forward ada-procedure-start-regexp nil t)
- (ada-gen-treat-proc))
-
- ; don't overwrite an eventually
- ; existing file
-; (if (file-exists-p file-name)
-; (error "File with this name already exists!")
-; (write-file file-name))
- ))
+
+ ;; (comment-until-proc)
+ ;; does not work correctly
+ ;; must be done by hand
+
+ (while (setq found
+ (ada-search-ignore-string-comment ada-procedure-start-regexp))
+ (ada-gen-treat-proc found))))
+
;;; provide ourself