Mercurial > emacs

comparison lisp/progmodes/ada-mode.el @ 25903:812005e9c20e

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