Commit | Line | Data |
---|---|---|
3afbc435 | 1 | ;;; ada-mode.el --- major-mode for editing Ada sources |
972579f9 | 2 | |
034babe1 | 3 | ;; Copyright (C) 1994, 1995, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, |
5df4f04c | 4 | ;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. |
972579f9 | 5 | |
7749c1a8 GM |
6 | ;; Author: Rolf Ebert <ebert@inf.enst.fr> |
7 | ;; Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de> | |
8 | ;; Emmanuel Briot <briot@gnat.com> | |
f70b58b0 | 9 | ;; Maintainer: Stephen Leake <stephen_leake@member.fsf.org> |
7749c1a8 | 10 | ;; Keywords: languages ada |
d03b8a2d | 11 | |
3afbc435 | 12 | ;; This file is part of GNU Emacs. |
972579f9 | 13 | |
b1fc2b50 | 14 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
972579f9 | 15 | ;; it under the terms of the GNU General Public License as published by |
b1fc2b50 GM |
16 | ;; the Free Software Foundation, either version 3 of the License, or |
17 | ;; (at your option) any later version. | |
972579f9 | 18 | |
2be7dabc | 19 | ;; GNU Emacs is distributed in the hope that it will be useful, |
972579f9 RS |
20 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
21 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
22 | ;; GNU General Public License for more details. | |
23 | ||
24 | ;; You should have received a copy of the GNU General Public License | |
b1fc2b50 | 25 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
7749c1a8 GM |
26 | |
27 | ;;; Commentary: | |
23b747d1 SM |
28 | ;; This mode is a major mode for editing Ada code. This is a major |
29 | ;; rewrite of the file packaged with Emacs-20. The Ada mode is | |
30 | ;; composed of four Lisp files: ada-mode.el, ada-xref.el, ada-prj.el | |
31 | ;; and ada-stmt.el. Only this file (ada-mode.el) is completely | |
32 | ;; independent from the GNU Ada compiler GNAT, distributed by Ada | |
33 | ;; Core Technologies. All the other files rely heavily on features | |
34 | ;; provided only by GNAT. | |
35 | ;; | |
36 | ;; Note: this mode will not work with Emacs 19. If you are on a VMS | |
37 | ;; system, where the latest version of Emacs is 19.28, you will need | |
38 | ;; another file, called ada-vms.el, that provides some required | |
39 | ;; functions. | |
7749c1a8 GM |
40 | |
41 | ;;; Usage: | |
23b747d1 SM |
42 | ;; Emacs should enter Ada mode automatically when you load an Ada file. |
43 | ;; By default, the valid extensions for Ada files are .ads, .adb or .ada | |
44 | ;; If the ada-mode does not start automatically, then simply type the | |
45 | ;; following command : | |
46 | ;; M-x ada-mode | |
47 | ;; | |
48 | ;; By default, ada-mode is configured to take full advantage of the GNAT | |
49 | ;; compiler (the menus will include the cross-referencing features,...). | |
50 | ;; If you are using another compiler, you might want to set the following | |
51 | ;; variable in your .emacs (Note: do not set this in the ada-mode-hook, it | |
52 | ;; won't work) : | |
53 | ;; (setq ada-which-compiler 'generic) | |
54 | ;; | |
55 | ;; This mode requires find-file.el to be present on your system. | |
972579f9 | 56 | |
7749c1a8 | 57 | ;;; History: |
23b747d1 SM |
58 | ;; The first Ada mode for GNU Emacs was written by V. Broman in |
59 | ;; 1985. He based his work on the already existing Modula-2 mode. | |
60 | ;; This was distributed as ada.el in versions of Emacs prior to 19.29. | |
61 | ;; | |
62 | ;; Lynn Slater wrote an extensive Ada mode in 1989. It consisted of | |
63 | ;; several files with support for dired commands and other nice | |
64 | ;; things. It is currently available from the PAL | |
65 | ;; (wuarchive.wustl.edu:/languages/ada) as ada-mode-1.06a.tar.Z. | |
66 | ;; | |
67 | ;; The probably very first Ada mode (called electric-ada.el) was | |
68 | ;; written by Steven D. Litvintchouk and Steven M. Rosen for the | |
69 | ;; Gosling Emacs. L. Slater based his development on ada.el and | |
70 | ;; electric-ada.el. | |
71 | ;; | |
72 | ;; A complete rewrite by M. Heritsch and R. Ebert has been done. | |
73 | ;; Some ideas from the Ada mode mailing list have been | |
74 | ;; added. Some of the functionality of L. Slater's mode has not | |
75 | ;; (yet) been recoded in this new mode. Perhaps you prefer sticking | |
76 | ;; to his version. | |
77 | ;; | |
78 | ;; A complete rewrite for Emacs-20 / GNAT-3.11 has been done by Ada Core | |
79 | ;; Technologies. | |
7749c1a8 GM |
80 | |
81 | ;;; Credits: | |
23b747d1 SM |
82 | ;; Many thanks to John McCabe <john@assen.demon.co.uk> for sending so |
83 | ;; many patches included in this package. | |
84 | ;; Christian Egli <Christian.Egli@hcsd.hac.com>: | |
85 | ;; ada-imenu-generic-expression | |
86 | ;; Many thanks also to the following persons that have contributed | |
87 | ;; to the ada-mode | |
88 | ;; Philippe Waroquiers (PW) <philippe@cfmu.eurocontrol.be> in particular, | |
89 | ;; woodruff@stc.llnl.gov (John Woodruff) | |
90 | ;; jj@ddci.dk (Jesper Joergensen) | |
91 | ;; gse@ocsystems.com (Scott Evans) | |
92 | ;; comar@gnat.com (Cyrille Comar) | |
93 | ;; stephen.leake@gsfc.nasa.gov (Stephen Leake) | |
94 | ;; robin-reply@reagans.org | |
95 | ;; and others for their valuable hints. | |
972579f9 | 96 | |
7749c1a8 | 97 | ;;; Code: |
23b747d1 SM |
98 | ;; Note: Every function in this package is compiler-independent. |
99 | ;; The names start with ada- | |
100 | ;; The variables that the user can edit can all be modified through | |
101 | ;; the customize mode. They are sorted in alphabetical order in this | |
102 | ;; file. | |
103 | ||
104 | ;; Supported packages. | |
105 | ;; This package supports a number of other Emacs modes. These other modes | |
106 | ;; should be loaded before the ada-mode, which will then setup some variables | |
107 | ;; to improve the support for Ada code. | |
108 | ;; Here is the list of these modes: | |
109 | ;; `which-function-mode': Display the name of the subprogram the cursor is | |
110 | ;; in in the mode line. | |
111 | ;; `outline-mode': Provides the capability to collapse or expand the code | |
112 | ;; for specific language constructs, for instance if you want to hide the | |
113 | ;; code corresponding to a subprogram | |
114 | ;; `align': This mode is now provided with Emacs 21, but can also be | |
115 | ;; installed manually for older versions of Emacs. It provides the | |
116 | ;; capability to automatically realign the selected region (for instance | |
117 | ;; all ':=', ':' and '--' will be aligned on top of each other. | |
118 | ;; `imenu': Provides a menu with the list of entities defined in the current | |
119 | ;; buffer, and an easy way to jump to any of them | |
120 | ;; `speedbar': Provides a separate file browser, and the capability for each | |
121 | ;; file to see the list of entities defined in it and to jump to them | |
122 | ;; easily | |
123 | ;; `abbrev-mode': Provides the capability to define abbreviations, which | |
124 | ;; are automatically expanded when you type them. See the Emacs manual. | |
4607c7f4 | 125 | |
dc786b8a JB |
126 | (require 'find-file nil t) |
127 | (require 'align nil t) | |
128 | (require 'which-func nil t) | |
129 | (require 'compile nil t) | |
7749c1a8 | 130 | |
7fdb5d54 | 131 | (defvar ispell-check-comments) |
5f7286f2 JB |
132 | (defvar skeleton-further-elements) |
133 | ||
f70b58b0 JB |
134 | (defun ada-mode-version () |
135 | "Return Ada mode version." | |
136 | (interactive) | |
d5875b25 | 137 | (let ((version-string "4.00")) |
32226619 | 138 | (if (called-interactively-p 'interactive) |
f70b58b0 JB |
139 | (message version-string) |
140 | version-string))) | |
141 | ||
7749c1a8 GM |
142 | (defvar ada-mode-hook nil |
143 | "*List of functions to call when Ada mode is invoked. | |
f7a80909 | 144 | This hook is automatically executed after the `ada-mode' is |
7749c1a8 GM |
145 | fully loaded. |
146 | This is a good place to add Ada environment specific bindings.") | |
52748d95 RS |
147 | |
148 | (defgroup ada nil | |
f70b58b0 | 149 | "Major mode for editing and compiling Ada source in Emacs." |
8ec3bce0 | 150 | :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces) |
52748d95 RS |
151 | :group 'languages) |
152 | ||
7749c1a8 GM |
153 | (defcustom ada-auto-case t |
154 | "*Non-nil means automatically change case of preceding word while typing. | |
155 | Casing is done according to `ada-case-keyword', `ada-case-identifier' | |
156 | and `ada-case-attribute'." | |
157 | :type 'boolean :group 'ada) | |
972579f9 | 158 | |
7749c1a8 GM |
159 | (defcustom ada-broken-decl-indent 0 |
160 | "*Number of columns to indent a broken declaration. | |
161 | ||
162 | An example is : | |
163 | declare | |
164 | A, | |
f70b58b0 | 165 | >>>>>B : Integer;" |
7749c1a8 | 166 | :type 'integer :group 'ada) |
972579f9 | 167 | |
52748d95 | 168 | (defcustom ada-broken-indent 2 |
7749c1a8 | 169 | "*Number of columns to indent the continuation of a broken line. |
972579f9 | 170 | |
7749c1a8 GM |
171 | An example is : |
172 | My_Var : My_Type := (Field1 => | |
f70b58b0 | 173 | >>>>>>>>>Value);" |
7749c1a8 | 174 | :type 'integer :group 'ada) |
972579f9 | 175 | |
80d50f88 | 176 | (defcustom ada-continuation-indent ada-broken-indent |
6d533a6e | 177 | "*Number of columns to indent the continuation of broken lines in parenthesis. |
80d50f88 SM |
178 | |
179 | An example is : | |
180 | Func (Param1, | |
f70b58b0 | 181 | >>>>>Param2);" |
80d50f88 SM |
182 | :type 'integer :group 'ada) |
183 | ||
7749c1a8 GM |
184 | (defcustom ada-case-attribute 'ada-capitalize-word |
185 | "*Function to call to adjust the case of Ada attributes. | |
4cc7e498 GM |
186 | It may be `downcase-word', `upcase-word', `ada-loose-case-word', |
187 | `ada-capitalize-word' or `ada-no-auto-case'." | |
7749c1a8 | 188 | :type '(choice (const downcase-word) |
f70b58b0 JB |
189 | (const upcase-word) |
190 | (const ada-capitalize-word) | |
191 | (const ada-loose-case-word) | |
192 | (const ada-no-auto-case)) | |
52748d95 | 193 | :group 'ada) |
972579f9 | 194 | |
4607c7f4 SM |
195 | (defcustom ada-case-exception-file |
196 | (list (convert-standard-filename' "~/.emacs_case_exceptions")) | |
4cc7e498 GM |
197 | "*List of special casing exceptions dictionaries for identifiers. |
198 | The first file is the one where new exceptions will be saved by Emacs | |
199 | when you call `ada-create-case-exception'. | |
200 | ||
201 | These files should contain one word per line, that gives the casing | |
6d533a6e | 202 | to be used for that word in Ada files. If the line starts with the |
4607c7f4 SM |
203 | character *, then the exception will be used for substrings that either |
204 | start at the beginning of a word or after a _ character, and end either | |
97a62f83 JB |
205 | at the end of the word or at a _ character. Each line can be terminated |
206 | by a comment." | |
4cc7e498 GM |
207 | :type '(repeat (file)) |
208 | :group 'ada) | |
972579f9 | 209 | |
7749c1a8 | 210 | (defcustom ada-case-keyword 'downcase-word |
655880d2 | 211 | "*Function to call to adjust the case of an Ada keywords. |
7749c1a8 GM |
212 | It may be `downcase-word', `upcase-word', `ada-loose-case-word' or |
213 | `ada-capitalize-word'." | |
214 | :type '(choice (const downcase-word) | |
f70b58b0 JB |
215 | (const upcase-word) |
216 | (const ada-capitalize-word) | |
217 | (const ada-loose-case-word) | |
218 | (const ada-no-auto-case)) | |
52748d95 | 219 | :group 'ada) |
972579f9 | 220 | |
7749c1a8 GM |
221 | (defcustom ada-case-identifier 'ada-loose-case-word |
222 | "*Function to call to adjust the case of an Ada identifier. | |
223 | It may be `downcase-word', `upcase-word', `ada-loose-case-word' or | |
224 | `ada-capitalize-word'." | |
225 | :type '(choice (const downcase-word) | |
f70b58b0 JB |
226 | (const upcase-word) |
227 | (const ada-capitalize-word) | |
228 | (const ada-loose-case-word) | |
229 | (const ada-no-auto-case)) | |
52748d95 | 230 | :group 'ada) |
972579f9 | 231 | |
7749c1a8 | 232 | (defcustom ada-clean-buffer-before-saving t |
655880d2 | 233 | "*Non-nil means remove trailing spaces and untabify the buffer before saving." |
7749c1a8 | 234 | :type 'boolean :group 'ada) |
5c9434d0 SL |
235 | (make-obsolete-variable 'ada-clean-buffer-before-saving |
236 | "use the `write-file-functions' hook." | |
237 | "23.2") | |
238 | ||
972579f9 | 239 | |
7749c1a8 GM |
240 | (defcustom ada-indent 3 |
241 | "*Size of Ada indentation. | |
972579f9 | 242 | |
7749c1a8 GM |
243 | An example is : |
244 | procedure Foo is | |
245 | begin | |
f70b58b0 | 246 | >>>>>>>>>>null;" |
7749c1a8 | 247 | :type 'integer :group 'ada) |
972579f9 | 248 | |
7749c1a8 GM |
249 | (defcustom ada-indent-after-return t |
250 | "*Non-nil means automatically indent after RET or LFD." | |
251 | :type 'boolean :group 'ada) | |
972579f9 | 252 | |
4cc7e498 GM |
253 | (defcustom ada-indent-align-comments t |
254 | "*Non-nil means align comments on previous line comments, if any. | |
255 | If nil, indentation is calculated as usual. | |
256 | Note that indentation is calculated only if `ada-indent-comment-as-code' is t. | |
257 | ||
258 | For instance: | |
259 | A := 1; -- A multi-line comment | |
b06a3bb5 | 260 | -- aligned if `ada-indent-align-comments' is t" |
4cc7e498 GM |
261 | :type 'boolean :group 'ada) |
262 | ||
7749c1a8 | 263 | (defcustom ada-indent-comment-as-code t |
4cc7e498 | 264 | "*Non-nil means indent comment lines as code. |
6d533a6e | 265 | A nil value means do not auto-indent comments." |
7749c1a8 | 266 | :type 'boolean :group 'ada) |
972579f9 | 267 | |
4607c7f4 | 268 | (defcustom ada-indent-handle-comment-special nil |
6d533a6e | 269 | "*Non-nil if comment lines should be handled specially inside parenthesis. |
4607c7f4 SM |
270 | By default, if the line that contains the open parenthesis has some |
271 | text following it, then the following lines will be indented in the | |
6d533a6e | 272 | same column as this text. This will not be true if the first line is |
4607c7f4 SM |
273 | a comment and `ada-indent-handle-comment-special' is t. |
274 | ||
275 | type A is | |
276 | ( Value_1, -- common behavior, when not a comment | |
277 | Value_2); | |
278 | ||
279 | type A is | |
280 | ( -- `ada-indent-handle-comment-special' is nil | |
281 | Value_1, | |
282 | Value_2); | |
283 | ||
284 | type A is | |
285 | ( -- `ada-indent-handle-comment-special' is non-nil | |
286 | Value_1, | |
287 | Value_2);" | |
288 | :type 'boolean :group 'ada) | |
a1506d29 | 289 | |
7749c1a8 GM |
290 | (defcustom ada-indent-is-separate t |
291 | "*Non-nil means indent 'is separate' or 'is abstract' if on a single line." | |
292 | :type 'boolean :group 'ada) | |
972579f9 | 293 | |
7749c1a8 GM |
294 | (defcustom ada-indent-record-rel-type 3 |
295 | "*Indentation for 'record' relative to 'type' or 'use'. | |
52748d95 | 296 | |
7749c1a8 GM |
297 | An example is: |
298 | type A is | |
f70b58b0 | 299 | >>>>>>>>>>>record" |
7749c1a8 | 300 | :type 'integer :group 'ada) |
52748d95 | 301 | |
4cc7e498 GM |
302 | (defcustom ada-indent-renames ada-broken-indent |
303 | "*Indentation for renames relative to the matching function statement. | |
6d533a6e JB |
304 | If `ada-indent-return' is null or negative, the indentation is done relative to |
305 | the open parenthesis (if there is no parenthesis, `ada-broken-indent' is used). | |
4cc7e498 GM |
306 | |
307 | An example is: | |
308 | function A (B : Integer) | |
f70b58b0 JB |
309 | return C; |
310 | >>>renames Foo;" | |
4cc7e498 GM |
311 | :type 'integer :group 'ada) |
312 | ||
7749c1a8 GM |
313 | (defcustom ada-indent-return 0 |
314 | "*Indentation for 'return' relative to the matching 'function' statement. | |
6d533a6e JB |
315 | If `ada-indent-return' is null or negative, the indentation is done relative to |
316 | the open parenthesis (if there is no parenthesis, `ada-broken-indent' is used). | |
52748d95 | 317 | |
7749c1a8 GM |
318 | An example is: |
319 | function A (B : Integer) | |
f70b58b0 | 320 | >>>>>return C;" |
7749c1a8 | 321 | :type 'integer :group 'ada) |
52748d95 | 322 | |
7749c1a8 GM |
323 | (defcustom ada-indent-to-open-paren t |
324 | "*Non-nil means indent according to the innermost open parenthesis." | |
325 | :type 'boolean :group 'ada) | |
52748d95 | 326 | |
5ebcaf36 | 327 | (defcustom ada-fill-comment-prefix "-- " |
7749c1a8 | 328 | "*Text inserted in the first columns when filling a comment paragraph. |
10bcf543 RS |
329 | Note: if you modify this variable, you will have to invoke `ada-mode' |
330 | again to take account of the new value." | |
7749c1a8 | 331 | :type 'string :group 'ada) |
52748d95 | 332 | |
7749c1a8 GM |
333 | (defcustom ada-fill-comment-postfix " --" |
334 | "*Text inserted at the end of each line when filling a comment paragraph. | |
6d533a6e | 335 | Used by `ada-fill-comment-paragraph-postfix'." |
7749c1a8 | 336 | :type 'string :group 'ada) |
52748d95 | 337 | |
7749c1a8 GM |
338 | (defcustom ada-label-indent -4 |
339 | "*Number of columns to indent a label. | |
52748d95 | 340 | |
7749c1a8 GM |
341 | An example is: |
342 | procedure Foo is | |
343 | begin | |
f70b58b0 | 344 | >>>>Label: |
80d50f88 SM |
345 | |
346 | This is also used for <<..>> labels" | |
7749c1a8 | 347 | :type 'integer :group 'ada) |
52748d95 RS |
348 | |
349 | (defcustom ada-language-version 'ada95 | |
7fdb5d54 JB |
350 | "*Ada language version; one of `ada83', `ada95', `ada2005'." |
351 | :type '(choice (const ada83) (const ada95) (const ada2005)) :group 'ada) | |
52748d95 | 352 | |
7749c1a8 | 353 | (defcustom ada-move-to-declaration nil |
f70b58b0 | 354 | "*Non-nil means `ada-move-to-start' moves to the subprogram declaration, not to 'begin'." |
7749c1a8 | 355 | :type 'boolean :group 'ada) |
972579f9 | 356 | |
7749c1a8 GM |
357 | (defcustom ada-popup-key '[down-mouse-3] |
358 | "*Key used for binding the contextual menu. | |
4cc7e498 | 359 | If nil, no contextual menu is available." |
7c5fd355 | 360 | :type '(restricted-sexp :match-alternatives (stringp vectorp)) |
50a8310e | 361 | :group 'ada) |
cadd3658 | 362 | |
7749c1a8 | 363 | (defcustom ada-search-directories |
f7a80909 JB |
364 | (append '(".") |
365 | (split-string (or (getenv "ADA_INCLUDE_PATH") "") ":") | |
366 | '("/usr/adainclude" "/usr/local/adainclude" | |
367 | "/opt/gnu/adainclude")) | |
f70b58b0 | 368 | "*Default list of directories to search for Ada files. |
6d533a6e | 369 | See the description for the `ff-search-directories' variable. This variable |
f70b58b0 | 370 | is the initial value of `ada-search-directories-internal'." |
7749c1a8 | 371 | :type '(repeat (choice :tag "Directory" |
f70b58b0 JB |
372 | (const :tag "default" nil) |
373 | (directory :format "%v"))) | |
52748d95 | 374 | :group 'ada) |
cadd3658 | 375 | |
6f9a2614 JB |
376 | (defvar ada-search-directories-internal ada-search-directories |
377 | "Internal version of `ada-search-directories'. | |
378 | Its value is the concatenation of the search path as read in the project file | |
379 | and the standard runtime location, and the value of the user-defined | |
6d533a6e | 380 | `ada-search-directories'.") |
6f9a2614 | 381 | |
7749c1a8 | 382 | (defcustom ada-stmt-end-indent 0 |
655880d2 | 383 | "*Number of columns to indent the end of a statement on a separate line. |
cadd3658 | 384 | |
7749c1a8 GM |
385 | An example is: |
386 | if A = B | |
f70b58b0 | 387 | >>>>then" |
7749c1a8 | 388 | :type 'integer :group 'ada) |
cadd3658 | 389 | |
7749c1a8 | 390 | (defcustom ada-tab-policy 'indent-auto |
655880d2 | 391 | "*Control the behavior of the TAB key. |
7749c1a8 | 392 | Must be one of : |
6d533a6e | 393 | `indent-rigidly' : always adds `ada-indent' blanks at the beginning of the line. |
7749c1a8 | 394 | `indent-auto' : use indentation functions in this file. |
f70b58b0 | 395 | `always-tab' : do `indent-relative'." |
7749c1a8 | 396 | :type '(choice (const indent-auto) |
f70b58b0 JB |
397 | (const indent-rigidly) |
398 | (const always-tab)) | |
52748d95 | 399 | :group 'ada) |
972579f9 | 400 | |
4cc7e498 GM |
401 | (defcustom ada-use-indent ada-broken-indent |
402 | "*Indentation for the lines in a 'use' statement. | |
403 | ||
404 | An example is: | |
405 | use Ada.Text_IO, | |
f70b58b0 | 406 | >>>>Ada.Numerics;" |
4cc7e498 GM |
407 | :type 'integer :group 'ada) |
408 | ||
7749c1a8 GM |
409 | (defcustom ada-when-indent 3 |
410 | "*Indentation for 'when' relative to 'exception' or 'case'. | |
411 | ||
412 | An example is: | |
413 | case A is | |
f70b58b0 | 414 | >>>>when B =>" |
7749c1a8 GM |
415 | :type 'integer :group 'ada) |
416 | ||
4cc7e498 GM |
417 | (defcustom ada-with-indent ada-broken-indent |
418 | "*Indentation for the lines in a 'with' statement. | |
419 | ||
420 | An example is: | |
421 | with Ada.Text_IO, | |
f70b58b0 | 422 | >>>>Ada.Numerics;" |
4cc7e498 GM |
423 | :type 'integer :group 'ada) |
424 | ||
7749c1a8 | 425 | (defcustom ada-which-compiler 'gnat |
655880d2 | 426 | "*Name of the compiler to use. |
0347188a | 427 | This will determine what features are made available through the Ada mode. |
97a62f83 | 428 | The possible choices are: |
1babb7ea | 429 | `gnat': Use Ada Core Technologies' GNAT compiler. Add some cross-referencing |
97a62f83 JB |
430 | features. |
431 | `generic': Use a generic compiler." | |
7749c1a8 | 432 | :type '(choice (const gnat) |
f70b58b0 | 433 | (const generic)) |
52748d95 | 434 | :group 'ada) |
972579f9 | 435 | |
972579f9 RS |
436 | |
437 | ;;; ---- end of user configurable variables | |
438 | \f | |
439 | ||
7749c1a8 | 440 | (defvar ada-body-suffixes '(".adb") |
655880d2 GM |
441 | "List of possible suffixes for Ada body files. |
442 | The extensions should include a `.' if needed.") | |
7749c1a8 GM |
443 | |
444 | (defvar ada-spec-suffixes '(".ads") | |
655880d2 GM |
445 | "List of possible suffixes for Ada spec files. |
446 | The extensions should include a `.' if needed.") | |
7749c1a8 | 447 | |
88127f30 | 448 | (defvar ada-mode-menu (make-sparse-keymap "Ada") |
0347188a | 449 | "Menu for Ada mode.") |
972579f9 | 450 | |
7749c1a8 | 451 | (defvar ada-mode-map (make-sparse-keymap) |
cadd3658 | 452 | "Local keymap used for Ada mode.") |
972579f9 | 453 | |
a3507bd3 SM |
454 | (defvar ada-mode-extra-map (make-sparse-keymap) |
455 | "Keymap used for non-standard keybindings.") | |
456 | ||
457 | ;; default is C-c C-q because it's free in ada-mode-map | |
458 | (defvar ada-mode-extra-prefix "\C-c\C-q" | |
459 | "Prefix key to access `ada-mode-extra-map' functions.") | |
460 | ||
4cc7e498 GM |
461 | (defvar ada-mode-abbrev-table nil |
462 | "Local abbrev table for Ada mode.") | |
463 | ||
972579f9 RS |
464 | (defvar ada-mode-syntax-table nil |
465 | "Syntax table to be used for editing Ada source code.") | |
466 | ||
f139ce87 KH |
467 | (defvar ada-mode-symbol-syntax-table nil |
468 | "Syntax table for Ada, where `_' is a word constituent.") | |
469 | ||
1d424b58 | 470 | (eval-when-compile |
d4ee31d3 | 471 | ;; These values are used in eval-when-compile expressions. |
1d424b58 JB |
472 | (defconst ada-83-string-keywords |
473 | '("abort" "abs" "accept" "access" "all" "and" "array" "at" "begin" | |
474 | "body" "case" "constant" "declare" "delay" "delta" "digits" "do" | |
475 | "else" "elsif" "end" "entry" "exception" "exit" "for" "function" | |
476 | "generic" "goto" "if" "in" "is" "limited" "loop" "mod" "new" | |
477 | "not" "null" "of" "or" "others" "out" "package" "pragma" "private" | |
478 | "procedure" "raise" "range" "record" "rem" "renames" "return" | |
479 | "reverse" "select" "separate" "subtype" "task" "terminate" "then" | |
480 | "type" "use" "when" "while" "with" "xor") | |
481 | "List of Ada 83 keywords. | |
7fdb5d54 JB |
482 | Used to define `ada-*-keywords'.") |
483 | ||
1d424b58 JB |
484 | (defconst ada-95-string-keywords |
485 | '("abstract" "aliased" "protected" "requeue" "tagged" "until") | |
486 | "List of keywords new in Ada 95. | |
7fdb5d54 JB |
487 | Used to define `ada-*-keywords'.") |
488 | ||
1d424b58 JB |
489 | (defconst ada-2005-string-keywords |
490 | '("interface" "overriding" "synchronized") | |
491 | "List of keywords new in Ada 2005. | |
492 | Used to define `ada-*-keywords.'")) | |
7749c1a8 GM |
493 | |
494 | (defvar ada-ret-binding nil | |
495 | "Variable to save key binding of RET when casing is activated.") | |
496 | ||
497 | (defvar ada-case-exception '() | |
655880d2 | 498 | "Alist of words (entities) that have special casing.") |
7749c1a8 | 499 | |
4607c7f4 SM |
500 | (defvar ada-case-exception-substring '() |
501 | "Alist of substrings (entities) that have special casing. | |
502 | The substrings are detected for word constituant when the word | |
6d533a6e | 503 | is not itself in `ada-case-exception', and only for substrings that |
4607c7f4 SM |
504 | either are at the beginning or end of the word, or start after '_'.") |
505 | ||
7749c1a8 GM |
506 | (defvar ada-lfd-binding nil |
507 | "Variable to save key binding of LFD when casing is activated.") | |
508 | ||
509 | (defvar ada-other-file-alist nil | |
6d533a6e | 510 | "Variable used by `find-file' to find the name of the other package. |
655880d2 | 511 | See `ff-other-file-alist'.") |
7749c1a8 | 512 | |
4607c7f4 SM |
513 | (defvar ada-align-list |
514 | '(("[^:]\\(\\s-*\\):[^:]" 1 t) | |
515 | ("[^=]\\(\\s-+\\)=[^=]" 1 t) | |
516 | ("\\(\\s-*\\)use\\s-" 1) | |
517 | ("\\(\\s-*\\)--" 1)) | |
f70b58b0 | 518 | "Ada support for align.el <= 2.2. |
4607c7f4 SM |
519 | This variable provides regular expressions on which to align different lines. |
520 | See `align-mode-alist' for more information.") | |
521 | ||
522 | (defvar ada-align-modes | |
523 | '((ada-declaration | |
524 | (regexp . "[^:]\\(\\s-*\\):[^:]") | |
525 | (valid . (lambda() (not (ada-in-comment-p)))) | |
526 | (modes . '(ada-mode))) | |
527 | (ada-assignment | |
528 | (regexp . "[^=]\\(\\s-+\\)=[^=]") | |
529 | (valid . (lambda() (not (ada-in-comment-p)))) | |
530 | (modes . '(ada-mode))) | |
531 | (ada-comment | |
532 | (regexp . "\\(\\s-*\\)--") | |
533 | (modes . '(ada-mode))) | |
534 | (ada-use | |
535 | (regexp . "\\(\\s-*\\)use\\s-") | |
536 | (valid . (lambda() (not (ada-in-comment-p)))) | |
537 | (modes . '(ada-mode))) | |
538 | ) | |
97a62f83 | 539 | "Ada support for align.el >= 2.8. |
4607c7f4 SM |
540 | This variable defines several rules to use to align different lines.") |
541 | ||
542 | (defconst ada-align-region-separate | |
7fdb5d54 JB |
543 | (eval-when-compile |
544 | (concat | |
545 | "^\\s-*\\($\\|\\(" | |
546 | "begin\\|" | |
547 | "declare\\|" | |
548 | "else\\|" | |
549 | "end\\|" | |
550 | "exception\\|" | |
551 | "for\\|" | |
552 | "function\\|" | |
553 | "generic\\|" | |
554 | "if\\|" | |
555 | "is\\|" | |
556 | "procedure\\|" | |
557 | "record\\|" | |
558 | "return\\|" | |
559 | "type\\|" | |
560 | "when" | |
561 | "\\)\\>\\)")) | |
6d533a6e | 562 | "See the variable `align-region-separate' for more information.") |
4607c7f4 | 563 | |
7749c1a8 GM |
564 | ;;; ---- Below are the regexp used in this package for parsing |
565 | ||
972579f9 | 566 | (defconst ada-83-keywords |
7749c1a8 GM |
567 | (eval-when-compile |
568 | (concat "\\<" (regexp-opt ada-83-string-keywords t) "\\>")) | |
dc786b8a | 569 | "Regular expression matching Ada83 keywords.") |
972579f9 | 570 | |
f139ce87 | 571 | (defconst ada-95-keywords |
7749c1a8 GM |
572 | (eval-when-compile |
573 | (concat "\\<" (regexp-opt | |
f70b58b0 | 574 | (append |
dc786b8a | 575 | ada-95-string-keywords |
f70b58b0 | 576 | ada-83-string-keywords) t) "\\>")) |
dc786b8a | 577 | "Regular expression matching Ada95 keywords.") |
972579f9 | 578 | |
dc786b8a JB |
579 | (defconst ada-2005-keywords |
580 | (eval-when-compile | |
581 | (concat "\\<" (regexp-opt | |
582 | (append | |
583 | ada-2005-string-keywords | |
584 | ada-83-string-keywords | |
585 | ada-95-string-keywords) t) "\\>")) | |
586 | "Regular expression matching Ada2005 keywords.") | |
587 | ||
588 | (defvar ada-keywords ada-2005-keywords | |
589 | "Regular expression matching Ada keywords.") | |
590 | ;; FIXME: make this customizable | |
972579f9 | 591 | |
7749c1a8 | 592 | (defconst ada-ident-re |
0b702bc1 SL |
593 | "[[:alpha:]]\\(?:[_[:alnum:]]\\)*" |
594 | ;; [:alnum:] matches any multibyte word constituent, as well as | |
595 | ;; Latin-1 letters and numbers. This allows __ and trailing _; | |
596 | ;; someone (emacs bug#1919) proposed [^\W_] to fix that, but \W does | |
597 | ;; _not_ mean "not word constituent" inside a character alternative. | |
598 | "Regexp matching an Ada identifier.") | |
599 | ||
600 | (defconst ada-goto-label-re | |
601 | (concat "<<" ada-ident-re ">>") | |
602 | "Regexp matching a goto label.") | |
603 | ||
604 | (defconst ada-block-label-re | |
605 | (concat ada-ident-re "[ \t\n]*:[^=]") | |
606 | "Regexp matching a block label. | |
607 | Note that this also matches a variable declaration.") | |
608 | ||
609 | (defconst ada-label-re | |
610 | (concat "\\(?:" ada-block-label-re "\\)\\|\\(?:" ada-goto-label-re "\\)") | |
611 | "Regexp matching a goto or block label.") | |
f139ce87 | 612 | |
dc786b8a JB |
613 | ;; "with" needs to be included in the regexp, to match generic subprogram parameters |
614 | ;; Similarly, we put '[not] overriding' on the same line with 'procedure' etc. | |
972579f9 | 615 | (defvar ada-procedure-start-regexp |
4607c7f4 | 616 | (concat |
dc786b8a | 617 | "^[ \t]*\\(with[ \t]+\\)?\\(\\(not[ \t]+\\)?overriding[ \t]+\\)?\\(procedure\\|function\\|task\\)[ \t\n]+" |
4607c7f4 SM |
618 | |
619 | ;; subprogram name: operator ("[+/=*]") | |
620 | "\\(" | |
621 | "\\(\"[^\"]+\"\\)" | |
622 | ||
623 | ;; subprogram name: name | |
624 | "\\|" | |
625 | "\\(\\(\\sw\\|[_.]\\)+\\)" | |
626 | "\\)") | |
dc786b8a | 627 | "Regexp matching Ada subprogram start. |
23b747d1 | 628 | The actual start is at (match-beginning 4). The name is in (match-string 5).") |
972579f9 | 629 | |
dc786b8a | 630 | (defconst ada-name-regexp |
7fdb5d54 | 631 | "\\([a-zA-Z][a-zA-Z0-9_.']*[a-zA-Z0-9]\\)" |
dc786b8a | 632 | "Regexp matching a fully qualified name (including attribute).") |
972579f9 | 633 | |
dc786b8a JB |
634 | (defconst ada-package-start-regexp |
635 | (concat "^[ \t]*\\(private[ \t]+\\)?\\(package\\)[ \t\n]+\\(body[ \t]*\\)?" ada-name-regexp) | |
636 | "Regexp matching start of package. | |
637 | The package name is in (match-string 4).") | |
972579f9 | 638 | |
7fdb5d54 JB |
639 | (defconst ada-compile-goto-error-file-linenr-re |
640 | "\\([-_.a-zA-Z0-9]+\\):\\([0-9]+\\)\\(:\\([0-9]+\\)\\)?" | |
641 | "Regexp matching filename:linenr[:column].") | |
642 | ||
643 | ||
972579f9 RS |
644 | ;;; ---- regexps for indentation functions |
645 | ||
646 | (defvar ada-block-start-re | |
7749c1a8 GM |
647 | (eval-when-compile |
648 | (concat "\\<\\(" (regexp-opt '("begin" "declare" "else" | |
f70b58b0 JB |
649 | "exception" "generic" "loop" "or" |
650 | "private" "select" )) | |
651 | "\\|\\(\\(limited\\|abstract\\|tagged\\)[ \t\n]+\\)*record\\)\\>")) | |
5e1cecee | 652 | "Regexp for keywords starting Ada blocks.") |
972579f9 RS |
653 | |
654 | (defvar ada-end-stmt-re | |
7749c1a8 GM |
655 | (eval-when-compile |
656 | (concat "\\(" | |
f70b58b0 JB |
657 | ";" "\\|" |
658 | "=>[ \t]*$" "\\|" | |
d5875b25 | 659 | "=>[ \t]*--.*$" "\\|" |
f70b58b0 JB |
660 | "^[ \t]*separate[ \t]*(\\(\\sw\\|[_.]\\)+)" "\\|" |
661 | "\\<" (regexp-opt '("begin" "declare" "is" "do" "else" "generic" | |
662 | "loop" "private" "record" "select" | |
663 | "then abort" "then") t) "\\>" "\\|" | |
664 | "^[ \t]*" (regexp-opt '("function" "package" "procedure") | |
665 | t) "\\>\\(\\sw\\|[ \t_.]\\)+\\<is\\>" "\\|" | |
666 | "^[ \t]*exception\\>" | |
667 | "\\)") ) | |
972579f9 | 668 | "Regexp of possible ends for a non-broken statement. |
5e1cecee | 669 | A new statement starts after these.") |
972579f9 | 670 | |
7749c1a8 GM |
671 | (defvar ada-matching-start-re |
672 | (eval-when-compile | |
673 | (concat "\\<" | |
f70b58b0 | 674 | (regexp-opt |
7fdb5d54 JB |
675 | '("end" "loop" "select" "begin" "case" "do" "declare" |
676 | "if" "task" "package" "procedure" "function" "record" "protected") t) | |
f70b58b0 | 677 | "\\>")) |
6d533a6e | 678 | "Regexp used in `ada-goto-matching-start'.") |
7749c1a8 | 679 | |
972579f9 RS |
680 | (defvar ada-loop-start-re |
681 | "\\<\\(for\\|while\\|loop\\)\\>" | |
682 | "Regexp for the start of a loop.") | |
683 | ||
684 | (defvar ada-subprog-start-re | |
7749c1a8 | 685 | (eval-when-compile |
fb0d1545 | 686 | (concat "\\<" (regexp-opt '("accept" "entry" "function" "overriding" "package" "procedure" |
f70b58b0 | 687 | "protected" "task") t) "\\>")) |
972579f9 RS |
688 | "Regexp for the start of a subprogram.") |
689 | ||
655880d2 GM |
690 | (defvar ada-contextual-menu-on-identifier nil |
691 | "Set to true when the right mouse button was clicked on an identifier.") | |
692 | ||
4cc7e498 GM |
693 | (defvar ada-contextual-menu-last-point nil |
694 | "Position of point just before displaying the menu. | |
695 | This is a list (point buffer). | |
696 | Since `ada-popup-menu' moves the point where the user clicked, the region | |
6d533a6e | 697 | is modified. Therefore no command from the menu knows what the user selected |
4cc7e498 GM |
698 | before displaying the contextual menu. |
699 | To get the original region, restore the point to this position before | |
700 | calling `region-end' and `region-beginning'. | |
701 | Modify this variable if you want to restore the point to another position.") | |
702 | ||
f7a80909 JB |
703 | (easy-menu-define ada-contextual-menu nil |
704 | "Menu to use when the user presses the right mouse button. | |
4cc7e498 GM |
705 | The variable `ada-contextual-menu-on-identifier' will be set to t before |
706 | displaying the menu if point was on an identifier." | |
f7a80909 JB |
707 | '("Ada" |
708 | ["Goto Declaration/Body" ada-point-and-xref | |
709 | :included ada-contextual-menu-on-identifier] | |
710 | ["Goto Body" ada-point-and-xref-body | |
711 | :included ada-contextual-menu-on-identifier] | |
712 | ["Goto Previous Reference" ada-xref-goto-previous-reference] | |
713 | ["List References" ada-find-references | |
714 | :included ada-contextual-menu-on-identifier] | |
715 | ["List Local References" ada-find-local-references | |
716 | :included ada-contextual-menu-on-identifier] | |
717 | ["-" nil nil] | |
718 | ["Other File" ff-find-other-file] | |
719 | ["Goto Parent Unit" ada-goto-parent])) | |
7749c1a8 | 720 | |
972579f9 | 721 | \f |
7749c1a8 GM |
722 | ;;------------------------------------------------------------------ |
723 | ;; Support for imenu (see imenu.el) | |
724 | ;;------------------------------------------------------------------ | |
725 | ||
4607c7f4 SM |
726 | (defconst ada-imenu-comment-re "\\([ \t]*--.*\\)?") |
727 | ||
4cc7e498 | 728 | (defconst ada-imenu-subprogram-menu-re |
fb0d1545 | 729 | (concat "^[ \t]*\\(overriding[ \t]*\\)?\\(procedure\\|function\\)[ \t\n]+" |
4607c7f4 SM |
730 | "\\(\\(\\sw\\|_\\)+\\)[ \t\n]*\\([ \t\n]\\|([^)]+)" |
731 | ada-imenu-comment-re | |
732 | "\\)[ \t\n]*" | |
733 | "\\(return[ \t\n]+\\(\\sw\\|[_.]\\)+[ \t\n]*\\)?is[ \t\n]")) | |
4cc7e498 | 734 | |
74480345 | 735 | (defvar ada-imenu-generic-expression |
7749c1a8 | 736 | (list |
fb0d1545 | 737 | (list nil ada-imenu-subprogram-menu-re 3) |
7749c1a8 | 738 | (list "*Specs*" |
f70b58b0 JB |
739 | (concat |
740 | "^[ \t]*\\(procedure\\|function\\)[ \t\n]+\\(\\(\\sw\\|_\\)+\\)" | |
741 | "\\(" | |
742 | "\\(" ada-imenu-comment-re "[ \t\n]+\\|[ \t\n]*([^)]+)" | |
4607c7f4 | 743 | ada-imenu-comment-re "\\)";; parameter list or simple space |
f70b58b0 JB |
744 | "\\([ \t\n]*return[ \t\n]+\\(\\sw\\|[_.]\\)+[ \t\n]*\\)?" |
745 | "\\)?;") 2) | |
4607c7f4 | 746 | '("*Tasks*" "^[ \t]*task[ \t]+\\(type[ \t]+\\)?\\(\\(body[ \t]+\\)?\\(\\sw\\|_\\)+\\)" 2) |
7749c1a8 | 747 | '("*Type Defs*" "^[ \t]*\\(sub\\)?type[ \t]+\\(\\(\\sw\\|_\\)+\\)" 2) |
4607c7f4 SM |
748 | '("*Protected*" |
749 | "^[ \t]*protected[ \t]+\\(type[ \t]+\\)?\\(\\(body[ \t]+\\)?\\(\\sw\\|_\\)+\\)" 2) | |
7749c1a8 | 750 | '("*Packages*" "^[ \t]*package[ \t]+\\(\\(body[ \t]+\\)?\\(\\sw\\|[_.]\\)+\\)" 1)) |
655880d2 | 751 | "Imenu generic expression for Ada mode. |
6d533a6e | 752 | See `imenu-generic-expression'. This variable will create several submenus for |
4607c7f4 | 753 | each type of entity that can be found in an Ada file.") |
4cc7e498 | 754 | |
74480345 | 755 | \f |
7749c1a8 | 756 | ;;------------------------------------------------------------ |
655880d2 | 757 | ;; Support for compile.el |
7749c1a8 GM |
758 | ;;------------------------------------------------------------ |
759 | ||
760 | (defun ada-compile-mouse-goto-error () | |
0347188a | 761 | "Mouse interface for `ada-compile-goto-error'." |
7749c1a8 GM |
762 | (interactive) |
763 | (mouse-set-point last-input-event) | |
764 | (ada-compile-goto-error (point)) | |
765 | ) | |
766 | ||
767 | (defun ada-compile-goto-error (pos) | |
6d533a6e JB |
768 | "Replace `compile-goto-error' from compile.el. |
769 | If POS is on a file and line location, go to this position. It adds | |
770 | to compile.el the capacity to go to a reference in an error message. | |
f70b58b0 | 771 | For instance, on these lines: |
655880d2 | 772 | foo.adb:61:11: [...] in call to size declared at foo.ads:11 |
f70b58b0 JB |
773 | foo.adb:61:11: [...] in call to local declared at line 20 |
774 | the 4 file locations can be clicked on and jumped to." | |
7749c1a8 GM |
775 | (interactive "d") |
776 | (goto-char pos) | |
777 | ||
778 | (skip-chars-backward "-a-zA-Z0-9_:./\\") | |
779 | (cond | |
780 | ;; special case: looking at a filename:line not at the beginning of a line | |
7fdb5d54 | 781 | ;; or a simple line reference "at line ..." |
7749c1a8 | 782 | ((and (not (bolp)) |
7fdb5d54 JB |
783 | (or (looking-at ada-compile-goto-error-file-linenr-re) |
784 | (and | |
785 | (save-excursion | |
786 | (beginning-of-line) | |
787 | (looking-at ada-compile-goto-error-file-linenr-re)) | |
788 | (save-excursion | |
789 | (if (looking-at "\\([0-9]+\\)") (backward-word 1)) | |
790 | (looking-at "line \\([0-9]+\\)")))) | |
791 | ) | |
792 | (let ((line (if (match-beginning 2) (match-string 2) (match-string 1))) | |
793 | (file (if (match-beginning 2) (match-string 1) | |
794 | (save-excursion (beginning-of-line) | |
795 | (looking-at ada-compile-goto-error-file-linenr-re) | |
796 | (match-string 1)))) | |
f70b58b0 JB |
797 | (error-pos (point-marker)) |
798 | source) | |
1babb7ea JB |
799 | |
800 | ;; set source marker | |
7749c1a8 | 801 | (save-excursion |
d5875b25 JB |
802 | (compilation-find-file (point-marker) (match-string 1) "./") |
803 | (set-buffer file) | |
1babb7ea | 804 | |
e6ce8c42 GM |
805 | (when (stringp line) |
806 | (goto-char (point-min)) | |
807 | (forward-line (1- (string-to-number line)))) | |
1babb7ea | 808 | |
d5875b25 | 809 | (setq source (point-marker))) |
1babb7ea JB |
810 | |
811 | (compilation-goto-locus error-pos source nil) | |
812 | ||
7749c1a8 GM |
813 | )) |
814 | ||
815 | ;; otherwise, default behavior | |
816 | (t | |
1babb7ea | 817 | (compile-goto-error)) |
7749c1a8 GM |
818 | ) |
819 | (recenter)) | |
820 | ||
4cc7e498 | 821 | \f |
655880d2 GM |
822 | ;;------------------------------------------------------------------------- |
823 | ;; Grammar related function | |
824 | ;; The functions below work with the syntax class of the characters in an Ada | |
825 | ;; buffer. Two syntax tables are created, depending on whether we want '_' | |
826 | ;; to be considered as part of a word or not. | |
827 | ;; Some characters may have multiple meanings depending on the context: | |
828 | ;; - ' is either the beginning of a constant character or an attribute | |
829 | ;; - # is either part of a based litteral or a gnatprep statement. | |
830 | ;; - " starts a string, but not if inside a constant character. | |
831 | ;; - ( and ) should be ignored if inside a constant character. | |
832 | ;; Thus their syntax property is changed automatically, and we can still use | |
833 | ;; the standard Emacs functions for sexp (see `ada-in-string-p') | |
834 | ;; | |
bef83666 MR |
835 | ;; On Emacs, this is done through the `syntax-table' text property. The |
836 | ;; corresponding action is applied automatically each time the buffer | |
837 | ;; changes. If `font-lock-mode' is enabled (the default) the action is | |
838 | ;; set up by `font-lock-syntactic-keywords'. Otherwise, we do it | |
839 | ;; manually in `ada-after-change-function'. The proper method is | |
840 | ;; installed by `ada-handle-syntax-table-properties'. | |
655880d2 GM |
841 | ;; |
842 | ;; on XEmacs, the `syntax-table' property does not exist and we have to use a | |
843 | ;; slow advice to `parse-partial-sexp' to do the same thing. | |
844 | ;; When executing parse-partial-sexp, we simply modify the strings before and | |
845 | ;; after, so that the special constants '"', '(' and ')' do not interact | |
846 | ;; with parse-partial-sexp. | |
847 | ;; Note: this code is slow and needs to be rewritten as soon as something | |
848 | ;; better is available on XEmacs. | |
849 | ;;------------------------------------------------------------------------- | |
972579f9 RS |
850 | |
851 | (defun ada-create-syntax-table () | |
655880d2 GM |
852 | "Create the two syntax tables use in the Ada mode. |
853 | The standard table declares `_' as a symbol constituent, the second one | |
854 | declares it as a word constituent." | |
7749c1a8 | 855 | (interactive) |
36144b26 | 856 | (setq ada-mode-syntax-table (make-syntax-table)) |
972579f9 | 857 | |
cadd3658 RS |
858 | ;; define string brackets (`%' is alternative string bracket, but |
859 | ;; almost never used as such and throws font-lock and indentation | |
860 | ;; off the track.) | |
861 | (modify-syntax-entry ?% "$" ada-mode-syntax-table) | |
972579f9 RS |
862 | (modify-syntax-entry ?\" "\"" ada-mode-syntax-table) |
863 | ||
972579f9 RS |
864 | (modify-syntax-entry ?: "." ada-mode-syntax-table) |
865 | (modify-syntax-entry ?\; "." ada-mode-syntax-table) | |
866 | (modify-syntax-entry ?& "." ada-mode-syntax-table) | |
867 | (modify-syntax-entry ?\| "." ada-mode-syntax-table) | |
868 | (modify-syntax-entry ?+ "." ada-mode-syntax-table) | |
869 | (modify-syntax-entry ?* "." ada-mode-syntax-table) | |
870 | (modify-syntax-entry ?/ "." ada-mode-syntax-table) | |
871 | (modify-syntax-entry ?= "." ada-mode-syntax-table) | |
872 | (modify-syntax-entry ?< "." ada-mode-syntax-table) | |
873 | (modify-syntax-entry ?> "." ada-mode-syntax-table) | |
874 | (modify-syntax-entry ?$ "." ada-mode-syntax-table) | |
875 | (modify-syntax-entry ?\[ "." ada-mode-syntax-table) | |
876 | (modify-syntax-entry ?\] "." ada-mode-syntax-table) | |
877 | (modify-syntax-entry ?\{ "." ada-mode-syntax-table) | |
878 | (modify-syntax-entry ?\} "." ada-mode-syntax-table) | |
879 | (modify-syntax-entry ?. "." ada-mode-syntax-table) | |
880 | (modify-syntax-entry ?\\ "." ada-mode-syntax-table) | |
881 | (modify-syntax-entry ?\' "." ada-mode-syntax-table) | |
882 | ||
883 | ;; a single hyphen is punctuation, but a double hyphen starts a comment | |
884 | (modify-syntax-entry ?- ". 12" ada-mode-syntax-table) | |
885 | ||
655880d2 GM |
886 | ;; See the comment above on grammar related function for the special |
887 | ;; setup for '#'. | |
6f9a2614 | 888 | (if (featurep 'xemacs) |
7749c1a8 GM |
889 | (modify-syntax-entry ?# "<" ada-mode-syntax-table) |
890 | (modify-syntax-entry ?# "$" ada-mode-syntax-table)) | |
891 | ||
972579f9 RS |
892 | ;; and \f and \n end a comment |
893 | (modify-syntax-entry ?\f "> " ada-mode-syntax-table) | |
894 | (modify-syntax-entry ?\n "> " ada-mode-syntax-table) | |
895 | ||
cadd3658 | 896 | ;; define what belongs in Ada symbols |
972579f9 RS |
897 | (modify-syntax-entry ?_ "_" ada-mode-syntax-table) |
898 | ||
899 | ;; define parentheses to match | |
900 | (modify-syntax-entry ?\( "()" ada-mode-syntax-table) | |
901 | (modify-syntax-entry ?\) ")(" ada-mode-syntax-table) | |
f139ce87 | 902 | |
36144b26 | 903 | (setq ada-mode-symbol-syntax-table (copy-syntax-table ada-mode-syntax-table)) |
f139ce87 | 904 | (modify-syntax-entry ?_ "w" ada-mode-symbol-syntax-table) |
972579f9 RS |
905 | ) |
906 | ||
655880d2 GM |
907 | ;; Support of special characters in XEmacs (see the comments at the beginning |
908 | ;; of the section on Grammar related functions). | |
7749c1a8 | 909 | |
6f9a2614 | 910 | (if (featurep 'xemacs) |
7749c1a8 | 911 | (defadvice parse-partial-sexp (around parse-partial-sexp-protect-constants) |
655880d2 | 912 | "Handles special character constants and gnatprep statements." |
7749c1a8 | 913 | (let (change) |
f70b58b0 JB |
914 | (if (< to from) |
915 | (let ((tmp from)) | |
916 | (setq from to to tmp))) | |
917 | (save-excursion | |
918 | (goto-char from) | |
919 | (while (re-search-forward "'\\([(\")#]\\)'" to t) | |
920 | (setq change (cons (list (match-beginning 1) | |
921 | 1 | |
922 | (match-string 1)) | |
923 | change)) | |
924 | (replace-match "'A'")) | |
925 | (goto-char from) | |
926 | (while (re-search-forward "\\(#[0-9a-fA-F]*#\\)" to t) | |
927 | (setq change (cons (list (match-beginning 1) | |
928 | (length (match-string 1)) | |
929 | (match-string 1)) | |
930 | change)) | |
931 | (replace-match (make-string (length (match-string 1)) ?@)))) | |
932 | ad-do-it | |
933 | (save-excursion | |
934 | (while change | |
935 | (goto-char (caar change)) | |
936 | (delete-char (cadar change)) | |
937 | (insert (caddar change)) | |
938 | (setq change (cdr change))))))) | |
7749c1a8 | 939 | |
bef83666 MR |
940 | (defun ada-set-syntax-table-properties () |
941 | "Assign `syntax-table' properties in accessible part of buffer. | |
942 | In particular, character constants are said to be strings, #...# | |
943 | are treated as numbers instead of gnatprep comments." | |
944 | (let ((modified (buffer-modified-p)) | |
945 | (buffer-undo-list t) | |
946 | (inhibit-read-only t) | |
947 | (inhibit-point-motion-hooks t) | |
d5875b25 | 948 | (inhibit-modification-hooks t)) |
bef83666 MR |
949 | (remove-text-properties (point-min) (point-max) '(syntax-table nil)) |
950 | (goto-char (point-min)) | |
951 | (while (re-search-forward | |
952 | ;; The following regexp was adapted from | |
953 | ;; `ada-font-lock-syntactic-keywords'. | |
954 | "^[ \t]*\\(#\\(?:if\\|else\\|elsif\\|end\\)\\)\\|[^a-zA-Z0-9)]\\('\\)[^'\n]\\('\\)" | |
955 | nil t) | |
956 | (if (match-beginning 1) | |
957 | (put-text-property | |
958 | (match-beginning 1) (match-end 1) 'syntax-table '(11 . ?\n)) | |
959 | (put-text-property | |
960 | (match-beginning 2) (match-end 2) 'syntax-table '(7 . ?')) | |
961 | (put-text-property | |
962 | (match-beginning 3) (match-end 3) 'syntax-table '(7 . ?')))) | |
963 | (unless modified | |
964 | (restore-buffer-modified-p nil)))) | |
7749c1a8 GM |
965 | |
966 | (defun ada-after-change-function (beg end old-len) | |
655880d2 GM |
967 | "Called when the region between BEG and END was changed in the buffer. |
968 | OLD-LEN indicates what the length of the replaced text was." | |
bef83666 MR |
969 | (save-excursion |
970 | (save-restriction | |
971 | (let ((from (progn (goto-char beg) (line-beginning-position))) | |
972 | (to (progn (goto-char end) (line-end-position)))) | |
973 | (narrow-to-region from to) | |
974 | (save-match-data | |
975 | (ada-set-syntax-table-properties)))))) | |
976 | ||
977 | (defun ada-initialize-syntax-table-properties () | |
978 | "Assign `syntax-table' properties in current buffer." | |
7749c1a8 | 979 | (save-excursion |
bef83666 MR |
980 | (save-restriction |
981 | (widen) | |
982 | (save-match-data | |
983 | (ada-set-syntax-table-properties)))) | |
984 | (add-hook 'after-change-functions 'ada-after-change-function nil t)) | |
985 | ||
986 | (defun ada-handle-syntax-table-properties () | |
987 | "Handle `syntax-table' properties." | |
988 | (if font-lock-mode | |
989 | ;; `font-lock-mode' will take care of `syntax-table' properties. | |
990 | (remove-hook 'after-change-functions 'ada-after-change-function t) | |
991 | ;; Take care of `syntax-table' properties manually. | |
992 | (ada-initialize-syntax-table-properties))) | |
7749c1a8 | 993 | |
4cc7e498 GM |
994 | ;;------------------------------------------------------------------ |
995 | ;; Testing the grammatical context | |
996 | ;;------------------------------------------------------------------ | |
997 | ||
998 | (defsubst ada-in-comment-p (&optional parse-result) | |
f70b58b0 JB |
999 | "Return t if inside a comment. |
1000 | If PARSE-RESULT is non-nil, use it instead of calling `parse-partial-sexp'." | |
4cc7e498 | 1001 | (nth 4 (or parse-result |
f70b58b0 JB |
1002 | (parse-partial-sexp |
1003 | (line-beginning-position) (point))))) | |
4cc7e498 GM |
1004 | |
1005 | (defsubst ada-in-string-p (&optional parse-result) | |
6d533a6e | 1006 | "Return t if point is inside a string. |
ff003dc7 | 1007 | If PARSE-RESULT is non-nil, use it instead of calling `parse-partial-sexp'." |
4cc7e498 | 1008 | (nth 3 (or parse-result |
f70b58b0 JB |
1009 | (parse-partial-sexp |
1010 | (line-beginning-position) (point))))) | |
4cc7e498 GM |
1011 | |
1012 | (defsubst ada-in-string-or-comment-p (&optional parse-result) | |
f70b58b0 JB |
1013 | "Return t if inside a comment or string. |
1014 | If PARSE-RESULT is non-nil, use it instead of calling `parse-partial-sexp'." | |
36144b26 | 1015 | (setq parse-result (or parse-result |
f70b58b0 JB |
1016 | (parse-partial-sexp |
1017 | (line-beginning-position) (point)))) | |
4cc7e498 GM |
1018 | (or (ada-in-string-p parse-result) (ada-in-comment-p parse-result))) |
1019 | ||
f29fd869 CY |
1020 | (defsubst ada-in-numeric-literal-p () |
1021 | "Return t if point is after a prefix of a numeric literal." | |
1022 | (looking-back "\\([0-9]+#[0-9a-fA-F_]+\\)")) | |
7749c1a8 | 1023 | |
655880d2 GM |
1024 | ;;------------------------------------------------------------------ |
1025 | ;; Contextual menus | |
0347188a | 1026 | ;; The Ada mode comes with contextual menus, bound by default to the right |
4cc7e498 | 1027 | ;; mouse button. |
655880d2 GM |
1028 | ;; Add items to this menu by modifying `ada-contextual-menu'. Note that the |
1029 | ;; variable `ada-contextual-menu-on-identifier' is set automatically to t | |
1030 | ;; if the mouse button was pressed on an identifier. | |
1031 | ;;------------------------------------------------------------------ | |
7749c1a8 | 1032 | |
4cc7e498 GM |
1033 | (defun ada-call-from-contextual-menu (function) |
1034 | "Execute FUNCTION when called from the contextual menu. | |
1035 | It forces Emacs to change the cursor position." | |
1036 | (interactive) | |
1037 | (funcall function) | |
1038 | (setq ada-contextual-menu-last-point | |
f70b58b0 | 1039 | (list (point) (current-buffer)))) |
4cc7e498 | 1040 | |
7749c1a8 | 1041 | (defun ada-popup-menu (position) |
655880d2 | 1042 | "Pops up a contextual menu, depending on where the user clicked. |
4cc7e498 GM |
1043 | POSITION is the location the mouse was clicked on. |
1044 | Sets `ada-contextual-menu-last-point' to the current position before | |
6d533a6e JB |
1045 | displaying the menu. When a function from the menu is called, the |
1046 | point is where the mouse button was clicked." | |
7749c1a8 | 1047 | (interactive "e") |
4cc7e498 GM |
1048 | |
1049 | ;; declare this as a local variable, so that the function called | |
1050 | ;; in the contextual menu does not hide the region in | |
1051 | ;; transient-mark-mode. | |
1052 | (let ((deactivate-mark nil)) | |
36144b26 | 1053 | (setq ada-contextual-menu-last-point |
f70b58b0 | 1054 | (list (point) (current-buffer))) |
655880d2 | 1055 | (mouse-set-point last-input-event) |
4cc7e498 | 1056 | |
655880d2 | 1057 | (setq ada-contextual-menu-on-identifier |
f70b58b0 JB |
1058 | (and (char-after) |
1059 | (or (= (char-syntax (char-after)) ?w) | |
1060 | (= (char-after) ?_)) | |
1061 | (not (ada-in-string-or-comment-p)) | |
1062 | (save-excursion (skip-syntax-forward "w") | |
1063 | (not (ada-after-keyword-p))) | |
1064 | )) | |
f7a80909 JB |
1065 | (if (fboundp 'popup-menu) |
1066 | (funcall (symbol-function 'popup-menu) ada-contextual-menu) | |
1067 | (let (choice) | |
1068 | (setq choice (x-popup-menu position ada-contextual-menu)) | |
f70b58b0 JB |
1069 | (if choice |
1070 | (funcall (lookup-key ada-contextual-menu (vector (car choice))))))) | |
f7a80909 | 1071 | |
4cc7e498 GM |
1072 | (set-buffer (cadr ada-contextual-menu-last-point)) |
1073 | (goto-char (car ada-contextual-menu-last-point)) | |
1074 | )) | |
1075 | ||
7749c1a8 | 1076 | |
655880d2 GM |
1077 | ;;------------------------------------------------------------------ |
1078 | ;; Misc functions | |
1079 | ;;------------------------------------------------------------------ | |
7749c1a8 GM |
1080 | |
1081 | ;;;###autoload | |
1082 | (defun ada-add-extensions (spec body) | |
655880d2 GM |
1083 | "Define SPEC and BODY as being valid extensions for Ada files. |
1084 | Going from body to spec with `ff-find-other-file' used these | |
1085 | extensions. | |
6d533a6e JB |
1086 | SPEC and BODY are two regular expressions that must match against |
1087 | the file name." | |
7749c1a8 | 1088 | (let* ((reg (concat (regexp-quote body) "$")) |
f70b58b0 | 1089 | (tmp (assoc reg ada-other-file-alist))) |
7749c1a8 | 1090 | (if tmp |
f70b58b0 | 1091 | (setcdr tmp (list (cons spec (cadr tmp)))) |
7749c1a8 | 1092 | (add-to-list 'ada-other-file-alist (list reg (list spec))))) |
4cc7e498 | 1093 | |
7749c1a8 | 1094 | (let* ((reg (concat (regexp-quote spec) "$")) |
f70b58b0 | 1095 | (tmp (assoc reg ada-other-file-alist))) |
7749c1a8 | 1096 | (if tmp |
f70b58b0 | 1097 | (setcdr tmp (list (cons body (cadr tmp)))) |
7749c1a8 GM |
1098 | (add-to-list 'ada-other-file-alist (list reg (list body))))) |
1099 | ||
1997815f AS |
1100 | (add-to-list 'auto-mode-alist |
1101 | (cons (concat (regexp-quote spec) "\\'") 'ada-mode)) | |
1102 | (add-to-list 'auto-mode-alist | |
1103 | (cons (concat (regexp-quote body) "\\'") 'ada-mode)) | |
7749c1a8 GM |
1104 | |
1105 | (add-to-list 'ada-spec-suffixes spec) | |
1106 | (add-to-list 'ada-body-suffixes body) | |
1107 | ||
1108 | ;; Support for speedbar (Specifies that we want to see these files in | |
1109 | ;; speedbar) | |
f7a80909 | 1110 | (if (fboundp 'speedbar-add-supported-extension) |
7749c1a8 | 1111 | (progn |
f70b58b0 JB |
1112 | (funcall (symbol-function 'speedbar-add-supported-extension) |
1113 | spec) | |
1114 | (funcall (symbol-function 'speedbar-add-supported-extension) | |
1115 | body))) | |
7749c1a8 GM |
1116 | ) |
1117 | ||
1118 | ||
a681b2a1 | 1119 | ;;;###autoload |
972579f9 | 1120 | (defun ada-mode () |
a97af989 | 1121 | "Ada mode is the major mode for editing Ada code." |
972579f9 RS |
1122 | |
1123 | (interactive) | |
1124 | (kill-all-local-variables) | |
65c96997 | 1125 | |
bef83666 | 1126 | (set-syntax-table ada-mode-syntax-table) |
972579f9 | 1127 | |
64a0475c | 1128 | (set (make-local-variable 'require-final-newline) mode-require-final-newline) |
972579f9 | 1129 | |
7749c1a8 GM |
1130 | ;; Set the paragraph delimiters so that one can select a whole block |
1131 | ;; simply with M-h | |
1132 | (set (make-local-variable 'paragraph-start) "[ \t\n\f]*$") | |
1133 | (set (make-local-variable 'paragraph-separate) "[ \t\n\f]*$") | |
972579f9 RS |
1134 | |
1135 | ;; comment end must be set because it may hold a wrong value if | |
1136 | ;; this buffer had been in another mode before. RE | |
7749c1a8 GM |
1137 | (set (make-local-variable 'comment-end) "") |
1138 | ||
1139 | ;; used by autofill and indent-new-comment-line | |
1140 | (set (make-local-variable 'comment-start-skip) "---*[ \t]*") | |
1141 | ||
1142 | ;; used by autofill to break a comment line and continue it on another line. | |
1143 | ;; The reason we need this one is that the default behavior does not work | |
1144 | ;; correctly with the definition of paragraph-start above when the comment | |
655880d2 | 1145 | ;; is right after a multi-line subprogram declaration (the comments are |
7749c1a8 GM |
1146 | ;; aligned under the latest parameter, not under the declaration start). |
1147 | (set (make-local-variable 'comment-line-break-function) | |
1148 | (lambda (&optional soft) (let ((fill-prefix nil)) | |
f70b58b0 | 1149 | (indent-new-comment-line soft)))) |
4cc7e498 | 1150 | |
7749c1a8 GM |
1151 | (set (make-local-variable 'indent-line-function) |
1152 | 'ada-indent-current-function) | |
1153 | ||
1154 | (set (make-local-variable 'comment-column) 40) | |
1155 | ||
1156 | ;; Emacs 20.3 defines a comment-padding to insert spaces between | |
1157 | ;; the comment and the text. We do not want any, this is already | |
1158 | ;; included in comment-start | |
6f9a2614 | 1159 | (unless (featurep 'xemacs) |
23b747d1 SM |
1160 | (set (make-local-variable 'parse-sexp-ignore-comments) t) |
1161 | (set (make-local-variable 'comment-padding) 0) | |
1162 | (set (make-local-variable 'parse-sexp-lookup-properties) t)) | |
7749c1a8 | 1163 | |
4607c7f4 SM |
1164 | (set 'case-fold-search t) |
1165 | (if (boundp 'imenu-case-fold-search) | |
1166 | (set 'imenu-case-fold-search t)) | |
7749c1a8 GM |
1167 | |
1168 | (set (make-local-variable 'fill-paragraph-function) | |
1169 | 'ada-fill-comment-paragraph) | |
1170 | ||
7749c1a8 GM |
1171 | ;; Support for compile.el |
1172 | ;; We just substitute our own functions to go to the error. | |
1173 | (add-hook 'compilation-mode-hook | |
f70b58b0 | 1174 | (lambda() |
5dab0769 | 1175 | ;; FIXME: This has global impact! -stef |
4cc7e498 GM |
1176 | (define-key compilation-minor-mode-map [mouse-2] |
1177 | 'ada-compile-mouse-goto-error) | |
1178 | (define-key compilation-minor-mode-map "\C-c\C-c" | |
1179 | 'ada-compile-goto-error) | |
1180 | (define-key compilation-minor-mode-map "\C-m" | |
5dab0769 | 1181 | 'ada-compile-goto-error))) |
7749c1a8 | 1182 | |
4607c7f4 | 1183 | ;; font-lock support : |
4607c7f4 | 1184 | |
d5875b25 JB |
1185 | (set (make-local-variable 'font-lock-defaults) |
1186 | '(ada-font-lock-keywords | |
1187 | nil t | |
1188 | ((?\_ . "w") (?# . ".")) | |
1189 | beginning-of-line | |
1190 | (font-lock-syntactic-keywords . ada-font-lock-syntactic-keywords))) | |
4cc7e498 | 1191 | |
7749c1a8 | 1192 | ;; Set up support for find-file.el. |
5dab0769 | 1193 | (set (make-local-variable 'ff-other-file-alist) |
7749c1a8 | 1194 | 'ada-other-file-alist) |
5dab0769 | 1195 | (set (make-local-variable 'ff-search-directories) |
6f9a2614 JB |
1196 | 'ada-search-directories-internal) |
1197 | (setq ff-post-load-hook 'ada-set-point-accordingly | |
f70b58b0 | 1198 | ff-file-created-hook 'ada-make-body) |
6f9a2614 | 1199 | (add-hook 'ff-pre-load-hook 'ada-which-function-are-we-in) |
4cc7e498 | 1200 | |
7749c1a8 | 1201 | (make-local-variable 'ff-special-constructs) |
7fdb5d54 | 1202 | (mapc (lambda (pair) (add-to-list 'ff-special-constructs pair)) |
d5875b25 JB |
1203 | (list |
1204 | ;; Top level child package declaration; go to the parent package. | |
1205 | (cons (eval-when-compile | |
1206 | (concat "^\\(private[ \t]\\)?[ \t]*package[ \t]+" | |
1207 | "\\(body[ \t]+\\)?" | |
1208 | "\\(\\(\\sw\\|[_.]\\)+\\)\\.\\(\\sw\\|_\\)+[ \t\n]+is")) | |
1209 | (lambda () | |
1210 | (ff-get-file | |
1211 | ada-search-directories-internal | |
1212 | (ada-make-filename-from-adaname (match-string 3)) | |
1213 | ada-spec-suffixes))) | |
1214 | ||
1215 | ;; A "separate" clause. | |
1216 | (cons "^separate[ \t\n]*(\\(\\(\\sw\\|[_.]\\)+\\))" | |
1217 | (lambda () | |
1218 | (ff-get-file | |
1219 | ada-search-directories-internal | |
1220 | (ada-make-filename-from-adaname (match-string 1)) | |
1221 | ada-spec-suffixes))) | |
1222 | ||
1223 | ;; A "with" clause. | |
1224 | (cons "^with[ \t]+\\([a-zA-Z0-9_\\.]+\\)" | |
1225 | (lambda () | |
1226 | (ff-get-file | |
1227 | ada-search-directories-internal | |
1228 | (ada-make-filename-from-adaname (match-string 1)) | |
1229 | ada-spec-suffixes))) | |
1230 | )) | |
4cc7e498 | 1231 | |
7749c1a8 GM |
1232 | ;; Support for outline-minor-mode |
1233 | (set (make-local-variable 'outline-regexp) | |
4cc7e498 | 1234 | "\\([ \t]*\\(procedure\\|function\\|package\\|if\\|while\\|for\\|declare\\|case\\|end\\|begin\\|loop\\)\\|--\\)") |
7749c1a8 GM |
1235 | (set (make-local-variable 'outline-level) 'ada-outline-level) |
1236 | ||
1237 | ;; Support for imenu : We want a sorted index | |
d5875b25 JB |
1238 | (setq imenu-generic-expression ada-imenu-generic-expression) |
1239 | ||
36144b26 | 1240 | (setq imenu-sort-function 'imenu--sort-by-name) |
7749c1a8 | 1241 | |
4607c7f4 SM |
1242 | ;; Support for ispell : Check only comments |
1243 | (set (make-local-variable 'ispell-check-comments) 'exclusive) | |
1244 | ||
7fdb5d54 JB |
1245 | ;; Support for align |
1246 | (add-to-list 'align-dq-string-modes 'ada-mode) | |
1247 | (add-to-list 'align-open-comment-modes 'ada-mode) | |
1248 | (set (make-local-variable 'align-region-separate) ada-align-region-separate) | |
1249 | ||
1250 | ;; Exclude comments alone on line from alignment. | |
1251 | (add-to-list 'align-exclude-rules-list | |
d5875b25 JB |
1252 | '(ada-solo-comment |
1253 | (regexp . "^\\(\\s-*\\)--") | |
1254 | (modes . '(ada-mode)))) | |
7fdb5d54 | 1255 | (add-to-list 'align-exclude-rules-list |
d5875b25 JB |
1256 | '(ada-solo-use |
1257 | (regexp . "^\\(\\s-*\\)\\<use\\>") | |
1258 | (modes . '(ada-mode)))) | |
7fdb5d54 JB |
1259 | |
1260 | (setq ada-align-modes nil) | |
1261 | ||
1262 | (add-to-list 'ada-align-modes | |
d5875b25 JB |
1263 | '(ada-declaration-assign |
1264 | (regexp . "[^:]\\(\\s-*\\):[^:]") | |
1265 | (valid . (lambda() (not (ada-in-comment-p)))) | |
1266 | (repeat . t) | |
1267 | (modes . '(ada-mode)))) | |
7fdb5d54 | 1268 | (add-to-list 'ada-align-modes |
d5875b25 JB |
1269 | '(ada-associate |
1270 | (regexp . "[^=]\\(\\s-*\\)=>") | |
1271 | (valid . (lambda() (not (ada-in-comment-p)))) | |
1272 | (modes . '(ada-mode)))) | |
7fdb5d54 | 1273 | (add-to-list 'ada-align-modes |
d5875b25 JB |
1274 | '(ada-comment |
1275 | (regexp . "\\(\\s-*\\)--") | |
1276 | (modes . '(ada-mode)))) | |
7fdb5d54 | 1277 | (add-to-list 'ada-align-modes |
d5875b25 JB |
1278 | '(ada-use |
1279 | (regexp . "\\(\\s-*\\)\\<use\\s-") | |
1280 | (valid . (lambda() (not (ada-in-comment-p)))) | |
1281 | (modes . '(ada-mode)))) | |
7fdb5d54 | 1282 | (add-to-list 'ada-align-modes |
d5875b25 JB |
1283 | '(ada-at |
1284 | (regexp . "\\(\\s-+\\)at\\>") | |
1285 | (modes . '(ada-mode)))) | |
7fdb5d54 JB |
1286 | |
1287 | (setq align-mode-rules-list ada-align-modes) | |
a1506d29 | 1288 | |
7749c1a8 GM |
1289 | ;; Set up the contextual menu |
1290 | (if ada-popup-key | |
1291 | (define-key ada-mode-map ada-popup-key 'ada-popup-menu)) | |
1292 | ||
4cc7e498 GM |
1293 | ;; Support for Abbreviations (the user still need to "M-x abbrev-mode" |
1294 | (define-abbrev-table 'ada-mode-abbrev-table ()) | |
36144b26 | 1295 | (setq local-abbrev-table ada-mode-abbrev-table) |
4cc7e498 | 1296 | |
80d50f88 | 1297 | ;; Support for which-function mode |
2389f143 RS |
1298 | (make-local-variable 'which-func-functions) |
1299 | (setq which-func-functions '(ada-which-function)) | |
80d50f88 | 1300 | |
7749c1a8 | 1301 | ;; Support for indent-new-comment-line (Especially for XEmacs) |
bef83666 | 1302 | (set (make-local-variable 'comment-multi-line) nil) |
7749c1a8 | 1303 | |
d5875b25 JB |
1304 | ;; Support for add-log |
1305 | (set (make-local-variable 'add-log-current-defun-function) 'ada-which-function) | |
1306 | ||
4607c7f4 SM |
1307 | (setq major-mode 'ada-mode |
1308 | mode-name "Ada") | |
972579f9 | 1309 | |
972579f9 RS |
1310 | (use-local-map ada-mode-map) |
1311 | ||
5dab0769 | 1312 | (easy-menu-add ada-mode-menu ada-mode-map) |
4cc7e498 | 1313 | |
7749c1a8 | 1314 | (set-syntax-table ada-mode-syntax-table) |
972579f9 | 1315 | |
4d9db685 RS |
1316 | (set (make-local-variable 'skeleton-further-elements) |
1317 | '((< '(backward-delete-char-untabify | |
1318 | (min ada-indent (current-column)))))) | |
1319 | (add-hook 'skeleton-end-hook 'ada-adjust-case-skeleton nil t) | |
1320 | ||
9a969196 | 1321 | (run-mode-hooks 'ada-mode-hook) |
972579f9 | 1322 | |
4607c7f4 SM |
1323 | ;; To be run after the hook, in case the user modified |
1324 | ;; ada-fill-comment-prefix | |
1325 | (make-local-variable 'comment-start) | |
1326 | (if ada-fill-comment-prefix | |
1327 | (set 'comment-start ada-fill-comment-prefix) | |
1328 | (set 'comment-start "-- ")) | |
a1506d29 | 1329 | |
7749c1a8 GM |
1330 | ;; Run this after the hook to give the users a chance to activate |
1331 | ;; font-lock-mode | |
972579f9 | 1332 | |
6f9a2614 | 1333 | (unless (featurep 'xemacs) |
bef83666 MR |
1334 | (ada-initialize-syntax-table-properties) |
1335 | (add-hook 'font-lock-mode-hook 'ada-handle-syntax-table-properties nil t)) | |
972579f9 RS |
1336 | |
1337 | ;; the following has to be done after running the ada-mode-hook | |
1338 | ;; because users might want to set the values of these variable | |
f70b58b0 | 1339 | ;; inside the hook |
972579f9 RS |
1340 | |
1341 | (cond ((eq ada-language-version 'ada83) | |
f70b58b0 JB |
1342 | (setq ada-keywords ada-83-keywords)) |
1343 | ((eq ada-language-version 'ada95) | |
dc786b8a | 1344 | (setq ada-keywords ada-95-keywords)) |
7fdb5d54 | 1345 | ((eq ada-language-version 'ada2005) |
dc786b8a | 1346 | (setq ada-keywords ada-2005-keywords))) |
972579f9 RS |
1347 | |
1348 | (if ada-auto-case | |
1349 | (ada-activate-keys-for-case))) | |
1350 | ||
4d9db685 RS |
1351 | (defun ada-adjust-case-skeleton () |
1352 | "Adjust the case of the text inserted by a skeleton." | |
1353 | (save-excursion | |
1354 | (let ((aa-end (point))) | |
1355 | (ada-adjust-case-region | |
1356 | (progn (goto-char (symbol-value 'beg)) (forward-word -1) (point)) | |
1357 | (goto-char aa-end))))) | |
4607c7f4 | 1358 | |
4607c7f4 | 1359 | (defun ada-region-selected () |
b63dc21e RS |
1360 | "Should we operate on an active region?" |
1361 | (if (fboundp 'use-region-p) | |
1362 | (use-region-p) | |
1363 | (region-active-p))) | |
972579f9 | 1364 | \f |
655880d2 GM |
1365 | ;;----------------------------------------------------------------- |
1366 | ;; auto-casing | |
0347188a | 1367 | ;; Since Ada is case-insensitive, the Ada mode provides an extensive set of |
655880d2 GM |
1368 | ;; functions to auto-case identifiers, keywords, ... |
1369 | ;; The basic rules for autocasing are defined through the variables | |
1370 | ;; `ada-case-attribute', `ada-case-keyword' and `ada-case-identifier'. These | |
1371 | ;; are references to the functions that will do the actual casing. | |
1372 | ;; | |
1373 | ;; However, in most cases, the user will want to define some exceptions to | |
1374 | ;; these casing rules. This is done through a list of files, that contain | |
1375 | ;; one word per line. These files are stored in `ada-case-exception-file'. | |
4cc7e498 | 1376 | ;; For backward compatibility, this variable can also be a string. |
655880d2 | 1377 | ;;----------------------------------------------------------------- |
cadd3658 | 1378 | |
4607c7f4 | 1379 | (defun ada-save-exceptions-to-file (file-name) |
f70b58b0 JB |
1380 | "Save the casing exception lists to the file FILE-NAME. |
1381 | Casing exception lists are `ada-case-exception' and `ada-case-exception-substring'." | |
4607c7f4 SM |
1382 | (find-file (expand-file-name file-name)) |
1383 | (erase-buffer) | |
65c96997 JB |
1384 | (mapc (lambda (x) (insert (car x) "\n")) |
1385 | (sort (copy-sequence ada-case-exception) | |
1386 | (lambda(a b) (string< (car a) (car b))))) | |
1387 | (mapc (lambda (x) (insert "*" (car x) "\n")) | |
1388 | (sort (copy-sequence ada-case-exception-substring) | |
1389 | (lambda(a b) (string< (car a) (car b))))) | |
4607c7f4 SM |
1390 | (save-buffer) |
1391 | (kill-buffer nil) | |
1392 | ) | |
a1506d29 | 1393 | |
7749c1a8 | 1394 | (defun ada-create-case-exception (&optional word) |
6d533a6e | 1395 | "Define WORD as an exception for the casing system. |
655880d2 | 1396 | If WORD is not given, then the current word in the buffer is used instead. |
32b1a27f | 1397 | The new word is added to the first file in `ada-case-exception-file'. |
655880d2 | 1398 | The standard casing rules will no longer apply to this word." |
972579f9 | 1399 | (interactive) |
7749c1a8 | 1400 | (let ((previous-syntax-table (syntax-table)) |
f70b58b0 JB |
1401 | file-name |
1402 | ) | |
4cc7e498 GM |
1403 | |
1404 | (cond ((stringp ada-case-exception-file) | |
f70b58b0 JB |
1405 | (setq file-name ada-case-exception-file)) |
1406 | ((listp ada-case-exception-file) | |
1407 | (setq file-name (car ada-case-exception-file))) | |
1408 | (t | |
1409 | (error (concat "No exception file specified. " | |
eb4ed27f | 1410 | "See variable ada-case-exception-file")))) |
4cc7e498 | 1411 | |
7749c1a8 GM |
1412 | (set-syntax-table ada-mode-symbol-syntax-table) |
1413 | (unless word | |
1414 | (save-excursion | |
f70b58b0 JB |
1415 | (skip-syntax-backward "w") |
1416 | (setq word (buffer-substring-no-properties | |
1417 | (point) (save-excursion (forward-word 1) (point)))))) | |
4607c7f4 | 1418 | (set-syntax-table previous-syntax-table) |
7749c1a8 GM |
1419 | |
1420 | ;; Reread the exceptions file, in case it was modified by some other, | |
4607c7f4 | 1421 | (ada-case-read-exceptions-from-file file-name) |
4cc7e498 | 1422 | |
7749c1a8 GM |
1423 | ;; If the word is already in the list, even with a different casing |
1424 | ;; we simply want to replace it. | |
7749c1a8 | 1425 | (if (and (not (equal ada-case-exception '())) |
f70b58b0 JB |
1426 | (assoc-string word ada-case-exception t)) |
1427 | (setcar (assoc-string word ada-case-exception t) word) | |
7749c1a8 GM |
1428 | (add-to-list 'ada-case-exception (cons word t)) |
1429 | ) | |
972579f9 | 1430 | |
4607c7f4 | 1431 | (ada-save-exceptions-to-file file-name) |
7749c1a8 | 1432 | )) |
4cc7e498 | 1433 | |
4607c7f4 | 1434 | (defun ada-create-case-exception-substring (&optional word) |
6d533a6e | 1435 | "Define the substring WORD as an exception for the casing system. |
4607c7f4 SM |
1436 | If WORD is not given, then the current word in the buffer is used instead, |
1437 | or the selected region if any is active. | |
6d533a6e | 1438 | The new word is added to the first file in `ada-case-exception-file'. |
4607c7f4 SM |
1439 | When auto-casing a word, this substring will be special-cased, unless the |
1440 | word itself has a special casing." | |
1441 | (interactive) | |
1442 | (let ((file-name | |
1443 | (cond ((stringp ada-case-exception-file) | |
1444 | ada-case-exception-file) | |
1445 | ((listp ada-case-exception-file) | |
1446 | (car ada-case-exception-file)) | |
1447 | (t | |
97a62f83 | 1448 | (error (concat "No exception file specified. " |
eb4ed27f | 1449 | "See variable ada-case-exception-file")))))) |
4607c7f4 SM |
1450 | |
1451 | ;; Find the substring to define as an exception. Order is: the parameter, | |
1452 | ;; if any, or the selected region, or the word under the cursor | |
1453 | (cond | |
1454 | (word nil) | |
1455 | ||
1456 | ((ada-region-selected) | |
1457 | (setq word (buffer-substring-no-properties | |
1458 | (region-beginning) (region-end)))) | |
1459 | ||
1460 | (t | |
1461 | (let ((underscore-syntax (char-syntax ?_))) | |
1462 | (unwind-protect | |
1463 | (progn | |
1464 | (modify-syntax-entry ?_ "." (syntax-table)) | |
1465 | (save-excursion | |
1466 | (skip-syntax-backward "w") | |
1467 | (set 'word (buffer-substring-no-properties | |
1468 | (point) | |
1469 | (save-excursion (forward-word 1) (point)))))) | |
1470 | (modify-syntax-entry ?_ (make-string 1 underscore-syntax) | |
1471 | (syntax-table)))))) | |
1472 | ||
1473 | ;; Reread the exceptions file, in case it was modified by some other, | |
1474 | (ada-case-read-exceptions-from-file file-name) | |
1475 | ||
1476 | ;; If the word is already in the list, even with a different casing | |
1477 | ;; we simply want to replace it. | |
1478 | (if (and (not (equal ada-case-exception-substring '())) | |
f70b58b0 JB |
1479 | (assoc-string word ada-case-exception-substring t)) |
1480 | (setcar (assoc-string word ada-case-exception-substring t) word) | |
4607c7f4 SM |
1481 | (add-to-list 'ada-case-exception-substring (cons word t)) |
1482 | ) | |
1483 | ||
1484 | (ada-save-exceptions-to-file file-name) | |
1485 | ||
29a4e67d | 1486 | (message "%s" (concat "Defining " word " as a casing exception")))) |
4607c7f4 | 1487 | |
4cc7e498 GM |
1488 | (defun ada-case-read-exceptions-from-file (file-name) |
1489 | "Read the content of the casing exception file FILE-NAME." | |
1490 | (if (file-readable-p (expand-file-name file-name)) | |
7749c1a8 | 1491 | (let ((buffer (current-buffer))) |
f70b58b0 JB |
1492 | (find-file (expand-file-name file-name)) |
1493 | (set-syntax-table ada-mode-symbol-syntax-table) | |
1494 | (widen) | |
1495 | (goto-char (point-min)) | |
1496 | (while (not (eobp)) | |
1497 | ||
1498 | ;; If the item is already in the list, even with an other casing, | |
1499 | ;; do not add it again. This way, the user can easily decide which | |
1500 | ;; priority should be applied to each casing exception | |
1501 | (let ((word (buffer-substring-no-properties | |
1502 | (point) (save-excursion (forward-word 1) (point))))) | |
4607c7f4 SM |
1503 | |
1504 | ;; Handling a substring ? | |
1505 | (if (char-equal (string-to-char word) ?*) | |
1506 | (progn | |
1507 | (setq word (substring word 1)) | |
c2fb6415 | 1508 | (unless (assoc-string word ada-case-exception-substring t) |
4607c7f4 | 1509 | (add-to-list 'ada-case-exception-substring (cons word t)))) |
c2fb6415 | 1510 | (unless (assoc-string word ada-case-exception t) |
4607c7f4 | 1511 | (add-to-list 'ada-case-exception (cons word t))))) |
4cc7e498 | 1512 | |
f70b58b0 JB |
1513 | (forward-line 1)) |
1514 | (kill-buffer nil) | |
1515 | (set-buffer buffer))) | |
4cc7e498 GM |
1516 | ) |
1517 | ||
1518 | (defun ada-case-read-exceptions () | |
1519 | "Read all the casing exception files from `ada-case-exception-file'." | |
1520 | (interactive) | |
1521 | ||
1522 | ;; Reinitialize the casing exception list | |
4607c7f4 SM |
1523 | (setq ada-case-exception '() |
1524 | ada-case-exception-substring '()) | |
4cc7e498 GM |
1525 | |
1526 | (cond ((stringp ada-case-exception-file) | |
f70b58b0 | 1527 | (ada-case-read-exceptions-from-file ada-case-exception-file)) |
4cc7e498 | 1528 | |
f70b58b0 JB |
1529 | ((listp ada-case-exception-file) |
1530 | (mapcar 'ada-case-read-exceptions-from-file | |
1531 | ada-case-exception-file)))) | |
7749c1a8 | 1532 | |
4607c7f4 SM |
1533 | (defun ada-adjust-case-substring () |
1534 | "Adjust case of substrings in the previous word." | |
1535 | (interactive) | |
1536 | (let ((substrings ada-case-exception-substring) | |
1537 | (max (point)) | |
1538 | (case-fold-search t) | |
1539 | (underscore-syntax (char-syntax ?_)) | |
1540 | re) | |
1541 | ||
1542 | (save-excursion | |
1543 | (forward-word -1) | |
a1506d29 | 1544 | |
4607c7f4 SM |
1545 | (unwind-protect |
1546 | (progn | |
1547 | (modify-syntax-entry ?_ "." (syntax-table)) | |
a1506d29 | 1548 | |
4607c7f4 SM |
1549 | (while substrings |
1550 | (setq re (concat "\\b" (regexp-quote (caar substrings)) "\\b")) | |
a1506d29 | 1551 | |
4607c7f4 SM |
1552 | (save-excursion |
1553 | (while (re-search-forward re max t) | |
f7a80909 | 1554 | (replace-match (caar substrings) t))) |
4607c7f4 SM |
1555 | (setq substrings (cdr substrings)) |
1556 | ) | |
1557 | ) | |
1558 | (modify-syntax-entry ?_ (make-string 1 underscore-syntax) (syntax-table))) | |
1559 | ))) | |
1560 | ||
7749c1a8 | 1561 | (defun ada-adjust-case-identifier () |
655880d2 | 1562 | "Adjust case of the previous identifier. |
97a62f83 JB |
1563 | The auto-casing is done according to the value of `ada-case-identifier' |
1564 | and the exceptions defined in `ada-case-exception-file'." | |
4cc7e498 | 1565 | (interactive) |
7749c1a8 | 1566 | (if (or (equal ada-case-exception '()) |
f70b58b0 | 1567 | (equal (char-after) ?_)) |
4607c7f4 SM |
1568 | (progn |
1569 | (funcall ada-case-identifier -1) | |
1570 | (ada-adjust-case-substring)) | |
972579f9 | 1571 | |
7749c1a8 GM |
1572 | (progn |
1573 | (let ((end (point)) | |
f70b58b0 JB |
1574 | (start (save-excursion (skip-syntax-backward "w") |
1575 | (point))) | |
1576 | match) | |
1577 | ;; If we have an exception, replace the word by the correct casing | |
1578 | (if (setq match (assoc-string (buffer-substring start end) | |
c2fb6415 | 1579 | ada-case-exception t)) |
972579f9 | 1580 | |
f70b58b0 JB |
1581 | (progn |
1582 | (delete-region start end) | |
1583 | (insert (car match))) | |
972579f9 | 1584 | |
f70b58b0 JB |
1585 | ;; Else simply re-case the word |
1586 | (funcall ada-case-identifier -1) | |
4607c7f4 | 1587 | (ada-adjust-case-substring)))))) |
972579f9 RS |
1588 | |
1589 | (defun ada-after-keyword-p () | |
6d533a6e | 1590 | "Return t if cursor is after a keyword that is not an attribute." |
972579f9 RS |
1591 | (save-excursion |
1592 | (forward-word -1) | |
4cc7e498 | 1593 | (and (not (and (char-before) |
f70b58b0 JB |
1594 | (or (= (char-before) ?_) |
1595 | (= (char-before) ?'))));; unless we have a _ or ' | |
1596 | (looking-at (concat ada-keywords "[^_]"))))) | |
972579f9 RS |
1597 | |
1598 | (defun ada-adjust-case (&optional force-identifier) | |
6d533a6e | 1599 | "Adjust the case of the word before the character just typed. |
655880d2 | 1600 | If FORCE-IDENTIFIER is non-nil then also adjust keyword as identifier." |
4607c7f4 SM |
1601 | (if (not (bobp)) |
1602 | (progn | |
1603 | (forward-char -1) | |
1604 | (if (and (not (bobp)) | |
1605 | ;; or if at the end of a character constant | |
1606 | (not (and (eq (following-char) ?') | |
1607 | (eq (char-before (1- (point))) ?'))) | |
1608 | ;; or if the previous character was not part of a word | |
1609 | (eq (char-syntax (char-before)) ?w) | |
1610 | ;; if in a string or a comment | |
1611 | (not (ada-in-string-or-comment-p)) | |
f29fd869 CY |
1612 | ;; if in a numeric literal |
1613 | (not (ada-in-numeric-literal-p)) | |
4607c7f4 SM |
1614 | ) |
1615 | (if (save-excursion | |
1616 | (forward-word -1) | |
1617 | (or (= (point) (point-min)) | |
1618 | (backward-char 1)) | |
1619 | (= (following-char) ?')) | |
1620 | (funcall ada-case-attribute -1) | |
1621 | (if (and | |
1622 | (not force-identifier) ; (MH) | |
1623 | (ada-after-keyword-p)) | |
1624 | (funcall ada-case-keyword -1) | |
1625 | (ada-adjust-case-identifier)))) | |
1626 | (forward-char 1) | |
1627 | )) | |
7749c1a8 | 1628 | ) |
972579f9 RS |
1629 | |
1630 | (defun ada-adjust-case-interactive (arg) | |
655880d2 | 1631 | "Adjust the case of the previous word, and process the character just typed. |
6d533a6e | 1632 | ARG is the prefix the user entered with \\[universal-argument]." |
972579f9 | 1633 | (interactive "P") |
972579f9 | 1634 | |
4cc7e498 | 1635 | (if ada-auto-case |
1ba983e8 | 1636 | (let ((lastk last-command-event) |
f70b58b0 | 1637 | (previous-syntax-table (syntax-table))) |
4cc7e498 GM |
1638 | |
1639 | (unwind-protect | |
1640 | (progn | |
1641 | (set-syntax-table ada-mode-symbol-syntax-table) | |
1642 | (cond ((or (eq lastk ?\n) | |
1643 | (eq lastk ?\r)) | |
1644 | ;; horrible kludge | |
1645 | (insert " ") | |
1646 | (ada-adjust-case) | |
1647 | ;; horrible dekludge | |
1648 | (delete-backward-char 1) | |
1649 | ;; some special keys and their bindings | |
1650 | (cond | |
1651 | ((eq lastk ?\n) | |
1652 | (funcall ada-lfd-binding)) | |
1653 | ((eq lastk ?\r) | |
1654 | (funcall ada-ret-binding)))) | |
1655 | ((eq lastk ?\C-i) (ada-tab)) | |
1656 | ;; Else just insert the character | |
f70b58b0 | 1657 | ((self-insert-command (prefix-numeric-value arg)))) |
4cc7e498 GM |
1658 | ;; if there is a keyword in front of the underscore |
1659 | ;; then it should be part of an identifier (MH) | |
1660 | (if (eq lastk ?_) | |
1661 | (ada-adjust-case t) | |
1662 | (ada-adjust-case)) | |
1663 | ) | |
1664 | ;; Restore the syntax table | |
1665 | (set-syntax-table previous-syntax-table)) | |
f70b58b0 | 1666 | ) |
4cc7e498 GM |
1667 | |
1668 | ;; Else, no auto-casing | |
1669 | (cond | |
1ba983e8 | 1670 | ((eq last-command-event ?\n) |
4cc7e498 | 1671 | (funcall ada-lfd-binding)) |
1ba983e8 | 1672 | ((eq last-command-event ?\r) |
4cc7e498 GM |
1673 | (funcall ada-ret-binding)) |
1674 | (t | |
1675 | (self-insert-command (prefix-numeric-value arg)))) | |
1676 | )) | |
972579f9 RS |
1677 | |
1678 | (defun ada-activate-keys-for-case () | |
6d533a6e | 1679 | "Modify the key bindings for all the keys that should readjust the casing." |
7749c1a8 | 1680 | (interactive) |
4cc7e498 GM |
1681 | ;; Save original key-bindings to allow swapping ret/lfd |
1682 | ;; when casing is activated. | |
1683 | ;; The 'or ...' is there to be sure that the value will not | |
1684 | ;; be changed again when Ada mode is called more than once | |
36144b26 SM |
1685 | (or ada-ret-binding (setq ada-ret-binding (key-binding "\C-M"))) |
1686 | (or ada-lfd-binding (setq ada-lfd-binding (key-binding "\C-j"))) | |
4cc7e498 GM |
1687 | |
1688 | ;; Call case modifying function after certain keys. | |
972579f9 | 1689 | (mapcar (function (lambda(key) (define-key |
f70b58b0 JB |
1690 | ada-mode-map |
1691 | (char-to-string key) | |
1692 | 'ada-adjust-case-interactive))) | |
1693 | '( ?` ?_ ?# ?% ?& ?* ?( ?) ?- ?= ?+ | |
1694 | ?| ?\; ?: ?' ?\" ?< ?, ?. ?> ?/ ?\n 32 ?\r ))) | |
972579f9 | 1695 | |
972579f9 | 1696 | (defun ada-loose-case-word (&optional arg) |
655880d2 GM |
1697 | "Upcase first letter and letters following `_' in the following word. |
1698 | No other letter is modified. | |
1699 | ARG is ignored, and is there for compatibility with `capitalize-word' only." | |
7749c1a8 | 1700 | (interactive) |
4cc7e498 GM |
1701 | (save-excursion |
1702 | (let ((end (save-excursion (skip-syntax-forward "w") (point))) | |
f70b58b0 | 1703 | (first t)) |
4cc7e498 GM |
1704 | (skip-syntax-backward "w") |
1705 | (while (and (or first (search-forward "_" end t)) | |
f70b58b0 JB |
1706 | (< (point) end)) |
1707 | (and first | |
1708 | (setq first nil)) | |
1709 | (insert-char (upcase (following-char)) 1) | |
1710 | (delete-char 1))))) | |
4cc7e498 GM |
1711 | |
1712 | (defun ada-no-auto-case (&optional arg) | |
f70b58b0 JB |
1713 | "Do nothing. ARG is ignored. |
1714 | This function can be used for the auto-casing variables in Ada mode, to | |
97a62f83 | 1715 | adapt to unusal auto-casing schemes. Since it does nothing, you can for |
4cc7e498 GM |
1716 | instance use it for `ada-case-identifier' if you don't want any special |
1717 | auto-casing for identifiers, whereas keywords have to be lower-cased. | |
1718 | See also `ada-auto-case' to disable auto casing altogether." | |
32b1a27f | 1719 | nil) |
972579f9 | 1720 | |
7749c1a8 | 1721 | (defun ada-capitalize-word (&optional arg) |
655880d2 GM |
1722 | "Upcase first letter and letters following '_', lower case other letters. |
1723 | ARG is ignored, and is there for compatibility with `capitalize-word' only." | |
7749c1a8 | 1724 | (interactive) |
4cc7e498 | 1725 | (let ((end (save-excursion (skip-syntax-forward "w") (point))) |
f70b58b0 | 1726 | (begin (save-excursion (skip-syntax-backward "w") (point)))) |
7749c1a8 | 1727 | (modify-syntax-entry ?_ "_") |
4cc7e498 | 1728 | (capitalize-region begin end) |
7749c1a8 | 1729 | (modify-syntax-entry ?_ "w"))) |
972579f9 | 1730 | |
972579f9 | 1731 | (defun ada-adjust-case-region (from to) |
6d533a6e JB |
1732 | "Adjust the case of all words in the region between FROM and TO. |
1733 | Attention: This function might take very long for big regions!" | |
972579f9 RS |
1734 | (interactive "*r") |
1735 | (let ((begin nil) | |
f70b58b0 JB |
1736 | (end nil) |
1737 | (keywordp nil) | |
1738 | (attribp nil) | |
1739 | (previous-syntax-table (syntax-table))) | |
7749c1a8 | 1740 | (message "Adjusting case ...") |
f139ce87 | 1741 | (unwind-protect |
f70b58b0 JB |
1742 | (save-excursion |
1743 | (set-syntax-table ada-mode-symbol-syntax-table) | |
1744 | (goto-char to) | |
1745 | ;; | |
1746 | ;; loop: look for all identifiers, keywords, and attributes | |
1747 | ;; | |
1748 | (while (re-search-backward "\\<\\(\\sw+\\)\\>" from t) | |
1749 | (setq end (match-end 1)) | |
1750 | (setq attribp | |
1751 | (and (> (point) from) | |
1752 | (save-excursion | |
1753 | (forward-char -1) | |
1754 | (setq attribp (looking-at "'.[^']"))))) | |
1755 | (or | |
1756 | ;; do nothing if it is a string or comment | |
1757 | (ada-in-string-or-comment-p) | |
1758 | (progn | |
1759 | ;; | |
1760 | ;; get the identifier or keyword or attribute | |
1761 | ;; | |
1762 | (setq begin (point)) | |
1763 | (setq keywordp (looking-at ada-keywords)) | |
1764 | (goto-char end) | |
1765 | ;; | |
1766 | ;; casing according to user-option | |
1767 | ;; | |
1768 | (if attribp | |
1769 | (funcall ada-case-attribute -1) | |
1770 | (if keywordp | |
1771 | (funcall ada-case-keyword -1) | |
1772 | (ada-adjust-case-identifier))) | |
1773 | (goto-char begin)))) | |
1774 | (message "Adjusting case ... Done")) | |
7749c1a8 | 1775 | (set-syntax-table previous-syntax-table)))) |
972579f9 | 1776 | |
972579f9 | 1777 | (defun ada-adjust-case-buffer () |
97a62f83 | 1778 | "Adjust the case of all words in the whole buffer. |
6d533a6e | 1779 | ATTENTION: This function might take very long for big buffers!" |
f139ce87 | 1780 | (interactive "*") |
972579f9 RS |
1781 | (ada-adjust-case-region (point-min) (point-max))) |
1782 | ||
1783 | \f | |
655880d2 GM |
1784 | ;;-------------------------------------------------------------- |
1785 | ;; Format Parameter Lists | |
1786 | ;; Some special algorithms are provided to indent the parameter lists in | |
1787 | ;; subprogram declarations. This is done in two steps: | |
1788 | ;; - First parses the parameter list. The returned list has the following | |
1789 | ;; format: | |
1790 | ;; ( (<Param_Name> in? out? access? <Type_Name> <Default_Expression>) | |
1791 | ;; ... ) | |
1792 | ;; This is done in `ada-scan-paramlist'. | |
1793 | ;; - Delete and recreate the parameter list in function | |
4cc7e498 GM |
1794 | ;; `ada-insert-paramlist'. |
1795 | ;; Both steps are called from `ada-format-paramlist'. | |
655880d2 GM |
1796 | ;; Note: Comments inside the parameter list are lost. |
1797 | ;; The syntax has to be correct, or the reformating will fail. | |
1798 | ;;-------------------------------------------------------------- | |
972579f9 | 1799 | |
655880d2 | 1800 | (defun ada-format-paramlist () |
6d533a6e | 1801 | "Reformat the parameter list point is in." |
972579f9 RS |
1802 | (interactive) |
1803 | (let ((begin nil) | |
f70b58b0 JB |
1804 | (end nil) |
1805 | (delend nil) | |
1806 | (paramlist nil) | |
1807 | (previous-syntax-table (syntax-table))) | |
f139ce87 | 1808 | (unwind-protect |
f70b58b0 JB |
1809 | (progn |
1810 | (set-syntax-table ada-mode-symbol-syntax-table) | |
655880d2 | 1811 | |
f70b58b0 JB |
1812 | ;; check if really inside parameter list |
1813 | (or (ada-in-paramlist-p) | |
1814 | (error "Not in parameter list")) | |
f139ce87 | 1815 | |
f70b58b0 JB |
1816 | ;; find start of current parameter-list |
1817 | (ada-search-ignore-string-comment | |
1818 | (concat ada-subprog-start-re "\\|\\<body\\>" ) t nil) | |
1819 | (down-list 1) | |
1820 | (backward-char 1) | |
1821 | (setq begin (point)) | |
1822 | ||
1823 | ;; find end of parameter-list | |
1824 | (forward-sexp 1) | |
1825 | (setq delend (point)) | |
1826 | (delete-char -1) | |
1827 | (insert "\n") | |
f139ce87 | 1828 | |
f70b58b0 JB |
1829 | ;; find end of last parameter-declaration |
1830 | (forward-comment -1000) | |
1831 | (setq end (point)) | |
f139ce87 | 1832 | |
f70b58b0 JB |
1833 | ;; build a list of all elements of the parameter-list |
1834 | (setq paramlist (ada-scan-paramlist (1+ begin) end)) | |
f139ce87 | 1835 | |
f70b58b0 JB |
1836 | ;; delete the original parameter-list |
1837 | (delete-region begin delend) | |
f139ce87 | 1838 | |
f70b58b0 JB |
1839 | ;; insert the new parameter-list |
1840 | (goto-char begin) | |
1841 | (ada-insert-paramlist paramlist)) | |
f139ce87 | 1842 | |
f139ce87 | 1843 | ;; restore syntax-table |
7749c1a8 | 1844 | (set-syntax-table previous-syntax-table) |
f139ce87 | 1845 | ))) |
972579f9 | 1846 | |
972579f9 | 1847 | (defun ada-scan-paramlist (begin end) |
655880d2 | 1848 | "Scan the parameter list found in between BEGIN and END. |
6d533a6e | 1849 | Return the equivalent internal parameter list." |
972579f9 | 1850 | (let ((paramlist (list)) |
f70b58b0 JB |
1851 | (param (list)) |
1852 | (notend t) | |
1853 | (apos nil) | |
1854 | (epos nil) | |
1855 | (semipos nil) | |
1856 | (match-cons nil)) | |
972579f9 RS |
1857 | |
1858 | (goto-char begin) | |
655880d2 | 1859 | |
972579f9 | 1860 | ;; loop until end of last parameter |
972579f9 RS |
1861 | (while notend |
1862 | ||
972579f9 | 1863 | ;; find first character of parameter-declaration |
972579f9 | 1864 | (ada-goto-next-non-ws) |
36144b26 | 1865 | (setq apos (point)) |
972579f9 | 1866 | |
972579f9 | 1867 | ;; find last character of parameter-declaration |
36144b26 | 1868 | (if (setq match-cons |
f70b58b0 JB |
1869 | (ada-search-ignore-string-comment "[ \t\n]*;" nil end t)) |
1870 | (progn | |
1871 | (setq epos (car match-cons)) | |
1872 | (setq semipos (cdr match-cons))) | |
1873 | (setq epos end)) | |
972579f9 | 1874 | |
972579f9 | 1875 | ;; read name(s) of parameter(s) |
972579f9 | 1876 | (goto-char apos) |
7749c1a8 | 1877 | (looking-at "\\(\\(\\sw\\|[_, \t\n]\\)*\\(\\sw\\|_\\)\\)[ \t\n]*:[^=]") |
972579f9 | 1878 | |
36144b26 | 1879 | (setq param (list (match-string 1))) |
7749c1a8 | 1880 | (ada-search-ignore-string-comment ":" nil epos t 'search-forward) |
972579f9 | 1881 | |
972579f9 | 1882 | ;; look for 'in' |
36144b26 SM |
1883 | (setq apos (point)) |
1884 | (setq param | |
f70b58b0 JB |
1885 | (append param |
1886 | (list | |
1887 | (consp | |
1888 | (ada-search-ignore-string-comment | |
1889 | "in" nil epos t 'word-search-forward))))) | |
972579f9 | 1890 | |
972579f9 | 1891 | ;; look for 'out' |
972579f9 | 1892 | (goto-char apos) |
36144b26 | 1893 | (setq param |
f70b58b0 JB |
1894 | (append param |
1895 | (list | |
1896 | (consp | |
1897 | (ada-search-ignore-string-comment | |
1898 | "out" nil epos t 'word-search-forward))))) | |
972579f9 | 1899 | |
5e1cecee | 1900 | ;; look for 'access' |
972579f9 | 1901 | (goto-char apos) |
36144b26 | 1902 | (setq param |
f70b58b0 JB |
1903 | (append param |
1904 | (list | |
1905 | (consp | |
1906 | (ada-search-ignore-string-comment | |
1907 | "access" nil epos t 'word-search-forward))))) | |
972579f9 | 1908 | |
5e1cecee | 1909 | ;; skip 'in'/'out'/'access' |
972579f9 RS |
1910 | (goto-char apos) |
1911 | (ada-goto-next-non-ws) | |
5e1cecee | 1912 | (while (looking-at "\\<\\(in\\|out\\|access\\)\\>") |
f70b58b0 JB |
1913 | (forward-word 1) |
1914 | (ada-goto-next-non-ws)) | |
972579f9 | 1915 | |
7749c1a8 | 1916 | ;; read type of parameter |
4cc7e498 GM |
1917 | ;; We accept spaces in the name, since some software like Rose |
1918 | ;; generates something like: "A : B 'Class" | |
1919 | (looking-at "\\<\\(\\sw\\|[_.' \t]\\)+\\>") | |
36144b26 | 1920 | (setq param |
f70b58b0 JB |
1921 | (append param |
1922 | (list (match-string 0)))) | |
972579f9 | 1923 | |
972579f9 | 1924 | ;; read default-expression, if there is one |
36144b26 SM |
1925 | (goto-char (setq apos (match-end 0))) |
1926 | (setq param | |
f70b58b0 JB |
1927 | (append param |
1928 | (list | |
1929 | (if (setq match-cons | |
1930 | (ada-search-ignore-string-comment | |
1931 | ":=" nil epos t 'search-forward)) | |
1932 | (buffer-substring (car match-cons) epos) | |
1933 | nil)))) | |
655880d2 | 1934 | |
972579f9 | 1935 | ;; add this parameter-declaration to the list |
36144b26 | 1936 | (setq paramlist (append paramlist (list param))) |
972579f9 | 1937 | |
972579f9 | 1938 | ;; check if it was the last parameter |
972579f9 | 1939 | (if (eq epos end) |
f70b58b0 JB |
1940 | (setq notend nil) |
1941 | (goto-char semipos)) | |
655880d2 | 1942 | ) |
972579f9 RS |
1943 | (reverse paramlist))) |
1944 | ||
972579f9 | 1945 | (defun ada-insert-paramlist (paramlist) |
6d533a6e | 1946 | "Insert a formatted PARAMLIST in the buffer." |
972579f9 | 1947 | (let ((i (length paramlist)) |
f70b58b0 JB |
1948 | (parlen 0) |
1949 | (typlen 0) | |
1950 | (inp nil) | |
1951 | (outp nil) | |
1952 | (accessp nil) | |
1953 | (column nil) | |
1954 | (firstcol nil)) | |
972579f9 | 1955 | |
972579f9 | 1956 | ;; loop until last parameter |
972579f9 | 1957 | (while (not (zerop i)) |
36144b26 | 1958 | (setq i (1- i)) |
972579f9 | 1959 | |
972579f9 | 1960 | ;; get max length of parameter-name |
36144b26 | 1961 | (setq parlen (max parlen (length (nth 0 (nth i paramlist))))) |
972579f9 | 1962 | |
972579f9 | 1963 | ;; get max length of type-name |
36144b26 | 1964 | (setq typlen (max typlen (length (nth 4 (nth i paramlist))))) |
972579f9 | 1965 | |
972579f9 | 1966 | ;; is there any 'in' ? |
36144b26 | 1967 | (setq inp (or inp (nth 1 (nth i paramlist)))) |
972579f9 | 1968 | |
972579f9 | 1969 | ;; is there any 'out' ? |
36144b26 | 1970 | (setq outp (or outp (nth 2 (nth i paramlist)))) |
972579f9 | 1971 | |
5e1cecee | 1972 | ;; is there any 'access' ? |
36144b26 | 1973 | (setq accessp (or accessp (nth 3 (nth i paramlist)))) |
655880d2 | 1974 | ) |
972579f9 | 1975 | |
972579f9 | 1976 | ;; does paramlist already start on a separate line ? |
972579f9 | 1977 | (if (save-excursion |
f70b58b0 JB |
1978 | (re-search-backward "^.\\|[^ \t]" nil t) |
1979 | (looking-at "^.")) | |
1980 | ;; yes => re-indent it | |
1981 | (progn | |
1982 | (ada-indent-current) | |
1983 | (save-excursion | |
1984 | (if (looking-at "\\(is\\|return\\)") | |
1985 | (replace-match " \\1")))) | |
655880d2 | 1986 | |
7749c1a8 | 1987 | ;; no => insert it where we are after removing any whitespace |
7749c1a8 GM |
1988 | (fixup-whitespace) |
1989 | (save-excursion | |
f70b58b0 JB |
1990 | (cond |
1991 | ((looking-at "[ \t]*\\(\n\\|;\\)") | |
1992 | (replace-match "\\1")) | |
1993 | ((looking-at "[ \t]*\\(is\\|return\\)") | |
1994 | (replace-match " \\1")))) | |
7749c1a8 | 1995 | (insert " ")) |
972579f9 RS |
1996 | |
1997 | (insert "(") | |
7749c1a8 | 1998 | (ada-indent-current) |
972579f9 | 1999 | |
36144b26 SM |
2000 | (setq firstcol (current-column)) |
2001 | (setq i (length paramlist)) | |
972579f9 | 2002 | |
972579f9 | 2003 | ;; loop until last parameter |
972579f9 | 2004 | (while (not (zerop i)) |
36144b26 SM |
2005 | (setq i (1- i)) |
2006 | (setq column firstcol) | |
972579f9 | 2007 | |
972579f9 | 2008 | ;; insert parameter-name, space and colon |
972579f9 RS |
2009 | (insert (nth 0 (nth i paramlist))) |
2010 | (indent-to (+ column parlen 1)) | |
2011 | (insert ": ") | |
36144b26 | 2012 | (setq column (current-column)) |
972579f9 | 2013 | |
972579f9 | 2014 | ;; insert 'in' or space |
972579f9 | 2015 | (if (nth 1 (nth i paramlist)) |
f70b58b0 JB |
2016 | (insert "in ") |
2017 | (if (and | |
2018 | (or inp | |
2019 | accessp) | |
2020 | (not (nth 3 (nth i paramlist)))) | |
2021 | (insert " "))) | |
972579f9 | 2022 | |
972579f9 | 2023 | ;; insert 'out' or space |
972579f9 | 2024 | (if (nth 2 (nth i paramlist)) |
f70b58b0 JB |
2025 | (insert "out ") |
2026 | (if (and | |
2027 | (or outp | |
2028 | accessp) | |
2029 | (not (nth 3 (nth i paramlist)))) | |
2030 | (insert " "))) | |
972579f9 | 2031 | |
5e1cecee | 2032 | ;; insert 'access' |
972579f9 | 2033 | (if (nth 3 (nth i paramlist)) |
f70b58b0 | 2034 | (insert "access ")) |
972579f9 | 2035 | |
36144b26 | 2036 | (setq column (current-column)) |
972579f9 | 2037 | |
972579f9 | 2038 | ;; insert type-name and, if necessary, space and default-expression |
972579f9 RS |
2039 | (insert (nth 4 (nth i paramlist))) |
2040 | (if (nth 5 (nth i paramlist)) | |
f70b58b0 JB |
2041 | (progn |
2042 | (indent-to (+ column typlen 1)) | |
2043 | (insert (nth 5 (nth i paramlist))))) | |
972579f9 | 2044 | |
972579f9 | 2045 | ;; check if it was the last parameter |
7749c1a8 | 2046 | (if (zerop i) |
f70b58b0 JB |
2047 | (insert ")") |
2048 | ;; no => insert ';' and newline and indent | |
2049 | (insert ";") | |
2050 | (newline) | |
2051 | (indent-to firstcol)) | |
655880d2 | 2052 | ) |
972579f9 | 2053 | |
7749c1a8 | 2054 | ;; if anything follows, except semicolon, newline, is or return |
972579f9 | 2055 | ;; put it in a new line and indent it |
7749c1a8 GM |
2056 | (unless (looking-at "[ \t]*\\(;\\|\n\\|is\\|return\\)") |
2057 | (ada-indent-newline-indent)) | |
972579f9 RS |
2058 | )) |
2059 | ||
972579f9 RS |
2060 | |
2061 | \f | |
655880d2 GM |
2062 | ;;;---------------------------------------------------------------- |
2063 | ;; Indentation Engine | |
2064 | ;; All indentations are indicated as a two-element string: | |
2065 | ;; - position of reference in the buffer | |
2066 | ;; - offset to indent from this position (can also be a symbol or a list | |
2067 | ;; that are evaluated) | |
2068 | ;; Thus the total indentation for a line is the column number of the reference | |
2069 | ;; position plus whatever value the evaluation of the second element provides. | |
0347188a | 2070 | ;; This mechanism is used so that the Ada mode can "explain" how the |
655880d2 GM |
2071 | ;; indentation was calculated, by showing which variables were used. |
2072 | ;; | |
2073 | ;; The indentation itself is done in only one pass: first we try to guess in | |
2074 | ;; what context we are by looking at the following keyword or punctuation | |
2075 | ;; sign. If nothing remarkable is found, just try to guess the indentation | |
2076 | ;; based on previous lines. | |
2077 | ;; | |
2078 | ;; The relevant functions for indentation are: | |
2079 | ;; - `ada-indent-region': Re-indent a region of text | |
2080 | ;; - `ada-justified-indent-current': Re-indent the current line and shows the | |
2081 | ;; calculation that were done | |
2082 | ;; - `ada-indent-current': Re-indent the current line | |
2083 | ;; - `ada-get-current-indent': Calculate the indentation for the current line, | |
2084 | ;; based on the context (see above). | |
2085 | ;; - `ada-get-indent-*': Calculate the indentation in a specific context. | |
4cc7e498 GM |
2086 | ;; For efficiency, these functions do not check they are in the correct |
2087 | ;; context. | |
655880d2 | 2088 | ;;;---------------------------------------------------------------- |
972579f9 | 2089 | |
972579f9 | 2090 | (defun ada-indent-region (beg end) |
4cc7e498 | 2091 | "Indent the region between BEG end END." |
972579f9 RS |
2092 | (interactive "*r") |
2093 | (goto-char beg) | |
f139ce87 | 2094 | (let ((block-done 0) |
f70b58b0 JB |
2095 | (lines-remaining (count-lines beg end)) |
2096 | (msg (format "%%4d out of %4d lines remaining ..." | |
2097 | (count-lines beg end))) | |
2098 | (endmark (copy-marker end))) | |
f139ce87 | 2099 | ;; catch errors while indenting |
7749c1a8 GM |
2100 | (while (< (point) endmark) |
2101 | (if (> block-done 39) | |
f70b58b0 | 2102 | (progn |
4cc7e498 GM |
2103 | (setq lines-remaining (- lines-remaining block-done) |
2104 | block-done 0) | |
2105 | (message msg lines-remaining))) | |
2106 | (if (= (char-after) ?\n) nil | |
f70b58b0 | 2107 | (ada-indent-current)) |
7749c1a8 | 2108 | (forward-line 1) |
4cc7e498 | 2109 | (setq block-done (1+ block-done))) |
97a62f83 | 2110 | (message "Indenting ... done"))) |
972579f9 | 2111 | |
972579f9 | 2112 | (defun ada-indent-newline-indent () |
6d533a6e | 2113 | "Indent the current line, insert a newline and then indent the new line." |
972579f9 | 2114 | (interactive "*") |
cadd3658 RS |
2115 | (ada-indent-current) |
2116 | (newline) | |
2117 | (ada-indent-current)) | |
972579f9 | 2118 | |
7749c1a8 | 2119 | (defun ada-indent-newline-indent-conditional () |
655880d2 | 2120 | "Insert a newline and indent it. |
0b702bc1 | 2121 | The original line is re-indented if `ada-indent-after-return' is non-nil." |
7749c1a8 | 2122 | (interactive "*") |
0b702bc1 SL |
2123 | ;; If at end of buffer (entering brand new code), some indentation |
2124 | ;; fails. For example, a block label requires whitespace following | |
2125 | ;; the : to be recognized. So we do the newline first, then | |
2126 | ;; go back and indent the original line. | |
7749c1a8 | 2127 | (newline) |
0b702bc1 SL |
2128 | (if ada-indent-after-return |
2129 | (progn | |
2130 | (forward-char -1) | |
2131 | (ada-indent-current) | |
2132 | (forward-char 1))) | |
7749c1a8 GM |
2133 | (ada-indent-current)) |
2134 | ||
2135 | (defun ada-justified-indent-current () | |
6d533a6e | 2136 | "Indent the current line and explain how the calculation was done." |
7749c1a8 GM |
2137 | (interactive) |
2138 | ||
2139 | (let ((cur-indent (ada-indent-current))) | |
2140 | ||
4607c7f4 SM |
2141 | (let ((line (save-excursion |
2142 | (goto-char (car cur-indent)) | |
80d50f88 | 2143 | (count-lines 1 (point))))) |
4607c7f4 SM |
2144 | |
2145 | (if (equal (cdr cur-indent) '(0)) | |
2146 | (message (concat "same indentation as line " (number-to-string line))) | |
29a4e67d DG |
2147 | (message "%s" (mapconcat (lambda(x) |
2148 | (cond | |
2149 | ((symbolp x) | |
2150 | (symbol-name x)) | |
2151 | ((numberp x) | |
2152 | (number-to-string x)) | |
2153 | ((listp x) | |
2154 | (concat "- " (symbol-name (cadr x)))) | |
2155 | )) | |
2156 | (cdr cur-indent) | |
2157 | " + ")))) | |
7749c1a8 GM |
2158 | (save-excursion |
2159 | (goto-char (car cur-indent)) | |
2160 | (sit-for 1)))) | |
972579f9 | 2161 | |
4cc7e498 GM |
2162 | (defun ada-batch-reformat () |
2163 | "Re-indent and re-case all the files found on the command line. | |
32b1a27f | 2164 | This function should be used from the command line, with a |
4cc7e498 GM |
2165 | command like: |
2166 | emacs -batch -l ada-mode -f ada-batch-reformat file1 file2 ..." | |
2167 | ||
2168 | (while command-line-args-left | |
2169 | (let ((source (car command-line-args-left))) | |
29a4e67d | 2170 | (message "Formating %s" source) |
4cc7e498 GM |
2171 | (find-file source) |
2172 | (ada-indent-region (point-min) (point-max)) | |
2173 | (ada-adjust-case-buffer) | |
2174 | (write-file source)) | |
36144b26 | 2175 | (setq command-line-args-left (cdr command-line-args-left))) |
4cc7e498 GM |
2176 | (message "Done") |
2177 | (kill-emacs 0)) | |
2178 | ||
2179 | (defsubst ada-goto-previous-word () | |
6d533a6e JB |
2180 | "Move point to the beginning of the previous word of Ada code. |
2181 | Return the new position of point or nil if not found." | |
4cc7e498 GM |
2182 | (ada-goto-next-word t)) |
2183 | ||
972579f9 | 2184 | (defun ada-indent-current () |
655880d2 | 2185 | "Indent current line as Ada code. |
32b1a27f JB |
2186 | Return the calculation that was done, including the reference point |
2187 | and the offset." | |
972579f9 | 2188 | (interactive) |
7749c1a8 | 2189 | (let ((previous-syntax-table (syntax-table)) |
f70b58b0 JB |
2190 | (orgpoint (point-marker)) |
2191 | cur-indent tmp-indent | |
2192 | prev-indent) | |
972579f9 | 2193 | |
7749c1a8 | 2194 | (unwind-protect |
f70b58b0 JB |
2195 | (progn |
2196 | (set-syntax-table ada-mode-symbol-syntax-table) | |
f139ce87 | 2197 | |
f70b58b0 JB |
2198 | ;; This need to be done here so that the advice is not always |
2199 | ;; activated (this might interact badly with other modes) | |
2200 | (if (featurep 'xemacs) | |
2201 | (ad-activate 'parse-partial-sexp t)) | |
4cc7e498 | 2202 | |
f70b58b0 JB |
2203 | (save-excursion |
2204 | (setq cur-indent | |
4cc7e498 | 2205 | |
f70b58b0 JB |
2206 | ;; Not First line in the buffer ? |
2207 | (if (save-excursion (zerop (forward-line -1))) | |
2208 | (progn | |
2209 | (back-to-indentation) | |
2210 | (ada-get-current-indent)) | |
4cc7e498 | 2211 | |
f70b58b0 JB |
2212 | ;; first line in the buffer |
2213 | (list (point-min) 0)))) | |
4cc7e498 | 2214 | |
f70b58b0 JB |
2215 | ;; Evaluate the list to get the column to indent to |
2216 | ;; prev-indent contains the column to indent to | |
4cc7e498 GM |
2217 | (if cur-indent |
2218 | (setq prev-indent (save-excursion (goto-char (car cur-indent)) | |
2219 | (current-column)) | |
2220 | tmp-indent (cdr cur-indent)) | |
2221 | (setq prev-indent 0 tmp-indent '())) | |
eaae8106 | 2222 | |
f70b58b0 JB |
2223 | (while (not (null tmp-indent)) |
2224 | (cond | |
2225 | ((numberp (car tmp-indent)) | |
2226 | (setq prev-indent (+ prev-indent (car tmp-indent)))) | |
2227 | (t | |
2228 | (setq prev-indent (+ prev-indent (eval (car tmp-indent))))) | |
2229 | ) | |
2230 | (setq tmp-indent (cdr tmp-indent))) | |
2231 | ||
2232 | ;; only re-indent if indentation is different then the current | |
2233 | (if (= (save-excursion (back-to-indentation) (current-column)) prev-indent) | |
2234 | nil | |
2235 | (beginning-of-line) | |
2236 | (delete-horizontal-space) | |
2237 | (indent-to prev-indent)) | |
2238 | ;; | |
2239 | ;; restore position of point | |
2240 | ;; | |
2241 | (goto-char orgpoint) | |
2242 | (if (< (current-column) (current-indentation)) | |
2243 | (back-to-indentation))) | |
4cc7e498 GM |
2244 | |
2245 | ;; restore syntax-table | |
2246 | (set-syntax-table previous-syntax-table) | |
6f9a2614 | 2247 | (if (featurep 'xemacs) |
f70b58b0 | 2248 | (ad-deactivate 'parse-partial-sexp)) |
4cc7e498 | 2249 | ) |
655880d2 | 2250 | |
7749c1a8 GM |
2251 | cur-indent |
2252 | )) | |
972579f9 | 2253 | |
7749c1a8 | 2254 | (defun ada-get-current-indent () |
4cc7e498 | 2255 | "Return the indentation to use for the current line." |
7749c1a8 | 2256 | (let (column |
f70b58b0 JB |
2257 | pos |
2258 | match-cons | |
4cc7e498 | 2259 | result |
f70b58b0 JB |
2260 | (orgpoint (save-excursion |
2261 | (beginning-of-line) | |
2262 | (forward-comment -10000) | |
2263 | (forward-line 1) | |
2264 | (point)))) | |
4cc7e498 | 2265 | |
36144b26 | 2266 | (setq result |
972579f9 | 2267 | (cond |
7749c1a8 | 2268 | |
4cc7e498 | 2269 | ;;----------------------------- |
972579f9 | 2270 | ;; in open parenthesis, but not in parameter-list |
4cc7e498 | 2271 | ;;----------------------------- |
eaae8106 | 2272 | |
4cc7e498 GM |
2273 | ((and ada-indent-to-open-paren |
2274 | (not (ada-in-paramlist-p)) | |
36144b26 | 2275 | (setq column (ada-in-open-paren-p))) |
eaae8106 | 2276 | |
972579f9 | 2277 | ;; check if we have something like this (Table_Component_Type => |
7749c1a8 | 2278 | ;; Source_File_Record) |
972579f9 | 2279 | (save-excursion |
4607c7f4 SM |
2280 | |
2281 | ;; Align the closing parenthesis on the opening one | |
2282 | (if (= (following-char) ?\)) | |
2283 | (save-excursion | |
2284 | (goto-char column) | |
2285 | (skip-chars-backward " \t") | |
2286 | (list (1- (point)) 0)) | |
a1506d29 | 2287 | |
4607c7f4 SM |
2288 | (if (and (skip-chars-backward " \t") |
2289 | (= (char-before) ?\n) | |
2290 | (not (forward-comment -10000)) | |
2291 | (= (char-before) ?>)) | |
2292 | ;; ??? Could use a different variable | |
2293 | (list column 'ada-broken-indent) | |
2294 | ||
80d50f88 SM |
2295 | ;; We want all continuation lines to be indented the same |
2296 | ;; (ada-broken-line from the opening parenthesis. However, in | |
2297 | ;; parameter list, each new parameter should be indented at the | |
2298 | ;; column as the opening parenthesis. | |
2299 | ||
2300 | ;; A special case to handle nested boolean expressions, as in | |
2301 | ;; ((B | |
2302 | ;; and then C) -- indented by ada-broken-indent | |
2303 | ;; or else D) -- indenting this line. | |
2304 | ;; ??? This is really a hack, we should have a proper way to go to | |
2305 | ;; ??? the beginning of the statement | |
a1506d29 | 2306 | |
80d50f88 SM |
2307 | (if (= (char-before) ?\)) |
2308 | (backward-sexp)) | |
a1506d29 | 2309 | |
80d50f88 SM |
2310 | (if (memq (char-before) '(?, ?\; ?\( ?\))) |
2311 | (list column 0) | |
2312 | (list column 'ada-continuation-indent) | |
2313 | ))))) | |
972579f9 | 2314 | |
4cc7e498 GM |
2315 | ;;--------------------------- |
2316 | ;; at end of buffer | |
2317 | ;;--------------------------- | |
972579f9 | 2318 | |
4cc7e498 GM |
2319 | ((not (char-after)) |
2320 | (ada-indent-on-previous-lines nil orgpoint orgpoint)) | |
eaae8106 | 2321 | |
4cc7e498 GM |
2322 | ;;--------------------------- |
2323 | ;; starting with e | |
2324 | ;;--------------------------- | |
eaae8106 | 2325 | |
4607c7f4 | 2326 | ((= (downcase (char-after)) ?e) |
4cc7e498 | 2327 | (cond |
972579f9 | 2328 | |
4cc7e498 | 2329 | ;; ------- end ------ |
eaae8106 | 2330 | |
4cc7e498 GM |
2331 | ((looking-at "end\\>") |
2332 | (let ((label 0) | |
2333 | limit) | |
2334 | (save-excursion | |
2335 | (ada-goto-matching-start 1) | |
eaae8106 | 2336 | |
4cc7e498 GM |
2337 | ;; |
2338 | ;; found 'loop' => skip back to 'while' or 'for' | |
2339 | ;; if 'loop' is not on a separate line | |
2340 | ;; Stop the search for 'while' and 'for' when a ';' is encountered. | |
2341 | ;; | |
2342 | (if (save-excursion | |
2343 | (beginning-of-line) | |
2344 | (looking-at ".+\\<loop\\>")) | |
2345 | (progn | |
2346 | (save-excursion | |
36144b26 | 2347 | (setq limit (car (ada-search-ignore-string-comment ";" t)))) |
4cc7e498 GM |
2348 | (if (save-excursion |
2349 | (and | |
36144b26 | 2350 | (setq match-cons |
4cc7e498 GM |
2351 | (ada-search-ignore-string-comment ada-loop-start-re t limit)) |
2352 | (not (looking-at "\\<loop\\>")))) | |
2353 | (progn | |
2354 | (goto-char (car match-cons)) | |
2355 | (save-excursion | |
0b702bc1 SL |
2356 | (back-to-indentation) |
2357 | (if (looking-at ada-block-label-re) | |
36144b26 | 2358 | (setq label (- ada-label-indent)))))))) |
a1506d29 | 2359 | |
4607c7f4 SM |
2360 | ;; found 'record' => |
2361 | ;; if the keyword is found at the beginning of a line (or just | |
2362 | ;; after limited, we indent on it, otherwise we indent on the | |
2363 | ;; beginning of the type declaration) | |
2364 | ;; type A is (B : Integer; | |
2365 | ;; C : Integer) is record | |
2366 | ;; end record; -- This is badly indented otherwise | |
2367 | (if (looking-at "record") | |
2368 | (if (save-excursion | |
2369 | (beginning-of-line) | |
2370 | (looking-at "^[ \t]*\\(record\\|limited record\\)")) | |
2371 | (list (save-excursion (back-to-indentation) (point)) 0) | |
2372 | (list (save-excursion | |
2373 | (car (ada-search-ignore-string-comment "\\<type\\>" t))) | |
2374 | 0)) | |
2375 | ||
2376 | ;; Else keep the same indentation as the beginning statement | |
2377 | (list (+ (save-excursion (back-to-indentation) (point)) label) 0))))) | |
4cc7e498 GM |
2378 | |
2379 | ;; ------ exception ---- | |
eaae8106 | 2380 | |
4cc7e498 GM |
2381 | ((looking-at "exception\\>") |
2382 | (save-excursion | |
2383 | (ada-goto-matching-start 1) | |
2384 | (list (save-excursion (back-to-indentation) (point)) 0))) | |
2385 | ||
2386 | ;; else | |
eaae8106 | 2387 | |
4cc7e498 | 2388 | ((looking-at "else\\>") |
ff003dc7 | 2389 | (if (save-excursion (ada-goto-previous-word) |
f70b58b0 | 2390 | (looking-at "\\<or\\>")) |
4cc7e498 GM |
2391 | (ada-indent-on-previous-lines nil orgpoint orgpoint) |
2392 | (save-excursion | |
2393 | (ada-goto-matching-start 1 nil t) | |
2394 | (list (progn (back-to-indentation) (point)) 0)))) | |
2395 | ||
2396 | ;; elsif | |
a1506d29 | 2397 | |
4cc7e498 GM |
2398 | ((looking-at "elsif\\>") |
2399 | (save-excursion | |
2400 | (ada-goto-matching-start 1 nil t) | |
2401 | (list (progn (back-to-indentation) (point)) 0))) | |
2402 | ||
2403 | )) | |
2404 | ||
2405 | ;;--------------------------- | |
2406 | ;; starting with w (when) | |
2407 | ;;--------------------------- | |
a1506d29 | 2408 | |
4607c7f4 | 2409 | ((and (= (downcase (char-after)) ?w) |
4cc7e498 | 2410 | (looking-at "when\\>")) |
972579f9 | 2411 | (save-excursion |
4cc7e498 GM |
2412 | (ada-goto-matching-start 1) |
2413 | (list (save-excursion (back-to-indentation) (point)) | |
2414 | 'ada-when-indent))) | |
2415 | ||
2416 | ;;--------------------------- | |
2417 | ;; starting with t (then) | |
2418 | ;;--------------------------- | |
2419 | ||
4607c7f4 | 2420 | ((and (= (downcase (char-after)) ?t) |
4cc7e498 | 2421 | (looking-at "then\\>")) |
7749c1a8 | 2422 | (if (save-excursion (ada-goto-previous-word) |
4cc7e498 | 2423 | (looking-at "and\\>")) |
7749c1a8 | 2424 | (ada-indent-on-previous-lines nil orgpoint orgpoint) |
4cc7e498 GM |
2425 | (save-excursion |
2426 | ;; Select has been added for the statement: "select ... then abort" | |
2427 | (ada-search-ignore-string-comment | |
2428 | "\\<\\(elsif\\|if\\|select\\)\\>" t nil) | |
2429 | (list (progn (back-to-indentation) (point)) | |
2430 | 'ada-stmt-end-indent)))) | |
2431 | ||
2432 | ;;--------------------------- | |
2433 | ;; starting with l (loop) | |
2434 | ;;--------------------------- | |
a1506d29 | 2435 | |
4607c7f4 | 2436 | ((and (= (downcase (char-after)) ?l) |
4cc7e498 | 2437 | (looking-at "loop\\>")) |
36144b26 | 2438 | (setq pos (point)) |
972579f9 | 2439 | (save-excursion |
f70b58b0 JB |
2440 | (goto-char (match-end 0)) |
2441 | (ada-goto-stmt-start) | |
2442 | (if (looking-at "\\<\\(loop\\|if\\)\\>") | |
2443 | (ada-indent-on-previous-lines nil orgpoint orgpoint) | |
2444 | (unless (looking-at ada-loop-start-re) | |
2445 | (ada-search-ignore-string-comment ada-loop-start-re | |
2446 | nil pos)) | |
2447 | (if (looking-at "\\<loop\\>") | |
2448 | (ada-indent-on-previous-lines nil orgpoint orgpoint) | |
2449 | (list (progn (back-to-indentation) (point)) 'ada-stmt-end-indent))))) | |
4cc7e498 | 2450 | |
4607c7f4 SM |
2451 | ;;---------------------------- |
2452 | ;; starting with l (limited) or r (record) | |
2453 | ;;---------------------------- | |
a1506d29 | 2454 | |
4607c7f4 SM |
2455 | ((or (and (= (downcase (char-after)) ?l) |
2456 | (looking-at "limited\\>")) | |
2457 | (and (= (downcase (char-after)) ?r) | |
2458 | (looking-at "record\\>"))) | |
2459 | ||
2460 | (save-excursion | |
2461 | (ada-search-ignore-string-comment | |
2462 | "\\<\\(type\\|use\\)\\>" t nil) | |
2463 | (if (looking-at "\\<use\\>") | |
2464 | (ada-search-ignore-string-comment "for" t nil nil | |
2465 | 'word-search-backward)) | |
2466 | (list (progn (back-to-indentation) (point)) | |
2467 | 'ada-indent-record-rel-type))) | |
2468 | ||
4cc7e498 GM |
2469 | ;;--------------------------- |
2470 | ;; starting with b (begin) | |
2471 | ;;--------------------------- | |
2472 | ||
4607c7f4 | 2473 | ((and (= (downcase (char-after)) ?b) |
4cc7e498 | 2474 | (looking-at "begin\\>")) |
972579f9 | 2475 | (save-excursion |
6a47c86a | 2476 | (if (ada-goto-decl-start t) |
f70b58b0 JB |
2477 | (list (progn (back-to-indentation) (point)) 0) |
2478 | (ada-indent-on-previous-lines nil orgpoint orgpoint)))) | |
4cc7e498 GM |
2479 | |
2480 | ;;--------------------------- | |
2481 | ;; starting with i (is) | |
2482 | ;;--------------------------- | |
2483 | ||
4607c7f4 | 2484 | ((and (= (downcase (char-after)) ?i) |
4cc7e498 | 2485 | (looking-at "is\\>")) |
eaae8106 | 2486 | |
7749c1a8 | 2487 | (if (and ada-indent-is-separate |
f70b58b0 JB |
2488 | (save-excursion |
2489 | (goto-char (match-end 0)) | |
2490 | (ada-goto-next-non-ws (save-excursion (end-of-line) | |
2491 | (point))) | |
2492 | (looking-at "\\<abstract\\>\\|\\<separate\\>"))) | |
2493 | (save-excursion | |
2494 | (ada-goto-stmt-start) | |
2495 | (list (progn (back-to-indentation) (point)) 'ada-indent)) | |
2496 | (save-excursion | |
2497 | (ada-goto-stmt-start) | |
fb0d1545 | 2498 | (if (looking-at "\\<overriding\\|package\\|procedure\\|function\\>") |
80d50f88 SM |
2499 | (list (progn (back-to-indentation) (point)) 0) |
2500 | (list (progn (back-to-indentation) (point)) 'ada-indent))))) | |
4cc7e498 GM |
2501 | |
2502 | ;;--------------------------- | |
4607c7f4 | 2503 | ;; starting with r (return, renames) |
4cc7e498 GM |
2504 | ;;--------------------------- |
2505 | ||
4607c7f4 SM |
2506 | ((and (= (downcase (char-after)) ?r) |
2507 | (looking-at "re\\(turn\\|names\\)\\>")) | |
a1506d29 | 2508 | |
4607c7f4 SM |
2509 | (save-excursion |
2510 | (let ((var 'ada-indent-return)) | |
2511 | ;; If looking at a renames, skip the 'return' statement too | |
2512 | (if (looking-at "renames") | |
2513 | (let (pos) | |
2514 | (save-excursion | |
2515 | (set 'pos (ada-search-ignore-string-comment ";\\|return\\>" t))) | |
2516 | (if (and pos | |
2517 | (= (downcase (char-after (car pos))) ?r)) | |
2518 | (goto-char (car pos))) | |
2519 | (set 'var 'ada-indent-renames))) | |
a1506d29 | 2520 | |
4607c7f4 SM |
2521 | (forward-comment -1000) |
2522 | (if (= (char-before) ?\)) | |
2523 | (forward-sexp -1) | |
2524 | (forward-word -1)) | |
a1506d29 | 2525 | |
4607c7f4 SM |
2526 | ;; If there is a parameter list, and we have a function declaration |
2527 | ;; or a access to subprogram declaration | |
2528 | (let ((num-back 1)) | |
2529 | (if (and (= (following-char) ?\() | |
2530 | (save-excursion | |
2531 | (or (progn | |
2532 | (backward-word 1) | |
2533 | (looking-at "\\(function\\|procedure\\)\\>")) | |
2534 | (progn | |
2535 | (backward-word 1) | |
2536 | (set 'num-back 2) | |
2537 | (looking-at "\\(function\\|procedure\\)\\>"))))) | |
a1506d29 | 2538 | |
4607c7f4 SM |
2539 | ;; The indentation depends of the value of ada-indent-return |
2540 | (if (<= (eval var) 0) | |
2541 | (list (point) (list '- var)) | |
2542 | (list (progn (backward-word num-back) (point)) | |
2543 | var)) | |
a1506d29 | 2544 | |
4607c7f4 SM |
2545 | ;; Else there is no parameter list, but we have a function |
2546 | ;; Only do something special if the user want to indent | |
2547 | ;; relative to the "function" keyword | |
2548 | (if (and (> (eval var) 0) | |
2549 | (save-excursion (forward-word -1) | |
2550 | (looking-at "function\\>"))) | |
2551 | (list (progn (forward-word -1) (point)) var) | |
a1506d29 | 2552 | |
4607c7f4 SM |
2553 | ;; Else... |
2554 | (ada-indent-on-previous-lines nil orgpoint orgpoint))))))) | |
a1506d29 | 2555 | |
4cc7e498 GM |
2556 | ;;-------------------------------- |
2557 | ;; starting with 'o' or 'p' | |
2558 | ;; 'or' as statement-start | |
2559 | ;; 'private' as statement-start | |
2560 | ;;-------------------------------- | |
2561 | ||
4607c7f4 SM |
2562 | ((and (or (= (downcase (char-after)) ?o) |
2563 | (= (downcase (char-after)) ?p)) | |
4cc7e498 GM |
2564 | (or (ada-looking-at-semi-or) |
2565 | (ada-looking-at-semi-private))) | |
972579f9 | 2566 | (save-excursion |
4607c7f4 SM |
2567 | ;; ??? Wasn't this done already in ada-looking-at-semi-or ? |
2568 | (ada-goto-matching-start 1) | |
2569 | (list (progn (back-to-indentation) (point)) 0))) | |
7749c1a8 | 2570 | |
4cc7e498 GM |
2571 | ;;-------------------------------- |
2572 | ;; starting with 'd' (do) | |
2573 | ;;-------------------------------- | |
2574 | ||
4607c7f4 | 2575 | ((and (= (downcase (char-after)) ?d) |
4cc7e498 | 2576 | (looking-at "do\\>")) |
972579f9 | 2577 | (save-excursion |
f70b58b0 JB |
2578 | (ada-goto-stmt-start) |
2579 | (list (progn (back-to-indentation) (point)) 'ada-stmt-end-indent))) | |
4cc7e498 GM |
2580 | |
2581 | ;;-------------------------------- | |
2582 | ;; starting with '-' (comment) | |
2583 | ;;-------------------------------- | |
2584 | ||
2585 | ((= (char-after) ?-) | |
2586 | (if ada-indent-comment-as-code | |
2587 | ||
2588 | ;; Indent comments on previous line comments if required | |
2589 | ;; We must use a search-forward (even if the code is more complex), | |
2590 | ;; since we want to find the beginning of the comment. | |
2591 | (let (pos) | |
eaae8106 | 2592 | |
4cc7e498 GM |
2593 | (if (and ada-indent-align-comments |
2594 | (save-excursion | |
2595 | (forward-line -1) | |
2596 | (beginning-of-line) | |
2597 | (while (and (not pos) | |
2598 | (search-forward "--" | |
2599 | (save-excursion | |
2600 | (end-of-line) (point)) | |
2601 | t)) | |
2602 | (unless (ada-in-string-p) | |
36144b26 | 2603 | (setq pos (point)))) |
4cc7e498 GM |
2604 | pos)) |
2605 | (list (- pos 2) 0) | |
eaae8106 | 2606 | |
4cc7e498 GM |
2607 | ;; Else always on previous line |
2608 | (ada-indent-on-previous-lines nil orgpoint orgpoint))) | |
2609 | ||
2610 | ;; Else same indentation as the previous line | |
f70b58b0 | 2611 | (list (save-excursion (back-to-indentation) (point)) 0))) |
4cc7e498 GM |
2612 | |
2613 | ;;-------------------------------- | |
2614 | ;; starting with '#' (preprocessor line) | |
2615 | ;;-------------------------------- | |
2616 | ||
2617 | ((and (= (char-after) ?#) | |
2618 | (equal ada-which-compiler 'gnat) | |
f70b58b0 | 2619 | (looking-at "#[ \t]*\\(if\\|els\\(e\\|if\\)\\|end[ \t]*if\\)")) |
4cc7e498 GM |
2620 | (list (save-excursion (beginning-of-line) (point)) 0)) |
2621 | ||
2622 | ;;-------------------------------- | |
2623 | ;; starting with ')' (end of a parameter list) | |
2624 | ;;-------------------------------- | |
2625 | ||
2626 | ((and (not (eobp)) (= (char-after) ?\))) | |
2627 | (save-excursion | |
f70b58b0 JB |
2628 | (forward-char 1) |
2629 | (backward-sexp 1) | |
2630 | (list (point) 0))) | |
4cc7e498 GM |
2631 | |
2632 | ;;--------------------------------- | |
2633 | ;; new/abstract/separate | |
2634 | ;;--------------------------------- | |
eaae8106 | 2635 | |
4cc7e498 GM |
2636 | ((looking-at "\\(new\\|abstract\\|separate\\)\\>") |
2637 | (ada-indent-on-previous-lines nil orgpoint orgpoint)) | |
2638 | ||
2639 | ;;--------------------------------- | |
972579f9 | 2640 | ;; package/function/procedure |
4cc7e498 GM |
2641 | ;;--------------------------------- |
2642 | ||
4607c7f4 | 2643 | ((and (or (= (downcase (char-after)) ?p) (= (downcase (char-after)) ?f)) |
4cc7e498 | 2644 | (looking-at "\\<\\(package\\|function\\|procedure\\)\\>")) |
972579f9 | 2645 | (save-excursion |
4cc7e498 | 2646 | ;; Go up until we find either a generic section, or the end of the |
fb0d1545 | 2647 | ;; previous subprogram/package, or 'overriding' for this function/procedure |
4cc7e498 GM |
2648 | (let (found) |
2649 | (while (and (not found) | |
2650 | (ada-search-ignore-string-comment | |
fb0d1545 | 2651 | "\\<\\(generic\\|end\\|begin\\|overriding\\|package\\|procedure\\|function\\)\\>" t)) |
eaae8106 | 2652 | |
4cc7e498 GM |
2653 | ;; avoid "with procedure"... in generic parts |
2654 | (save-excursion | |
2655 | (forward-word -1) | |
36144b26 | 2656 | (setq found (not (looking-at "with")))))) |
eaae8106 | 2657 | |
fb0d1545 SL |
2658 | (cond |
2659 | ((looking-at "\\<generic\\|overriding\\>") | |
2660 | (list (progn (back-to-indentation) (point)) 0)) | |
2661 | ||
2662 | (t | |
2663 | (ada-indent-on-previous-lines nil orgpoint orgpoint))))) | |
eaae8106 | 2664 | |
4cc7e498 | 2665 | ;;--------------------------------- |
972579f9 | 2666 | ;; label |
4cc7e498 | 2667 | ;;--------------------------------- |
eaae8106 | 2668 | |
0b702bc1 | 2669 | ((looking-at ada-label-re) |
972579f9 | 2670 | (if (ada-in-decl-p) |
0b702bc1 | 2671 | ;; ada-block-label-re matches variable declarations |
f70b58b0 JB |
2672 | (ada-indent-on-previous-lines nil orgpoint orgpoint) |
2673 | (append (ada-indent-on-previous-lines nil orgpoint orgpoint) | |
2674 | '(ada-label-indent)))) | |
4cc7e498 GM |
2675 | |
2676 | )) | |
2677 | ||
2678 | ;;--------------------------------- | |
2679 | ;; Other syntaxes | |
2680 | ;;--------------------------------- | |
2681 | (or result (ada-indent-on-previous-lines nil orgpoint orgpoint)))) | |
7749c1a8 GM |
2682 | |
2683 | (defun ada-indent-on-previous-lines (&optional nomove orgpoint initial-pos) | |
655880d2 GM |
2684 | "Calculate the indentation for the new line after ORGPOINT. |
2685 | The result list is based on the previous lines in the buffer. | |
2686 | If NOMOVE is nil, moves point to the beginning of the current statement. | |
2687 | if INITIAL-POS is non-nil, moves point to INITIAL-POS before calculation." | |
7749c1a8 GM |
2688 | (if initial-pos |
2689 | (goto-char initial-pos)) | |
4cc7e498 GM |
2690 | (let ((oldpoint (point))) |
2691 | ||
7749c1a8 | 2692 | ;; Is inside a parameter-list ? |
972579f9 | 2693 | (if (ada-in-paramlist-p) |
f70b58b0 | 2694 | (ada-get-indent-paramlist) |
972579f9 | 2695 | |
0b702bc1 SL |
2696 | ;; Move to beginning of current statement. If already at a |
2697 | ;; statement start, move to beginning of enclosing statement. | |
7749c1a8 | 2698 | (unless nomove |
0b702bc1 | 2699 | (ada-goto-stmt-start t)) |
972579f9 | 2700 | |
4cc7e498 GM |
2701 | ;; no beginning found => don't change indentation |
2702 | (if (and (eq oldpoint (point)) | |
f70b58b0 JB |
2703 | (not nomove)) |
2704 | (ada-get-indent-nochange) | |
2705 | ||
2706 | (cond | |
2707 | ;; | |
2708 | ((and | |
2709 | ada-indent-to-open-paren | |
2710 | (ada-in-open-paren-p)) | |
2711 | (ada-get-indent-open-paren)) | |
2712 | ;; | |
2713 | ((looking-at "end\\>") | |
2714 | (ada-get-indent-end orgpoint)) | |
2715 | ;; | |
2716 | ((looking-at ada-loop-start-re) | |
2717 | (ada-get-indent-loop orgpoint)) | |
2718 | ;; | |
2719 | ((looking-at ada-subprog-start-re) | |
2720 | (ada-get-indent-subprog orgpoint)) | |
2721 | ;; | |
2722 | ((looking-at ada-block-start-re) | |
2723 | (ada-get-indent-block-start orgpoint)) | |
2724 | ;; | |
0b702bc1 SL |
2725 | ((looking-at ada-block-label-re) ; also variable declaration |
2726 | (ada-get-indent-block-label orgpoint)) | |
2727 | ;; | |
2728 | ((looking-at ada-goto-label-re) | |
2729 | (ada-get-indent-goto-label orgpoint)) | |
2730 | ;; | |
f70b58b0 JB |
2731 | ((looking-at "\\(sub\\)?type\\>") |
2732 | (ada-get-indent-type orgpoint)) | |
2733 | ;; | |
2734 | ;; "then" has to be included in the case of "select...then abort" | |
2735 | ;; statements, since (goto-stmt-start) at the beginning of | |
2736 | ;; the current function would leave the cursor on that position | |
2737 | ((looking-at "\\(\\(els\\)?if\\>\\)\\|then abort\\\>") | |
2738 | (ada-get-indent-if orgpoint)) | |
2739 | ;; | |
2740 | ((looking-at "case\\>") | |
2741 | (ada-get-indent-case orgpoint)) | |
2742 | ;; | |
2743 | ((looking-at "when\\>") | |
2744 | (ada-get-indent-when orgpoint)) | |
2745 | ;; | |
f70b58b0 JB |
2746 | ((looking-at "separate\\>") |
2747 | (ada-get-indent-nochange)) | |
4cc7e498 GM |
2748 | ;; |
2749 | ((looking-at "with\\>\\|use\\>") | |
2750 | ;; Are we still in that statement, or are we in fact looking at | |
2751 | ;; the previous one ? | |
2752 | (if (save-excursion (search-forward ";" oldpoint t)) | |
2753 | (list (progn (back-to-indentation) (point)) 0) | |
2754 | (list (point) (if (looking-at "with") | |
2755 | 'ada-with-indent | |
2756 | 'ada-use-indent)))) | |
2757 | ;; | |
f70b58b0 JB |
2758 | (t |
2759 | (ada-get-indent-noindent orgpoint))))) | |
4cc7e498 | 2760 | )) |
972579f9 | 2761 | |
655880d2 | 2762 | (defun ada-get-indent-open-paren () |
6d533a6e | 2763 | "Calculate the indentation when point is behind an unclosed parenthesis." |
7749c1a8 | 2764 | (list (ada-in-open-paren-p) 0)) |
972579f9 | 2765 | |
655880d2 GM |
2766 | (defun ada-get-indent-nochange () |
2767 | "Return the current indentation of the previous line." | |
972579f9 RS |
2768 | (save-excursion |
2769 | (forward-line -1) | |
655880d2 GM |
2770 | (back-to-indentation) |
2771 | (list (point) 0))) | |
972579f9 | 2772 | |
655880d2 | 2773 | (defun ada-get-indent-paramlist () |
6d533a6e | 2774 | "Calculate the indentation when point is inside a parameter list." |
972579f9 RS |
2775 | (save-excursion |
2776 | (ada-search-ignore-string-comment "[^ \t\n]" t nil t) | |
2777 | (cond | |
972579f9 | 2778 | ;; in front of the first parameter |
7749c1a8 | 2779 | ((= (char-after) ?\() |
972579f9 | 2780 | (goto-char (match-end 0)) |
7749c1a8 | 2781 | (list (point) 0)) |
655880d2 | 2782 | |
972579f9 | 2783 | ;; in front of another parameter |
7749c1a8 | 2784 | ((= (char-after) ?\;) |
972579f9 RS |
2785 | (goto-char (cdr (ada-search-ignore-string-comment "(\\|;" t nil t))) |
2786 | (ada-goto-next-non-ws) | |
7749c1a8 | 2787 | (list (point) 0)) |
655880d2 | 2788 | |
4607c7f4 SM |
2789 | ;; After an affectation (default parameter value in subprogram |
2790 | ;; declaration) | |
2791 | ((and (= (following-char) ?=) (= (preceding-char) ?:)) | |
2792 | (back-to-indentation) | |
2793 | (list (point) 'ada-broken-indent)) | |
2794 | ||
972579f9 | 2795 | ;; inside a parameter declaration |
972579f9 RS |
2796 | (t |
2797 | (goto-char (cdr (ada-search-ignore-string-comment "(\\|;" t nil t))) | |
2798 | (ada-goto-next-non-ws) | |
a97af989 | 2799 | (list (point) 'ada-broken-indent))))) |
972579f9 | 2800 | |
655880d2 | 2801 | (defun ada-get-indent-end (orgpoint) |
6d533a6e | 2802 | "Calculate the indentation when point is just before an end statement. |
655880d2 | 2803 | ORGPOINT is the limit position used in the calculation." |
972579f9 | 2804 | (let ((defun-name nil) |
f70b58b0 | 2805 | (indent nil)) |
4cc7e498 | 2806 | |
972579f9 | 2807 | ;; is the line already terminated by ';' ? |
972579f9 | 2808 | (if (save-excursion |
f70b58b0 JB |
2809 | (ada-search-ignore-string-comment ";" nil orgpoint nil |
2810 | 'search-forward)) | |
2811 | ||
2812 | ;; yes, look what's following 'end' | |
2813 | (progn | |
2814 | (forward-word 1) | |
2815 | (ada-goto-next-non-ws) | |
2816 | (cond | |
dd4fdc44 JB |
2817 | ;; |
2818 | ;; loop/select/if/case/return | |
2819 | ;; | |
2820 | ((looking-at "\\<\\(loop\\|select\\|if\\|case\\|return\\)\\>") | |
f70b58b0 JB |
2821 | (save-excursion (ada-check-matching-start (match-string 0))) |
2822 | (list (save-excursion (back-to-indentation) (point)) 0)) | |
2823 | ||
2824 | ;; | |
dd4fdc44 | 2825 | ;; record |
f70b58b0 JB |
2826 | ;; |
2827 | ((looking-at "\\<record\\>") | |
2828 | (save-excursion | |
2829 | (ada-check-matching-start (match-string 0)) | |
2830 | ;; we are now looking at the matching "record" statement | |
2831 | (forward-word 1) | |
2832 | (ada-goto-stmt-start) | |
2833 | ;; now on the matching type declaration, or use clause | |
2834 | (unless (looking-at "\\(for\\|type\\)\\>") | |
2835 | (ada-search-ignore-string-comment "\\<type\\>" t)) | |
2836 | (list (progn (back-to-indentation) (point)) 0))) | |
2837 | ;; | |
2838 | ;; a named block end | |
2839 | ;; | |
2840 | ((looking-at ada-ident-re) | |
2841 | (setq defun-name (match-string 0)) | |
2842 | (save-excursion | |
2843 | (ada-goto-matching-start 0) | |
2844 | (ada-check-defun-name defun-name)) | |
2845 | (list (progn (back-to-indentation) (point)) 0)) | |
2846 | ;; | |
2847 | ;; a block-end without name | |
2848 | ;; | |
2849 | ((= (char-after) ?\;) | |
2850 | (save-excursion | |
2851 | (ada-goto-matching-start 0) | |
2852 | (if (looking-at "\\<begin\\>") | |
2853 | (progn | |
2854 | (setq indent (list (point) 0)) | |
6a47c86a | 2855 | (if (ada-goto-decl-start t) |
f70b58b0 JB |
2856 | (list (progn (back-to-indentation) (point)) 0) |
2857 | indent)) | |
4607c7f4 SM |
2858 | (list (progn (back-to-indentation) (point)) 0) |
2859 | ))) | |
f70b58b0 JB |
2860 | ;; |
2861 | ;; anything else - should maybe signal an error ? | |
2862 | ;; | |
2863 | (t | |
2864 | (list (save-excursion (back-to-indentation) (point)) | |
2865 | 'ada-broken-indent)))) | |
972579f9 | 2866 | |
655880d2 | 2867 | (list (save-excursion (back-to-indentation) (point)) |
f70b58b0 | 2868 | 'ada-broken-indent)))) |
972579f9 RS |
2869 | |
2870 | (defun ada-get-indent-case (orgpoint) | |
6d533a6e | 2871 | "Calculate the indentation when point is just before a case statement. |
655880d2 | 2872 | ORGPOINT is the limit position used in the calculation." |
7749c1a8 | 2873 | (let ((match-cons nil) |
f70b58b0 | 2874 | (opos (point))) |
972579f9 RS |
2875 | (cond |
2876 | ;; | |
2877 | ;; case..is..when..=> | |
2878 | ;; | |
2879 | ((save-excursion | |
f70b58b0 JB |
2880 | (setq match-cons (and |
2881 | ;; the `=>' must be after the keyword `is'. | |
2882 | (ada-search-ignore-string-comment | |
2883 | "is" nil orgpoint nil 'word-search-forward) | |
2884 | (ada-search-ignore-string-comment | |
2885 | "[ \t\n]+=>" nil orgpoint)))) | |
972579f9 | 2886 | (save-excursion |
f70b58b0 JB |
2887 | (goto-char (car match-cons)) |
2888 | (unless (ada-search-ignore-string-comment "when" t opos) | |
2889 | (error "Missing 'when' between 'case' and '=>'")) | |
2890 | (list (save-excursion (back-to-indentation) (point)) 'ada-indent))) | |
972579f9 RS |
2891 | ;; |
2892 | ;; case..is..when | |
2893 | ;; | |
2894 | ((save-excursion | |
f70b58b0 JB |
2895 | (setq match-cons (ada-search-ignore-string-comment |
2896 | "when" nil orgpoint nil 'word-search-forward))) | |
972579f9 | 2897 | (goto-char (cdr match-cons)) |
7749c1a8 | 2898 | (list (save-excursion (back-to-indentation) (point)) 'ada-broken-indent)) |
972579f9 RS |
2899 | ;; |
2900 | ;; case..is | |
2901 | ;; | |
2902 | ((save-excursion | |
f70b58b0 JB |
2903 | (setq match-cons (ada-search-ignore-string-comment |
2904 | "is" nil orgpoint nil 'word-search-forward))) | |
7749c1a8 | 2905 | (list (save-excursion (back-to-indentation) (point)) 'ada-when-indent)) |
972579f9 RS |
2906 | ;; |
2907 | ;; incomplete case | |
2908 | ;; | |
2909 | (t | |
655880d2 | 2910 | (list (save-excursion (back-to-indentation) (point)) |
f70b58b0 | 2911 | 'ada-broken-indent))))) |
972579f9 RS |
2912 | |
2913 | (defun ada-get-indent-when (orgpoint) | |
6d533a6e | 2914 | "Calculate the indentation when point is just before a when statement. |
655880d2 | 2915 | ORGPOINT is the limit position used in the calculation." |
7749c1a8 | 2916 | (let ((cur-indent (save-excursion (back-to-indentation) (point)))) |
655880d2 | 2917 | (if (ada-search-ignore-string-comment "[ \t\n]*=>" nil orgpoint) |
f70b58b0 | 2918 | (list cur-indent 'ada-indent) |
7749c1a8 | 2919 | (list cur-indent 'ada-broken-indent)))) |
972579f9 | 2920 | |
972579f9 | 2921 | (defun ada-get-indent-if (orgpoint) |
6d533a6e | 2922 | "Calculate the indentation when point is just before an if statement. |
655880d2 | 2923 | ORGPOINT is the limit position used in the calculation." |
7749c1a8 | 2924 | (let ((cur-indent (save-excursion (back-to-indentation) (point))) |
f70b58b0 | 2925 | (match-cons nil)) |
972579f9 | 2926 | ;; |
7749c1a8 | 2927 | ;; Move to the correct then (ignore all "and then") |
972579f9 | 2928 | ;; |
36144b26 | 2929 | (while (and (setq match-cons (ada-search-ignore-string-comment |
f70b58b0 JB |
2930 | "\\<\\(then\\|and[ \t]*then\\)\\>" |
2931 | nil orgpoint)) | |
2932 | (= (downcase (char-after (car match-cons))) ?a))) | |
7749c1a8 GM |
2933 | ;; If "then" was found (we are looking at it) |
2934 | (if match-cons | |
f70b58b0 JB |
2935 | (progn |
2936 | ;; | |
2937 | ;; 'then' first in separate line ? | |
2938 | ;; => indent according to 'then', | |
2939 | ;; => else indent according to 'if' | |
2940 | ;; | |
2941 | (if (save-excursion | |
2942 | (back-to-indentation) | |
2943 | (looking-at "\\<then\\>")) | |
2944 | (setq cur-indent (save-excursion (back-to-indentation) (point)))) | |
2945 | ;; skip 'then' | |
2946 | (forward-word 1) | |
2947 | (list cur-indent 'ada-indent)) | |
972579f9 | 2948 | |
7749c1a8 | 2949 | (list cur-indent 'ada-broken-indent)))) |
972579f9 | 2950 | |
972579f9 | 2951 | (defun ada-get-indent-block-start (orgpoint) |
6d533a6e | 2952 | "Calculate the indentation when point is at the start of a block. |
655880d2 | 2953 | ORGPOINT is the limit position used in the calculation." |
7749c1a8 | 2954 | (let ((pos nil)) |
972579f9 RS |
2955 | (cond |
2956 | ((save-excursion | |
f70b58b0 JB |
2957 | (forward-word 1) |
2958 | (setq pos (ada-goto-next-non-ws orgpoint))) | |
972579f9 RS |
2959 | (goto-char pos) |
2960 | (save-excursion | |
f70b58b0 | 2961 | (ada-indent-on-previous-lines t orgpoint))) |
655880d2 | 2962 | |
4607c7f4 SM |
2963 | ;; Special case for record types, for instance for: |
2964 | ;; type A is (B : Integer; | |
2965 | ;; C : Integer) is record | |
2966 | ;; null; -- This is badly indented otherwise | |
2967 | ((looking-at "record") | |
2968 | ||
2969 | ;; If record is at the beginning of the line, indent from there | |
2970 | (if (save-excursion | |
2971 | (beginning-of-line) | |
2972 | (looking-at "^[ \t]*\\(record\\|limited record\\)")) | |
2973 | (list (save-excursion (back-to-indentation) (point)) 'ada-indent) | |
2974 | ||
2975 | ;; else indent relative to the type command | |
2976 | (list (save-excursion | |
2977 | (car (ada-search-ignore-string-comment "\\<type\\>" t))) | |
2978 | 'ada-indent))) | |
2979 | ||
0b702bc1 SL |
2980 | ;; Special case for label: |
2981 | ((looking-at ada-block-label-re) | |
2982 | (list (- (save-excursion (back-to-indentation) (point)) ada-label-indent) 'ada-indent)) | |
2983 | ||
972579f9 | 2984 | ;; nothing follows the block-start |
972579f9 | 2985 | (t |
7749c1a8 | 2986 | (list (save-excursion (back-to-indentation) (point)) 'ada-indent))))) |
972579f9 | 2987 | |
972579f9 | 2988 | (defun ada-get-indent-subprog (orgpoint) |
6d533a6e | 2989 | "Calculate the indentation when point is just before a subprogram. |
655880d2 | 2990 | ORGPOINT is the limit position used in the calculation." |
972579f9 | 2991 | (let ((match-cons nil) |
f70b58b0 JB |
2992 | (cur-indent (save-excursion (back-to-indentation) (point))) |
2993 | (foundis nil)) | |
972579f9 RS |
2994 | ;; |
2995 | ;; is there an 'is' in front of point ? | |
2996 | ;; | |
2997 | (if (save-excursion | |
f70b58b0 JB |
2998 | (setq match-cons |
2999 | (ada-search-ignore-string-comment | |
3000 | "\\<\\(is\\|do\\)\\>" nil orgpoint))) | |
3001 | ;; | |
3002 | ;; yes, then skip to its end | |
3003 | ;; | |
3004 | (progn | |
3005 | (setq foundis t) | |
3006 | (goto-char (cdr match-cons))) | |
972579f9 RS |
3007 | ;; |
3008 | ;; no, then goto next non-ws, if there is one in front of point | |
3009 | ;; | |
3010 | (progn | |
f70b58b0 JB |
3011 | (unless (ada-goto-next-non-ws orgpoint) |
3012 | (goto-char orgpoint)))) | |
972579f9 RS |
3013 | |
3014 | (cond | |
3015 | ;; | |
3016 | ;; nothing follows 'is' | |
3017 | ;; | |
3018 | ((and | |
3019 | foundis | |
3020 | (save-excursion | |
f70b58b0 JB |
3021 | (not (ada-search-ignore-string-comment |
3022 | "[^ \t\n]" nil orgpoint t)))) | |
7749c1a8 | 3023 | (list cur-indent 'ada-indent)) |
972579f9 RS |
3024 | ;; |
3025 | ;; is abstract/separate/new ... | |
3026 | ;; | |
3027 | ((and | |
3028 | foundis | |
3029 | (save-excursion | |
f70b58b0 JB |
3030 | (setq match-cons |
3031 | (ada-search-ignore-string-comment | |
3032 | "\\<\\(separate\\|new\\|abstract\\)\\>" | |
3033 | nil orgpoint)))) | |
972579f9 | 3034 | (goto-char (car match-cons)) |
276c1210 | 3035 | (ada-search-ignore-string-comment ada-subprog-start-re t) |
972579f9 RS |
3036 | (ada-get-indent-noindent orgpoint)) |
3037 | ;; | |
3038 | ;; something follows 'is' | |
3039 | ;; | |
3040 | ((and | |
3041 | foundis | |
36144b26 | 3042 | (save-excursion (setq match-cons (ada-goto-next-non-ws orgpoint))) |
7749c1a8 GM |
3043 | (goto-char match-cons) |
3044 | (ada-indent-on-previous-lines t orgpoint))) | |
972579f9 RS |
3045 | ;; |
3046 | ;; no 'is' but ';' | |
3047 | ;; | |
3048 | ((save-excursion | |
f70b58b0 | 3049 | (ada-search-ignore-string-comment ";" nil orgpoint nil 'search-forward)) |
7749c1a8 | 3050 | (list cur-indent 0)) |
972579f9 RS |
3051 | ;; |
3052 | ;; no 'is' or ';' | |
3053 | ;; | |
3054 | (t | |
7749c1a8 | 3055 | (list cur-indent 'ada-broken-indent))))) |
972579f9 | 3056 | |
972579f9 | 3057 | (defun ada-get-indent-noindent (orgpoint) |
6d533a6e | 3058 | "Calculate the indentation when point is just before a 'noindent stmt'. |
655880d2 | 3059 | ORGPOINT is the limit position used in the calculation." |
cadd3658 RS |
3060 | (let ((label 0)) |
3061 | (save-excursion | |
3062 | (beginning-of-line) | |
972579f9 | 3063 | |
7749c1a8 GM |
3064 | (cond |
3065 | ||
4cc7e498 | 3066 | ;; This one is called when indenting a line preceded by a multi-line |
7749c1a8 GM |
3067 | ;; subprogram declaration (in that case, we are at this point inside |
3068 | ;; the parameter declaration list) | |
3069 | ((ada-in-paramlist-p) | |
f70b58b0 JB |
3070 | (ada-previous-procedure) |
3071 | (list (save-excursion (back-to-indentation) (point)) 0)) | |
7749c1a8 | 3072 | |
655880d2 | 3073 | ;; This one is called when indenting the second line of a multi-line |
7749c1a8 GM |
3074 | ;; declaration section, in a declare block or a record declaration |
3075 | ((looking-at "[ \t]*\\(\\sw\\|_\\)*[ \t]*,[ \t]*$") | |
f70b58b0 JB |
3076 | (list (save-excursion (back-to-indentation) (point)) |
3077 | 'ada-broken-decl-indent)) | |
7749c1a8 | 3078 | |
0b702bc1 | 3079 | ;; This one is called in every other case when indenting a line at the |
7749c1a8 GM |
3080 | ;; top level |
3081 | (t | |
0b702bc1 | 3082 | (if (looking-at (concat "[ \t]*" ada-block-label-re)) |
f70b58b0 JB |
3083 | (setq label (- ada-label-indent)) |
3084 | ||
3085 | (let (p) | |
3086 | ||
3087 | ;; "with private" or "null record" cases | |
3088 | (if (or (save-excursion | |
3089 | (and (ada-search-ignore-string-comment "\\<private\\>" nil orgpoint) | |
3090 | (setq p (point)) | |
3091 | (save-excursion (forward-char -7);; skip back "private" | |
3092 | (ada-goto-previous-word) | |
3093 | (looking-at "with")))) | |
3094 | (save-excursion | |
3095 | (and (ada-search-ignore-string-comment "\\<record\\>" nil orgpoint) | |
3096 | (setq p (point)) | |
3097 | (save-excursion (forward-char -6);; skip back "record" | |
3098 | (ada-goto-previous-word) | |
3099 | (looking-at "null"))))) | |
3100 | (progn | |
3101 | (goto-char p) | |
3102 | (re-search-backward "\\<\\(type\\|subtype\\)\\>" nil t) | |
3103 | (list (save-excursion (back-to-indentation) (point)) 0))))) | |
3104 | (if (save-excursion | |
3105 | (ada-search-ignore-string-comment ";" nil orgpoint nil | |
3106 | 'search-forward)) | |
3107 | (list (+ (save-excursion (back-to-indentation) (point)) label) 0) | |
3108 | (list (+ (save-excursion (back-to-indentation) (point)) label) | |
3109 | 'ada-broken-indent))))))) | |
972579f9 | 3110 | |
0b702bc1 | 3111 | (defun ada-get-indent-block-label (orgpoint) |
6d533a6e | 3112 | "Calculate the indentation when before a label or variable declaration. |
655880d2 | 3113 | ORGPOINT is the limit position used in the calculation." |
972579f9 | 3114 | (let ((match-cons nil) |
f70b58b0 | 3115 | (cur-indent (save-excursion (back-to-indentation) (point)))) |
7749c1a8 | 3116 | (ada-search-ignore-string-comment ":" nil) |
972579f9 | 3117 | (cond |
972579f9 | 3118 | ;; loop label |
972579f9 | 3119 | ((save-excursion |
f70b58b0 JB |
3120 | (setq match-cons (ada-search-ignore-string-comment |
3121 | ada-loop-start-re nil orgpoint))) | |
972579f9 RS |
3122 | (goto-char (car match-cons)) |
3123 | (ada-get-indent-loop orgpoint)) | |
7749c1a8 | 3124 | |
972579f9 | 3125 | ;; declare label |
972579f9 | 3126 | ((save-excursion |
f70b58b0 JB |
3127 | (setq match-cons (ada-search-ignore-string-comment |
3128 | "\\<declare\\|begin\\>" nil orgpoint))) | |
7749c1a8 GM |
3129 | (goto-char (car match-cons)) |
3130 | (list (save-excursion (back-to-indentation) (point)) 'ada-indent)) | |
3131 | ||
3132 | ;; variable declaration | |
3133 | ((ada-in-decl-p) | |
3134 | (if (save-excursion | |
f70b58b0 JB |
3135 | (ada-search-ignore-string-comment ";" nil orgpoint)) |
3136 | (list cur-indent 0) | |
3137 | (list cur-indent 'ada-broken-indent))) | |
7749c1a8 | 3138 | |
972579f9 | 3139 | ;; nothing follows colon |
972579f9 | 3140 | (t |
7749c1a8 | 3141 | (list cur-indent '(- ada-label-indent)))))) |
972579f9 | 3142 | |
0b702bc1 SL |
3143 | (defun ada-get-indent-goto-label (orgpoint) |
3144 | "Calculate the indentation when at a goto label." | |
3145 | (search-forward ">>") | |
3146 | (ada-goto-next-non-ws) | |
3147 | (if (>= (point) orgpoint) | |
3148 | ;; labeled statement is the one we need to indent | |
3149 | (list (- (point) ada-label-indent)) | |
3150 | ;; else indentation is indent for labeled statement | |
3151 | (ada-indent-on-previous-lines t orgpoint))) | |
3152 | ||
972579f9 | 3153 | (defun ada-get-indent-loop (orgpoint) |
6d533a6e | 3154 | "Calculate the indentation when just before a loop or a for ... use. |
655880d2 | 3155 | ORGPOINT is the limit position used in the calculation." |
972579f9 | 3156 | (let ((match-cons nil) |
f70b58b0 | 3157 | (pos (point)) |
7749c1a8 | 3158 | |
f70b58b0 JB |
3159 | ;; If looking at a named block, skip the label |
3160 | (label (save-excursion | |
0b702bc1 SL |
3161 | (back-to-indentation) |
3162 | (if (looking-at ada-block-label-re) | |
f70b58b0 JB |
3163 | (- ada-label-indent) |
3164 | 0)))) | |
7749c1a8 | 3165 | |
972579f9 RS |
3166 | (cond |
3167 | ||
3168 | ;; | |
3169 | ;; statement complete | |
3170 | ;; | |
3171 | ((save-excursion | |
f70b58b0 JB |
3172 | (ada-search-ignore-string-comment ";" nil orgpoint nil |
3173 | 'search-forward)) | |
7749c1a8 | 3174 | (list (+ (save-excursion (back-to-indentation) (point)) label) 0)) |
972579f9 RS |
3175 | ;; |
3176 | ;; simple loop | |
3177 | ;; | |
3178 | ((looking-at "loop\\>") | |
36144b26 | 3179 | (setq pos (ada-get-indent-block-start orgpoint)) |
7749c1a8 | 3180 | (if (equal label 0) |
f70b58b0 | 3181 | pos |
a97af989 | 3182 | (list (+ (car pos) label) (cadr pos)))) |
972579f9 RS |
3183 | |
3184 | ;; | |
3185 | ;; 'for'- loop (or also a for ... use statement) | |
3186 | ;; | |
3187 | ((looking-at "for\\>") | |
3188 | (cond | |
3189 | ;; | |
3190 | ;; for ... use | |
3191 | ;; | |
3192 | ((save-excursion | |
f70b58b0 JB |
3193 | (and |
3194 | (goto-char (match-end 0)) | |
3195 | (ada-goto-next-non-ws orgpoint) | |
3196 | (forward-word 1) | |
3197 | (if (= (char-after) ?') (forward-word 1) t) | |
3198 | (ada-goto-next-non-ws orgpoint) | |
3199 | (looking-at "\\<use\\>") | |
3200 | ;; | |
3201 | ;; check if there is a 'record' before point | |
3202 | ;; | |
3203 | (progn | |
3204 | (setq match-cons (ada-search-ignore-string-comment | |
3205 | "record" nil orgpoint nil 'word-search-forward)) | |
3206 | t))) | |
3207 | (if match-cons | |
f7a80909 JB |
3208 | (progn |
3209 | (goto-char (car match-cons)) | |
3210 | (list (save-excursion (back-to-indentation) (point)) 'ada-indent)) | |
3211 | (list (save-excursion (back-to-indentation) (point)) 'ada-broken-indent)) | |
3212 | ) | |
3213 | ||
972579f9 RS |
3214 | ;; |
3215 | ;; for..loop | |
3216 | ;; | |
3217 | ((save-excursion | |
f70b58b0 JB |
3218 | (setq match-cons (ada-search-ignore-string-comment |
3219 | "loop" nil orgpoint nil 'word-search-forward))) | |
3220 | (goto-char (car match-cons)) | |
3221 | ;; | |
3222 | ;; indent according to 'loop', if it's first in the line; | |
3223 | ;; otherwise to 'for' | |
3224 | ;; | |
3225 | (unless (save-excursion | |
3226 | (back-to-indentation) | |
3227 | (looking-at "\\<loop\\>")) | |
3228 | (goto-char pos)) | |
3229 | (list (+ (save-excursion (back-to-indentation) (point)) label) | |
3230 | 'ada-indent)) | |
972579f9 RS |
3231 | ;; |
3232 | ;; for-statement is broken | |
3233 | ;; | |
3234 | (t | |
f70b58b0 JB |
3235 | (list (+ (save-excursion (back-to-indentation) (point)) label) |
3236 | 'ada-broken-indent)))) | |
972579f9 RS |
3237 | |
3238 | ;; | |
3239 | ;; 'while'-loop | |
3240 | ;; | |
3241 | ((looking-at "while\\>") | |
3242 | ;; | |
3243 | ;; while..loop ? | |
3244 | ;; | |
3245 | (if (save-excursion | |
f70b58b0 JB |
3246 | (setq match-cons (ada-search-ignore-string-comment |
3247 | "loop" nil orgpoint nil 'word-search-forward))) | |
3248 | ||
3249 | (progn | |
3250 | (goto-char (car match-cons)) | |
3251 | ;; | |
3252 | ;; indent according to 'loop', if it's first in the line; | |
3253 | ;; otherwise to 'while'. | |
3254 | ;; | |
3255 | (unless (save-excursion | |
3256 | (back-to-indentation) | |
3257 | (looking-at "\\<loop\\>")) | |
3258 | (goto-char pos)) | |
3259 | (list (+ (save-excursion (back-to-indentation) (point)) label) | |
3260 | 'ada-indent)) | |
3261 | ||
3262 | (list (+ (save-excursion (back-to-indentation) (point)) label) | |
3263 | 'ada-broken-indent)))))) | |
972579f9 RS |
3264 | |
3265 | (defun ada-get-indent-type (orgpoint) | |
6d533a6e | 3266 | "Calculate the indentation when before a type statement. |
655880d2 | 3267 | ORGPOINT is the limit position used in the calculation." |
972579f9 RS |
3268 | (let ((match-dat nil)) |
3269 | (cond | |
3270 | ;; | |
3271 | ;; complete record declaration | |
3272 | ;; | |
3273 | ((save-excursion | |
f70b58b0 JB |
3274 | (and |
3275 | (setq match-dat (ada-search-ignore-string-comment | |
3276 | "end" nil orgpoint nil 'word-search-forward)) | |
3277 | (ada-goto-next-non-ws) | |
3278 | (looking-at "\\<record\\>") | |
3279 | (forward-word 1) | |
3280 | (ada-goto-next-non-ws) | |
3281 | (= (char-after) ?\;))) | |
972579f9 | 3282 | (goto-char (car match-dat)) |
7749c1a8 | 3283 | (list (save-excursion (back-to-indentation) (point)) 0)) |
972579f9 RS |
3284 | ;; |
3285 | ;; record type | |
3286 | ;; | |
3287 | ((save-excursion | |
f70b58b0 JB |
3288 | (setq match-dat (ada-search-ignore-string-comment |
3289 | "record" nil orgpoint nil 'word-search-forward))) | |
972579f9 | 3290 | (goto-char (car match-dat)) |
7749c1a8 | 3291 | (list (save-excursion (back-to-indentation) (point)) 'ada-indent)) |
972579f9 RS |
3292 | ;; |
3293 | ;; complete type declaration | |
3294 | ;; | |
3295 | ((save-excursion | |
f70b58b0 JB |
3296 | (ada-search-ignore-string-comment ";" nil orgpoint nil |
3297 | 'search-forward)) | |
7749c1a8 | 3298 | (list (save-excursion (back-to-indentation) (point)) 0)) |
972579f9 | 3299 | ;; |
f139ce87 | 3300 | ;; "type ... is", but not "type ... is ...", which is broken |
972579f9 RS |
3301 | ;; |
3302 | ((save-excursion | |
f70b58b0 JB |
3303 | (and |
3304 | (ada-search-ignore-string-comment "is" nil orgpoint nil | |
3305 | 'word-search-forward) | |
3306 | (not (ada-goto-next-non-ws orgpoint)))) | |
7749c1a8 | 3307 | (list (save-excursion (back-to-indentation) (point)) 'ada-broken-indent)) |
972579f9 RS |
3308 | ;; |
3309 | ;; broken statement | |
3310 | ;; | |
3311 | (t | |
655880d2 | 3312 | (list (save-excursion (back-to-indentation) (point)) |
f70b58b0 | 3313 | 'ada-broken-indent))))) |
972579f9 RS |
3314 | |
3315 | \f | |
655880d2 GM |
3316 | ;; ----------------------------------------------------------- |
3317 | ;; -- searching and matching | |
3318 | ;; ----------------------------------------------------------- | |
3319 | ||
0b702bc1 | 3320 | (defun ada-goto-stmt-start (&optional ignore-goto-label) |
6d533a6e JB |
3321 | "Move point to the beginning of the statement that point is in or after. |
3322 | Return the new position of point. | |
655880d2 GM |
3323 | As a special case, if we are looking at a closing parenthesis, skip to the |
3324 | open parenthesis." | |
972579f9 | 3325 | (let ((match-dat nil) |
f70b58b0 | 3326 | (orgpoint (point))) |
972579f9 | 3327 | |
36144b26 | 3328 | (setq match-dat (ada-search-prev-end-stmt)) |
972579f9 | 3329 | (if match-dat |
eaae8106 | 3330 | |
4cc7e498 GM |
3331 | ;; |
3332 | ;; found a previous end-statement => check if anything follows | |
3333 | ;; | |
3334 | (unless (looking-at "declare") | |
3335 | (progn | |
3336 | (unless (save-excursion | |
3337 | (goto-char (cdr match-dat)) | |
0b702bc1 | 3338 | (ada-goto-next-non-ws orgpoint ignore-goto-label)) |
4cc7e498 GM |
3339 | ;; |
3340 | ;; nothing follows => it's the end-statement directly in | |
3341 | ;; front of point => search again | |
3342 | ;; | |
36144b26 | 3343 | (setq match-dat (ada-search-prev-end-stmt))) |
4cc7e498 GM |
3344 | ;; |
3345 | ;; if found the correct end-statement => goto next non-ws | |
3346 | ;; | |
3347 | (if match-dat | |
3348 | (goto-char (cdr match-dat))) | |
3349 | (ada-goto-next-non-ws) | |
3350 | )) | |
eaae8106 | 3351 | |
972579f9 RS |
3352 | ;; |
3353 | ;; no previous end-statement => we are at the beginning of the | |
3354 | ;; accessible part of the buffer | |
3355 | ;; | |
3356 | (progn | |
4cc7e498 GM |
3357 | (goto-char (point-min)) |
3358 | ;; | |
3359 | ;; skip to the very first statement, if there is one | |
0b702bc1 | 3360 | ;; |
4cc7e498 GM |
3361 | (unless (ada-goto-next-non-ws orgpoint) |
3362 | (goto-char orgpoint)))) | |
972579f9 RS |
3363 | (point))) |
3364 | ||
3365 | ||
655880d2 | 3366 | (defun ada-search-prev-end-stmt () |
6d533a6e JB |
3367 | "Move point to previous end statement. |
3368 | Return a cons cell whose car is the beginning and whose cdr | |
3369 | is the end of the match." | |
972579f9 | 3370 | (let ((match-dat nil) |
f70b58b0 | 3371 | (found nil)) |
7749c1a8 | 3372 | |
972579f9 | 3373 | ;; search until found or beginning-of-buffer |
972579f9 | 3374 | (while |
f70b58b0 JB |
3375 | (and |
3376 | (not found) | |
3377 | (setq match-dat (ada-search-ignore-string-comment | |
3378 | ada-end-stmt-re t))) | |
972579f9 RS |
3379 | |
3380 | (goto-char (car match-dat)) | |
7749c1a8 | 3381 | (unless (ada-in-open-paren-p) |
80d50f88 | 3382 | (cond |
a1506d29 | 3383 | |
80d50f88 SM |
3384 | ((and (looking-at |
3385 | "\\<\\(record\\|loop\\|select\\|else\\|then\\)\\>") | |
3386 | (save-excursion | |
3387 | (ada-goto-previous-word) | |
3388 | (looking-at "\\<\\(end\\|or\\|and\\)\\>[ \t]*[^;]"))) | |
3389 | (forward-word -1)) | |
3390 | ||
3391 | ((looking-at "is") | |
3392 | (setq found | |
f70b58b0 | 3393 | (and (save-excursion (ada-goto-previous-word) |
80d50f88 SM |
3394 | (ada-goto-previous-word) |
3395 | (not (looking-at "subtype"))) | |
a1506d29 | 3396 | |
f70b58b0 JB |
3397 | (save-excursion (goto-char (cdr match-dat)) |
3398 | (ada-goto-next-non-ws) | |
3399 | ;; words that can go after an 'is' | |
3400 | (not (looking-at | |
3401 | (eval-when-compile | |
3402 | (concat "\\<" | |
3403 | (regexp-opt | |
3404 | '("separate" "access" "array" | |
7fdb5d54 | 3405 | "private" "abstract" "new") t) |
f70b58b0 | 3406 | "\\>\\|(")))))))) |
a1506d29 | 3407 | |
7fdb5d54 JB |
3408 | ((looking-at "private") |
3409 | (save-excursion | |
3410 | (backward-word 1) | |
3411 | (setq found (not (looking-at "is"))))) | |
3412 | ||
80d50f88 SM |
3413 | (t |
3414 | (setq found t)) | |
f70b58b0 | 3415 | ))) |
972579f9 RS |
3416 | |
3417 | (if found | |
f70b58b0 | 3418 | match-dat |
972579f9 RS |
3419 | nil))) |
3420 | ||
0b702bc1 SL |
3421 | (defun ada-goto-next-non-ws (&optional limit skip-goto-label) |
3422 | "Skip to next non-whitespace character. | |
3423 | Skips spaces, newlines and comments, and possibly goto labels. | |
3424 | Return `point' if moved, nil if not. | |
655880d2 | 3425 | Stop the search at LIMIT. |
7749c1a8 GM |
3426 | Do not call this function from within a string." |
3427 | (unless limit | |
36144b26 | 3428 | (setq limit (point-max))) |
7749c1a8 | 3429 | (while (and (<= (point) limit) |
0b702bc1 SL |
3430 | (or (progn (forward-comment 10000) |
3431 | (if (and (not (eobp)) | |
3432 | (save-excursion (forward-char 1) | |
3433 | (ada-in-string-p))) | |
3434 | (progn (forward-sexp 1) t))) | |
3435 | (and skip-goto-label | |
3436 | (looking-at ada-goto-label-re) | |
3437 | (progn | |
3438 | (goto-char (match-end 0)) | |
3439 | t))))) | |
7749c1a8 GM |
3440 | (if (< (point) limit) |
3441 | (point) | |
3442 | nil) | |
3443 | ) | |
972579f9 RS |
3444 | |
3445 | ||
3446 | (defun ada-goto-stmt-end (&optional limit) | |
6d533a6e JB |
3447 | "Move point to the end of the statement that point is in or before. |
3448 | Return the new position of point or nil if not found. | |
655880d2 | 3449 | Stop the search at LIMIT." |
972579f9 RS |
3450 | (if (ada-search-ignore-string-comment ada-end-stmt-re nil limit) |
3451 | (point) | |
3452 | nil)) | |
3453 | ||
3454 | ||
cadd3658 | 3455 | (defun ada-goto-next-word (&optional backward) |
6d533a6e | 3456 | "Move point to the beginning of the next word of Ada code. |
655880d2 | 3457 | If BACKWARD is non-nil, jump to the beginning of the previous word. |
6d533a6e | 3458 | Return the new position of point or nil if not found." |
972579f9 | 3459 | (let ((match-cons nil) |
f70b58b0 JB |
3460 | (orgpoint (point)) |
3461 | (old-syntax (char-to-string (char-syntax ?_)))) | |
7749c1a8 GM |
3462 | (modify-syntax-entry ?_ "w") |
3463 | (unless backward | |
4cc7e498 | 3464 | (skip-syntax-forward "w")) |
36144b26 | 3465 | (if (setq match-cons |
0b702bc1 | 3466 | (ada-search-ignore-string-comment "\\w" backward nil t)) |
f70b58b0 JB |
3467 | ;; |
3468 | ;; move to the beginning of the word found | |
3469 | ;; | |
3470 | (progn | |
3471 | (goto-char (car match-cons)) | |
3472 | (skip-syntax-backward "w") | |
3473 | (point)) | |
972579f9 RS |
3474 | ;; |
3475 | ;; if not found, restore old position of point | |
3476 | ;; | |
7749c1a8 GM |
3477 | (goto-char orgpoint) |
3478 | 'nil) | |
3479 | (modify-syntax-entry ?_ old-syntax)) | |
3480 | ) | |
972579f9 RS |
3481 | |
3482 | ||
3483 | (defun ada-check-matching-start (keyword) | |
6d533a6e | 3484 | "Signal an error if matching block start is not KEYWORD. |
655880d2 | 3485 | Moves point to the matching block start." |
972579f9 | 3486 | (ada-goto-matching-start 0) |
7749c1a8 | 3487 | (unless (looking-at (concat "\\<" keyword "\\>")) |
6d533a6e | 3488 | (error "Matching start is not '%s'" keyword))) |
972579f9 RS |
3489 | |
3490 | ||
3491 | (defun ada-check-defun-name (defun-name) | |
6d533a6e JB |
3492 | "Check if the name of the matching defun really is DEFUN-NAME. |
3493 | Assumes point to be already positioned by `ada-goto-matching-start'. | |
655880d2 | 3494 | Moves point to the beginning of the declaration." |
972579f9 | 3495 | |
d5875b25 JB |
3496 | ;; named block without a `declare'; ada-goto-matching-start leaves |
3497 | ;; point at start of 'begin' for a block. | |
cadd3658 | 3498 | (if (save-excursion |
f70b58b0 JB |
3499 | (ada-goto-previous-word) |
3500 | (looking-at (concat "\\<" defun-name "\\> *:"))) | |
6a47c86a | 3501 | t ; name matches |
d5875b25 | 3502 | ;; else |
972579f9 | 3503 | ;; |
cadd3658 | 3504 | ;; 'accept' or 'package' ? |
972579f9 | 3505 | ;; |
4cc7e498 | 3506 | (unless (looking-at ada-subprog-start-re) |
6a47c86a | 3507 | (ada-goto-decl-start)) |
cadd3658 RS |
3508 | ;; |
3509 | ;; 'begin' of 'procedure'/'function'/'task' or 'declare' | |
3510 | ;; | |
3511 | (save-excursion | |
972579f9 | 3512 | ;; |
7fdb5d54 | 3513 | ;; a named 'declare'-block ? => jump to the label |
972579f9 | 3514 | ;; |
cadd3658 | 3515 | (if (looking-at "\\<declare\\>") |
d5875b25 JB |
3516 | (progn |
3517 | (forward-comment -1) | |
3518 | (backward-word 1)) | |
f70b58b0 JB |
3519 | ;; |
3520 | ;; no, => 'procedure'/'function'/'task'/'protected' | |
3521 | ;; | |
3522 | (progn | |
3523 | (forward-word 2) | |
3524 | (backward-word 1) | |
3525 | ;; | |
3526 | ;; skip 'body' 'type' | |
3527 | ;; | |
3528 | (if (looking-at "\\<\\(body\\|type\\)\\>") | |
3529 | (forward-word 1)) | |
3530 | (forward-sexp 1) | |
3531 | (backward-sexp 1))) | |
cadd3658 RS |
3532 | ;; |
3533 | ;; should be looking-at the correct name | |
3534 | ;; | |
7749c1a8 | 3535 | (unless (looking-at (concat "\\<" defun-name "\\>")) |
f70b58b0 JB |
3536 | (error "Matching defun has different name: %s" |
3537 | (buffer-substring (point) | |
3538 | (progn (forward-sexp 1) (point)))))))) | |
972579f9 | 3539 | |
6a47c86a SL |
3540 | (defun ada-goto-decl-start (&optional noerror) |
3541 | "Move point to the declaration start of the current construct. | |
3542 | If NOERROR is non-nil, return nil if no match was found; | |
3543 | otherwise throw error." | |
972579f9 | 3544 | (let ((nest-count 1) |
6a47c86a SL |
3545 | (regexp (eval-when-compile |
3546 | (concat "\\<" | |
3547 | (regexp-opt | |
3548 | '("is" "separate" "end" "declare" "if" "new" "begin" "generic" "when") t) | |
3549 | "\\>"))) | |
4607c7f4 SM |
3550 | |
3551 | ;; first should be set to t if we should stop at the first | |
3552 | ;; "begin" we encounter. | |
6a47c86a | 3553 | (first t) |
f70b58b0 | 3554 | (count-generic nil) |
6f9a2614 | 3555 | (stop-at-when nil) |
f70b58b0 | 3556 | ) |
7749c1a8 | 3557 | |
4cc7e498 GM |
3558 | ;; Ignore "when" most of the time, except if we are looking at the |
3559 | ;; beginning of a block (structure: case .. is | |
3560 | ;; when ... => | |
3561 | ;; begin ... | |
3562 | ;; exception ... ) | |
3563 | (if (looking-at "begin") | |
f70b58b0 | 3564 | (setq stop-at-when t)) |
4cc7e498 | 3565 | |
7749c1a8 | 3566 | (if (or |
f70b58b0 JB |
3567 | (looking-at "\\<\\(package\\|procedure\\|function\\)\\>") |
3568 | (save-excursion | |
3569 | (ada-search-ignore-string-comment | |
3570 | "\\<\\(package\\|procedure\\|function\\|generic\\)\\>" t) | |
3571 | (looking-at "generic"))) | |
3572 | (setq count-generic t)) | |
7749c1a8 | 3573 | |
972579f9 | 3574 | ;; search backward for interesting keywords |
972579f9 | 3575 | (while (and |
f70b58b0 | 3576 | (not (zerop nest-count)) |
6a47c86a | 3577 | (ada-search-ignore-string-comment regexp t)) |
972579f9 RS |
3578 | ;; |
3579 | ;; calculate nest-depth | |
3580 | ;; | |
3581 | (cond | |
3582 | ;; | |
3583 | ((looking-at "end") | |
f70b58b0 JB |
3584 | (ada-goto-matching-start 1 noerror) |
3585 | ||
3586 | ;; In some case, two begin..end block can follow each other closely, | |
3587 | ;; which we have to detect, as in | |
3588 | ;; procedure P is | |
3589 | ;; procedure Q is | |
3590 | ;; begin | |
3591 | ;; end; | |
3592 | ;; begin -- here we should go to procedure, not begin | |
3593 | ;; end | |
3594 | ||
3595 | (if (looking-at "begin") | |
3596 | (let ((loop-again t)) | |
3597 | (save-excursion | |
3598 | (while loop-again | |
3599 | ;; If begin was just there as the beginning of a block | |
3600 | ;; (with no declare) then do nothing, otherwise just | |
3601 | ;; register that we have to find the statement that | |
3602 | ;; required the begin | |
3603 | ||
3604 | (ada-search-ignore-string-comment | |
3605 | "\\<\\(declare\\|begin\\|end\\|procedure\\|function\\|task\\|package\\)\\>" | |
3606 | t) | |
3607 | ||
3608 | (if (looking-at "end") | |
4607c7f4 | 3609 | (ada-goto-matching-start 1 noerror t) |
4cc7e498 | 3610 | |
f70b58b0 JB |
3611 | (setq loop-again nil) |
3612 | (unless (looking-at "begin") | |
3613 | (setq nest-count (1+ nest-count)))) | |
3614 | )) | |
3615 | ))) | |
7749c1a8 GM |
3616 | ;; |
3617 | ((looking-at "generic") | |
f70b58b0 JB |
3618 | (if count-generic |
3619 | (progn | |
3620 | (setq first nil) | |
3621 | (setq nest-count (1- nest-count))))) | |
972579f9 | 3622 | ;; |
4cc7e498 GM |
3623 | ((looking-at "if") |
3624 | (save-excursion | |
3625 | (forward-word -1) | |
3626 | (unless (looking-at "\\<end[ \t\n]*if\\>") | |
3627 | (progn | |
36144b26 SM |
3628 | (setq nest-count (1- nest-count)) |
3629 | (setq first nil))))) | |
eaae8106 | 3630 | |
4cc7e498 GM |
3631 | ;; |
3632 | ((looking-at "declare\\|generic") | |
f70b58b0 JB |
3633 | (setq nest-count (1- nest-count)) |
3634 | (setq first t)) | |
972579f9 RS |
3635 | ;; |
3636 | ((looking-at "is") | |
6a47c86a SL |
3637 | ;; look for things to ignore |
3638 | (if | |
3639 | (or | |
3640 | ;; generic formal parameter | |
3641 | (looking-at "is[ t]+<>") | |
3642 | ||
3643 | ;; A type definition, or a case statement. Note that the | |
3644 | ;; goto-matching-start above on 'end record' leaves us at | |
3645 | ;; 'record', not at 'type'. | |
3646 | ;; | |
3647 | ;; We get to a case statement here by calling | |
3648 | ;; 'ada-move-to-end' from inside a case statement; then | |
3649 | ;; we are not ignoring 'when'. | |
3650 | (save-excursion | |
3651 | ;; Skip type discriminants or case argument function call param list | |
3652 | (forward-comment -10000) | |
3653 | (forward-char -1) | |
3654 | (if (= (char-after) ?\)) | |
3655 | (progn | |
3656 | (forward-char 1) | |
3657 | (backward-sexp 1) | |
3658 | (forward-comment -10000) | |
3659 | )) | |
3660 | ;; skip type or case argument name | |
3661 | (skip-chars-backward "a-zA-Z0-9_.'") | |
3662 | (ada-goto-previous-word) | |
3663 | (and | |
3664 | ;; if it's a protected type, it's the decl start we | |
3665 | ;; are looking for; since we didn't see the 'end' | |
3666 | ;; above, we are inside it. | |
3667 | (looking-at "\\<\\(sub\\)?type\\|case\\>") | |
f70b58b0 JB |
3668 | (save-match-data |
3669 | (ada-goto-previous-word) | |
3670 | (not (looking-at "\\<protected\\>")))) | |
6a47c86a SL |
3671 | ) ; end of type definition p |
3672 | ||
3673 | ;; null procedure declaration | |
3674 | (save-excursion (ada-goto-next-word) (looking-at "\\<null\\>")) | |
3675 | );; end or | |
3676 | ;; skip this construct | |
3677 | nil | |
3678 | ;; this is the right "is" | |
3679 | (setq nest-count (1- nest-count)) | |
3680 | (setq first nil))) | |
972579f9 RS |
3681 | |
3682 | ;; | |
3683 | ((looking-at "new") | |
f70b58b0 JB |
3684 | (if (save-excursion |
3685 | (ada-goto-previous-word) | |
3686 | (looking-at "is")) | |
3687 | (goto-char (match-beginning 0)))) | |
972579f9 RS |
3688 | ;; |
3689 | ((and first | |
f70b58b0 JB |
3690 | (looking-at "begin")) |
3691 | (setq nest-count 0)) | |
4cc7e498 GM |
3692 | ;; |
3693 | ((looking-at "when") | |
4607c7f4 SM |
3694 | (save-excursion |
3695 | (forward-word -1) | |
3696 | (unless (looking-at "\\<exit[ \t\n]*when\\>") | |
3697 | (progn | |
3698 | (if stop-at-when | |
3699 | (setq nest-count (1- nest-count))) | |
f7a80909 | 3700 | )))) |
4607c7f4 SM |
3701 | ;; |
3702 | ((looking-at "begin") | |
3703 | (setq first nil)) | |
972579f9 RS |
3704 | ;; |
3705 | (t | |
f70b58b0 JB |
3706 | (setq nest-count (1+ nest-count)) |
3707 | (setq first nil))) | |
972579f9 | 3708 | |
7749c1a8 | 3709 | );; end of loop |
972579f9 RS |
3710 | |
3711 | ;; check if declaration-start is really found | |
7749c1a8 | 3712 | (if (and |
f70b58b0 JB |
3713 | (zerop nest-count) |
3714 | (if (looking-at "is") | |
3715 | (ada-search-ignore-string-comment ada-subprog-start-re t) | |
3716 | (looking-at "declare\\|generic"))) | |
3717 | t | |
7749c1a8 | 3718 | (if noerror nil |
f70b58b0 | 3719 | (error "No matching proc/func/task/declare/package/protected"))) |
7749c1a8 | 3720 | )) |
972579f9 RS |
3721 | |
3722 | (defun ada-goto-matching-start (&optional nest-level noerror gotothen) | |
6d533a6e JB |
3723 | "Move point to the beginning of a block-start. |
3724 | Which block depends on the value of NEST-LEVEL, which defaults to zero. | |
3725 | If NOERROR is non-nil, it only returns nil if no matching start was found. | |
655880d2 | 3726 | If GOTOTHEN is non-nil, point moves to the 'then' following 'if'." |
972579f9 | 3727 | (let ((nest-count (if nest-level nest-level 0)) |
f70b58b0 | 3728 | (found nil) |
7fdb5d54 JB |
3729 | |
3730 | (last-was-begin '()) | |
3731 | ;; List all keywords encountered while traversing | |
3732 | ;; something like '("end" "end" "begin") | |
3733 | ;; This is removed from the list when "package", "procedure",... | |
3734 | ;; are seen. The goal is to find whether a package has an elaboration | |
3735 | ;; part | |
3736 | ||
f70b58b0 | 3737 | (pos nil)) |
972579f9 | 3738 | |
972579f9 | 3739 | ;; search backward for interesting keywords |
972579f9 | 3740 | (while (and |
f70b58b0 JB |
3741 | (not found) |
3742 | (ada-search-ignore-string-comment ada-matching-start-re t)) | |
7749c1a8 GM |
3743 | |
3744 | (unless (and (looking-at "\\<record\\>") | |
f70b58b0 JB |
3745 | (save-excursion |
3746 | (forward-word -1) | |
3747 | (looking-at "\\<null\\>"))) | |
3748 | (progn | |
3749 | ;; calculate nest-depth | |
3750 | (cond | |
3751 | ;; found block end => increase nest depth | |
3752 | ((looking-at "end") | |
7fdb5d54 | 3753 | (push nil last-was-begin) |
f70b58b0 JB |
3754 | (setq nest-count (1+ nest-count))) |
3755 | ||
3756 | ;; found loop/select/record/case/if => check if it starts or | |
3757 | ;; ends a block | |
3758 | ((looking-at "loop\\|select\\|record\\|case\\|if") | |
3759 | (setq pos (point)) | |
3760 | (save-excursion | |
3761 | ;; check if keyword follows 'end' | |
3762 | (ada-goto-previous-word) | |
3763 | (if (looking-at "\\<end\\>[ \t]*[^;]") | |
7fdb5d54 JB |
3764 | (progn |
3765 | ;; it ends a block => increase nest depth | |
3766 | (setq nest-count (1+ nest-count) | |
3767 | pos (point)) | |
3768 | (push nil last-was-begin)) | |
a1506d29 | 3769 | |
f70b58b0 | 3770 | ;; it starts a block => decrease nest depth |
7fdb5d54 JB |
3771 | (setq nest-count (1- nest-count)) |
3772 | ||
3773 | ;; Some nested "begin .. end" blocks with no "declare"? | |
3774 | ;; => remove those entries | |
3775 | (while (car last-was-begin) | |
3776 | (setq last-was-begin (cdr (cdr last-was-begin)))) | |
3777 | ||
3778 | (setq last-was-begin (cdr last-was-begin)) | |
3779 | )) | |
3780 | (goto-char pos) | |
3781 | ) | |
f70b58b0 JB |
3782 | |
3783 | ;; found package start => check if it really is a block | |
3784 | ((looking-at "package") | |
3785 | (save-excursion | |
3786 | ;; ignore if this is just a renames statement | |
3787 | (let ((current (point)) | |
3788 | (pos (ada-search-ignore-string-comment | |
3789 | "\\<\\(is\\|renames\\|;\\)\\>" nil))) | |
3790 | (if pos | |
3791 | (goto-char (car pos)) | |
3792 | (error (concat | |
3793 | "No matching 'is' or 'renames' for 'package' at" | |
3794 | " line " | |
3795 | (number-to-string (count-lines 1 (1+ current))))))) | |
3796 | (unless (looking-at "renames") | |
3797 | (progn | |
3798 | (forward-word 1) | |
3799 | (ada-goto-next-non-ws) | |
3800 | ;; ignore it if it is only a declaration with 'new' | |
4607c7f4 SM |
3801 | ;; We could have package Foo is new .... |
3802 | ;; or package Foo is separate; | |
3803 | ;; or package Foo is begin null; end Foo | |
3804 | ;; for elaboration code (elaboration) | |
7fdb5d54 JB |
3805 | (if (and (not (looking-at "\\<\\(new\\|separate\\|begin\\)\\>")) |
3806 | (not (car last-was-begin))) | |
3807 | (setq nest-count (1- nest-count)))))) | |
3808 | ||
3809 | (setq last-was-begin (cdr last-was-begin)) | |
3810 | ) | |
f70b58b0 JB |
3811 | ;; found task start => check if it has a body |
3812 | ((looking-at "task") | |
3813 | (save-excursion | |
3814 | (forward-word 1) | |
3815 | (ada-goto-next-non-ws) | |
3816 | (cond | |
3817 | ((looking-at "\\<body\\>")) | |
3818 | ((looking-at "\\<type\\>") | |
3819 | ;; In that case, do nothing if there is a "is" | |
3820 | (forward-word 2);; skip "type" | |
3821 | (ada-goto-next-non-ws);; skip type name | |
3822 | ||
3823 | ;; Do nothing if we are simply looking at a simple | |
3824 | ;; "task type name;" statement with no block | |
3825 | (unless (looking-at ";") | |
3826 | (progn | |
3827 | ;; Skip the parameters | |
3828 | (if (looking-at "(") | |
3829 | (ada-search-ignore-string-comment ")" nil)) | |
3830 | (let ((tmp (ada-search-ignore-string-comment | |
3831 | "\\<\\(is\\|;\\)\\>" nil))) | |
3832 | (if tmp | |
3833 | (progn | |
3834 | (goto-char (car tmp)) | |
3835 | (if (looking-at "is") | |
3836 | (setq nest-count (1- nest-count))))))))) | |
3837 | (t | |
3838 | ;; Check if that task declaration had a block attached to | |
3839 | ;; it (i.e do nothing if we have just "task name;") | |
3840 | (unless (progn (forward-word 1) | |
3841 | (looking-at "[ \t]*;")) | |
7fdb5d54 JB |
3842 | (setq nest-count (1- nest-count)))))) |
3843 | (setq last-was-begin (cdr last-was-begin)) | |
3844 | ) | |
3845 | ||
3846 | ((looking-at "declare") | |
3847 | ;; remove entry for begin and end (include nested begin..end | |
3848 | ;; groups) | |
3849 | (setq last-was-begin (cdr last-was-begin)) | |
3850 | (let ((count 1)) | |
3851 | (while (and (> count 0)) | |
3852 | (if (equal (car last-was-begin) t) | |
3853 | (setq count (1+ count)) | |
3854 | (setq count (1- count))) | |
3855 | (setq last-was-begin (cdr last-was-begin)) | |
3856 | ))) | |
3857 | ||
3858 | ((looking-at "protected") | |
3859 | ;; Ignore if this is just a declaration | |
3860 | (save-excursion | |
3861 | (let ((pos (ada-search-ignore-string-comment | |
3862 | "\\(\\<is\\>\\|\\<renames\\>\\|;\\)" nil))) | |
3863 | (if pos | |
3864 | (goto-char (car pos))) | |
3865 | (if (looking-at "is") | |
3866 | ;; remove entry for end | |
3867 | (setq last-was-begin (cdr last-was-begin))))) | |
3868 | (setq nest-count (1- nest-count))) | |
3869 | ||
3870 | ((or (looking-at "procedure") | |
3871 | (looking-at "function")) | |
3872 | ;; Ignore if this is just a declaration | |
3873 | (save-excursion | |
3874 | (let ((pos (ada-search-ignore-string-comment | |
3875 | "\\(\\<is\\>\\|\\<renames\\>\\|)[ \t]*;\\)" nil))) | |
3876 | (if pos | |
3877 | (goto-char (car pos))) | |
3878 | (if (looking-at "is") | |
3879 | ;; remove entry for begin and end | |
3880 | (setq last-was-begin (cdr (cdr last-was-begin)))))) | |
3881 | ) | |
3882 | ||
f70b58b0 JB |
3883 | ;; all the other block starts |
3884 | (t | |
7fdb5d54 JB |
3885 | (push (looking-at "begin") last-was-begin) |
3886 | (setq nest-count (1- nest-count))) | |
3887 | ||
3888 | ) | |
f70b58b0 JB |
3889 | |
3890 | ;; match is found, if nest-depth is zero | |
3891 | (setq found (zerop nest-count))))) ; end of loop | |
972579f9 | 3892 | |
4607c7f4 SM |
3893 | (if (bobp) |
3894 | (point) | |
3895 | (if found | |
3896 | ;; | |
3897 | ;; match found => is there anything else to do ? | |
3898 | ;; | |
3899 | (progn | |
3900 | (cond | |
3901 | ;; | |
3902 | ;; found 'if' => skip to 'then', if it's on a separate line | |
3903 | ;; and GOTOTHEN is non-nil | |
3904 | ;; | |
3905 | ((and | |
3906 | gotothen | |
3907 | (looking-at "if") | |
3908 | (save-excursion | |
3909 | (ada-search-ignore-string-comment "then" nil nil nil | |
3910 | 'word-search-forward) | |
3911 | (back-to-indentation) | |
3912 | (looking-at "\\<then\\>"))) | |
3913 | (goto-char (match-beginning 0))) | |
a1506d29 | 3914 | |
4607c7f4 | 3915 | ;; |
dd4fdc44 | 3916 | ;; found 'do' => skip back to 'accept' or 'return' |
4607c7f4 SM |
3917 | ;; |
3918 | ((looking-at "do") | |
3919 | (unless (ada-search-ignore-string-comment | |
dd4fdc44 JB |
3920 | "\\<accept\\|return\\>" t) |
3921 | (error "Missing 'accept' or 'return' in front of 'do'")))) | |
4607c7f4 | 3922 | (point)) |
a1506d29 | 3923 | |
4607c7f4 SM |
3924 | (if noerror |
3925 | nil | |
6d533a6e | 3926 | (error "No matching start")))))) |
972579f9 RS |
3927 | |
3928 | ||
3929 | (defun ada-goto-matching-end (&optional nest-level noerror) | |
6d533a6e | 3930 | "Move point to the end of a block. |
655880d2 | 3931 | Which block depends on the value of NEST-LEVEL, which defaults to zero. |
97a62f83 | 3932 | If NOERROR is non-nil, it only returns nil if no matching start found." |
4607c7f4 SM |
3933 | (let ((nest-count (or nest-level 0)) |
3934 | (regex (eval-when-compile | |
3935 | (concat "\\<" | |
3936 | (regexp-opt '("end" "loop" "select" "begin" "case" | |
3937 | "if" "task" "package" "record" "do" | |
3938 | "procedure" "function") t) | |
3939 | "\\>"))) | |
f7a80909 | 3940 | found |
f70b58b0 | 3941 | pos |
4607c7f4 SM |
3942 | |
3943 | ;; First is used for subprograms: they are generally handled | |
3944 | ;; recursively, but of course we do not want to do that the | |
3945 | ;; first time (see comment below about subprograms) | |
3946 | (first (not (looking-at "declare")))) | |
3947 | ||
3948 | ;; If we are already looking at one of the keywords, this shouldn't count | |
3949 | ;; in the nesting loop below, so we just make sure we don't count it. | |
3950 | ;; "declare" is a special case because we need to look after the "begin" | |
3951 | ;; keyword | |
f7a80909 | 3952 | (if (looking-at "\\<if\\|loop\\|case\\|begin\\>") |
4607c7f4 | 3953 | (forward-char 1)) |
972579f9 RS |
3954 | |
3955 | ;; | |
3956 | ;; search forward for interesting keywords | |
3957 | ;; | |
3958 | (while (and | |
f70b58b0 JB |
3959 | (not found) |
3960 | (ada-search-ignore-string-comment regex nil)) | |
972579f9 RS |
3961 | |
3962 | ;; | |
3963 | ;; calculate nest-depth | |
3964 | ;; | |
3965 | (backward-word 1) | |
3966 | (cond | |
4607c7f4 SM |
3967 | ;; procedures and functions need to be processed recursively, in |
3968 | ;; case they are defined in a declare/begin block, as in: | |
3969 | ;; declare -- NL 0 (nested level) | |
3970 | ;; A : Boolean; | |
3971 | ;; procedure B (C : D) is | |
3972 | ;; begin -- NL 1 | |
3973 | ;; null; | |
3974 | ;; end B; -- NL 0, and we would exit | |
3975 | ;; begin | |
3976 | ;; end; -- we should exit here | |
3977 | ;; processing them recursively avoids the need for any special | |
3978 | ;; handling. | |
3979 | ;; Nothing should be done if we have only the specs or a | |
3980 | ;; generic instantion. | |
a1506d29 | 3981 | |
4607c7f4 SM |
3982 | ((and (looking-at "\\<procedure\\|function\\>")) |
3983 | (if first | |
3984 | (forward-word 1) | |
f7a80909 JB |
3985 | |
3986 | (setq pos (point)) | |
4607c7f4 | 3987 | (ada-search-ignore-string-comment "is\\|;") |
f7a80909 JB |
3988 | (if (= (char-before) ?s) |
3989 | (progn | |
3990 | (ada-goto-next-non-ws) | |
3991 | (unless (looking-at "\\<new\\>") | |
3992 | (progn | |
3993 | (goto-char pos) | |
3994 | (ada-goto-matching-end 0 t))))))) | |
a1506d29 | 3995 | |
972579f9 RS |
3996 | ;; found block end => decrease nest depth |
3997 | ((looking-at "\\<end\\>") | |
f70b58b0 | 3998 | (setq nest-count (1- nest-count) |
4607c7f4 | 3999 | found (<= nest-count 0)) |
f70b58b0 | 4000 | ;; skip the following keyword |
4607c7f4 SM |
4001 | (if (progn |
4002 | (skip-chars-forward "end") | |
4003 | (ada-goto-next-non-ws) | |
4004 | (looking-at "\\<\\(loop\\|select\\|record\\|case\\|if\\)\\>")) | |
4005 | (forward-word 1))) | |
a1506d29 | 4006 | |
4607c7f4 SM |
4007 | ;; found package start => check if it really starts a block, and is not |
4008 | ;; in fact a generic instantiation for instance | |
972579f9 | 4009 | ((looking-at "\\<package\\>") |
f70b58b0 JB |
4010 | (ada-search-ignore-string-comment "is" nil nil nil |
4011 | 'word-search-forward) | |
4012 | (ada-goto-next-non-ws) | |
4013 | ;; ignore and skip it if it is only a 'new' package | |
4014 | (if (looking-at "\\<new\\>") | |
4015 | (goto-char (match-end 0)) | |
4016 | (setq nest-count (1+ nest-count) | |
4607c7f4 | 4017 | found (<= nest-count 0)))) |
a1506d29 | 4018 | |
972579f9 RS |
4019 | ;; all the other block starts |
4020 | (t | |
f7a80909 JB |
4021 | (if (not first) |
4022 | (setq nest-count (1+ nest-count))) | |
4023 | (setq found (<= nest-count 0)) | |
f70b58b0 | 4024 | (forward-word 1))) ; end of 'cond' |
972579f9 | 4025 | |
4607c7f4 | 4026 | (setq first nil)) |
972579f9 | 4027 | |
7749c1a8 | 4028 | (if found |
f70b58b0 | 4029 | t |
7749c1a8 | 4030 | (if noerror |
f70b58b0 JB |
4031 | nil |
4032 | (error "No matching end"))) | |
7749c1a8 | 4033 | )) |
972579f9 RS |
4034 | |
4035 | ||
4036 | (defun ada-search-ignore-string-comment | |
4cc7e498 | 4037 | (search-re &optional backward limit paramlists search-func) |
655880d2 | 4038 | "Regexp-search for SEARCH-RE, ignoring comments, strings. |
f70b58b0 JB |
4039 | Returns a cons cell of begin and end of match data or nil, if not found. |
4040 | If BACKWARD is non-nil, search backward; search forward otherwise. | |
655880d2 | 4041 | The search stops at pos LIMIT. |
f70b58b0 | 4042 | If PARAMLISTS is nil, ignore parameter lists. |
23b747d1 | 4043 | The search is done using SEARCH-FUNC. SEARCH-FUNC can be optimized |
f70b58b0 | 4044 | in case we are searching for a constant string. |
6d533a6e | 4045 | Point is moved at the beginning of the SEARCH-RE." |
7749c1a8 | 4046 | (let (found |
f70b58b0 JB |
4047 | begin |
4048 | end | |
4049 | parse-result | |
4050 | (previous-syntax-table (syntax-table))) | |
7749c1a8 | 4051 | |
f70b58b0 | 4052 | ;; FIXME: need to pass BACKWARD to search-func! |
7749c1a8 | 4053 | (unless search-func |
36144b26 | 4054 | (setq search-func (if backward 're-search-backward 're-search-forward))) |
972579f9 RS |
4055 | |
4056 | ;; | |
4057 | ;; search until found or end-of-buffer | |
7749c1a8 | 4058 | ;; We have to test that we do not look further than limit |
972579f9 | 4059 | ;; |
7749c1a8 | 4060 | (set-syntax-table ada-mode-symbol-syntax-table) |
972579f9 | 4061 | (while (and (not found) |
f70b58b0 JB |
4062 | (or (not limit) |
4063 | (or (and backward (<= limit (point))) | |
4064 | (>= limit (point)))) | |
4065 | (funcall search-func search-re limit 1)) | |
36144b26 SM |
4066 | (setq begin (match-beginning 0)) |
4067 | (setq end (match-end 0)) | |
7749c1a8 | 4068 | |
36144b26 | 4069 | (setq parse-result (parse-partial-sexp |
f70b58b0 JB |
4070 | (save-excursion (beginning-of-line) (point)) |
4071 | (point))) | |
972579f9 RS |
4072 | |
4073 | (cond | |
4074 | ;; | |
7749c1a8 | 4075 | ;; If inside a string, skip it (and the following comments) |
972579f9 | 4076 | ;; |
7749c1a8 | 4077 | ((ada-in-string-p parse-result) |
f70b58b0 JB |
4078 | (if (featurep 'xemacs) |
4079 | (search-backward "\"" nil t) | |
4080 | (goto-char (nth 8 parse-result))) | |
4081 | (unless backward (forward-sexp 1))) | |
972579f9 | 4082 | ;; |
7749c1a8 GM |
4083 | ;; If inside a comment, skip it (and the following comments) |
4084 | ;; There is a special code for comments at the end of the file | |
972579f9 | 4085 | ;; |
7749c1a8 | 4086 | ((ada-in-comment-p parse-result) |
f70b58b0 JB |
4087 | (if (featurep 'xemacs) |
4088 | (progn | |
4089 | (forward-line 1) | |
4090 | (beginning-of-line) | |
4091 | (forward-comment -1)) | |
4092 | (goto-char (nth 8 parse-result))) | |
4093 | (unless backward | |
4094 | ;; at the end of the file, it is not possible to skip a comment | |
4095 | ;; so we just go at the end of the line | |
4096 | (if (forward-comment 1) | |
4097 | (progn | |
4098 | (forward-comment 1000) | |
4099 | (beginning-of-line)) | |
4100 | (end-of-line)))) | |
972579f9 | 4101 | ;; |
7749c1a8 | 4102 | ;; directly in front of a comment => skip it, if searching forward |
972579f9 | 4103 | ;; |
7749c1a8 | 4104 | ((and (= (char-after begin) ?-) (= (char-after (1+ begin)) ?-)) |
f70b58b0 | 4105 | (unless backward (progn (forward-char -1) (forward-comment 1000)))) |
7749c1a8 | 4106 | |
972579f9 RS |
4107 | ;; |
4108 | ;; found a parameter-list but should ignore it => skip it | |
4109 | ;; | |
7749c1a8 | 4110 | ((and (not paramlists) (ada-in-paramlist-p)) |
f70b58b0 JB |
4111 | (if backward |
4112 | (search-backward "(" nil t) | |
4113 | (search-forward ")" nil t))) | |
972579f9 RS |
4114 | ;; |
4115 | ;; found what we were looking for | |
4116 | ;; | |
4117 | (t | |
f70b58b0 | 4118 | (setq found t)))) ; end of loop |
972579f9 | 4119 | |
7749c1a8 | 4120 | (set-syntax-table previous-syntax-table) |
972579f9 RS |
4121 | |
4122 | (if found | |
f70b58b0 | 4123 | (cons begin end) |
972579f9 RS |
4124 | nil))) |
4125 | ||
655880d2 GM |
4126 | ;; ------------------------------------------------------- |
4127 | ;; -- Testing the position of the cursor | |
4128 | ;; ------------------------------------------------------- | |
972579f9 RS |
4129 | |
4130 | (defun ada-in-decl-p () | |
6d533a6e | 4131 | "Return t if point is inside a declarative part. |
655880d2 GM |
4132 | Assumes point to be at the end of a statement." |
4133 | (or (ada-in-paramlist-p) | |
4134 | (save-excursion | |
6a47c86a | 4135 | (ada-goto-decl-start t)))) |
972579f9 RS |
4136 | |
4137 | ||
4138 | (defun ada-looking-at-semi-or () | |
6d533a6e | 4139 | "Return t if looking at an 'or' following a semicolon." |
972579f9 RS |
4140 | (save-excursion |
4141 | (and (looking-at "\\<or\\>") | |
f70b58b0 JB |
4142 | (progn |
4143 | (forward-word 1) | |
4144 | (ada-goto-stmt-start) | |
4145 | (looking-at "\\<or\\>"))))) | |
972579f9 RS |
4146 | |
4147 | ||
4148 | (defun ada-looking-at-semi-private () | |
6d533a6e | 4149 | "Return t if looking at the start of a private section in a package. |
97a62f83 | 4150 | Return nil if the private is part of the package name, as in |
655880d2 | 4151 | 'private package A is...' (this can only happen at top level)." |
972579f9 RS |
4152 | (save-excursion |
4153 | (and (looking-at "\\<private\\>") | |
f70b58b0 | 4154 | (not (looking-at "\\<private[ \t]*\\(package\\|generic\\)")) |
7749c1a8 | 4155 | |
4cc7e498 GM |
4156 | ;; Make sure this is the start of a private section (ie after |
4157 | ;; a semicolon or just after the package declaration, but not | |
4158 | ;; after a 'type ... is private' or 'is new ... with private' | |
4607c7f4 SM |
4159 | ;; |
4160 | ;; Note that a 'private' statement at the beginning of the buffer | |
4161 | ;; does not indicate a private section, since this is instead a | |
4162 | ;; 'private procedure ...' | |
eaae8106 | 4163 | (progn (forward-comment -1000) |
4607c7f4 SM |
4164 | (and (not (bobp)) |
4165 | (or (= (char-before) ?\;) | |
4166 | (and (forward-word -3) | |
4167 | (looking-at "\\<package\\>")))))))) | |
7749c1a8 | 4168 | |
972579f9 RS |
4169 | |
4170 | (defun ada-in-paramlist-p () | |
b06a3bb5 | 4171 | "Return t if point is inside the parameter-list of a declaration, but not a subprogram call or aggregate." |
972579f9 RS |
4172 | (save-excursion |
4173 | (and | |
4cc7e498 | 4174 | (ada-search-ignore-string-comment "(\\|)" t nil t) |
972579f9 | 4175 | ;; inside parentheses ? |
7749c1a8 | 4176 | (= (char-after) ?\() |
4cc7e498 GM |
4177 | |
4178 | ;; We could be looking at two things here: | |
4179 | ;; operator definition: function "." ( | |
4180 | ;; subprogram definition: procedure .... ( | |
4181 | ;; Let's skip back over the first one | |
4182 | (progn | |
4607c7f4 | 4183 | (skip-chars-backward " \t\n") |
4cc7e498 | 4184 | (if (= (char-before) ?\") |
f70b58b0 JB |
4185 | (backward-char 3) |
4186 | (backward-word 1)) | |
4cc7e498 GM |
4187 | t) |
4188 | ||
4189 | ;; and now over the second one | |
4190 | (backward-word 1) | |
4191 | ||
7749c1a8 GM |
4192 | ;; We should ignore the case when the reserved keyword is in a |
4193 | ;; comment (for instance, when we have: | |
4194 | ;; -- .... package | |
4195 | ;; Test (A) | |
4196 | ;; we should return nil | |
4197 | ||
4198 | (not (ada-in-string-or-comment-p)) | |
4cc7e498 | 4199 | |
7749c1a8 GM |
4200 | ;; right keyword two words before parenthesis ? |
4201 | ;; Type is in this list because of discriminants | |
afb5d709 | 4202 | ;; pragma is not, because the syntax is that of a subprogram call. |
7749c1a8 | 4203 | (looking-at (eval-when-compile |
f70b58b0 JB |
4204 | (concat "\\<\\(" |
4205 | "procedure\\|function\\|body\\|" | |
4206 | "task\\|entry\\|accept\\|" | |
4207 | "access[ \t]+procedure\\|" | |
4208 | "access[ \t]+function\\|" | |
f70b58b0 | 4209 | "type\\)\\>")))))) |
972579f9 | 4210 | |
4cc7e498 | 4211 | (defun ada-search-ignore-complex-boolean (regexp backwardp) |
f70b58b0 JB |
4212 | "Search for REGEXP, ignoring comments, strings, 'and then', 'or else'. |
4213 | If BACKWARDP is non-nil, search backward; search forward otherwise." | |
4cc7e498 | 4214 | (let (result) |
36144b26 | 4215 | (while (and (setq result (ada-search-ignore-string-comment regexp backwardp)) |
4cc7e498 GM |
4216 | (save-excursion (forward-word -1) |
4217 | (looking-at "and then\\|or else")))) | |
4218 | result)) | |
4219 | ||
972579f9 | 4220 | (defun ada-in-open-paren-p () |
f70b58b0 JB |
4221 | "Non-nil if in an open parenthesis. |
4222 | Return value is the position of the first non-ws behind the last unclosed | |
655880d2 | 4223 | parenthesis, or nil." |
7749c1a8 GM |
4224 | (save-excursion |
4225 | (let ((parse (parse-partial-sexp | |
f70b58b0 JB |
4226 | (point) |
4227 | (or (car (ada-search-ignore-complex-boolean | |
4228 | "\\<\\(;\\|is\\|then\\|loop\\|begin\\|else\\)\\>" | |
4229 | t)) | |
4230 | (point-min))))) | |
4cc7e498 | 4231 | |
7749c1a8 | 4232 | (if (nth 1 parse) |
f70b58b0 JB |
4233 | (progn |
4234 | (goto-char (1+ (nth 1 parse))) | |
4607c7f4 SM |
4235 | |
4236 | ;; Skip blanks, if they are not followed by a comment | |
4237 | ;; See: | |
4238 | ;; type A is ( Value_0, | |
4239 | ;; Value_1); | |
4240 | ;; type B is ( -- comment | |
4241 | ;; Value_2); | |
a1506d29 | 4242 | |
4607c7f4 SM |
4243 | (if (or (not ada-indent-handle-comment-special) |
4244 | (not (looking-at "[ \t]+--"))) | |
f70b58b0 | 4245 | (skip-chars-forward " \t")) |
4607c7f4 | 4246 | |
f70b58b0 | 4247 | (point)))))) |
972579f9 RS |
4248 | |
4249 | \f | |
4cc7e498 GM |
4250 | ;; ----------------------------------------------------------- |
4251 | ;; -- Behavior Of TAB Key | |
4252 | ;; ----------------------------------------------------------- | |
655880d2 | 4253 | |
972579f9 | 4254 | (defun ada-tab () |
7749c1a8 | 4255 | "Do indenting or tabbing according to `ada-tab-policy'. |
7749c1a8 | 4256 | In Transient Mark mode, if the mark is active, operate on the contents |
6d533a6e | 4257 | of the region. Otherwise, operate only on the current line." |
972579f9 | 4258 | (interactive) |
7749c1a8 | 4259 | (cond ((eq ada-tab-policy 'indent-rigidly) (ada-tab-hard)) |
f70b58b0 | 4260 | ((eq ada-tab-policy 'indent-auto) |
4607c7f4 | 4261 | (if (ada-region-selected) |
f70b58b0 JB |
4262 | (ada-indent-region (region-beginning) (region-end)) |
4263 | (ada-indent-current))) | |
4264 | ((eq ada-tab-policy 'always-tab) (error "Not implemented")) | |
4265 | )) | |
972579f9 | 4266 | |
972579f9 RS |
4267 | (defun ada-untab (arg) |
4268 | "Delete leading indenting according to `ada-tab-policy'." | |
f70b58b0 | 4269 | ;; FIXME: ARG is ignored |
972579f9 RS |
4270 | (interactive "P") |
4271 | (cond ((eq ada-tab-policy 'indent-rigidly) (ada-untab-hard)) | |
f70b58b0 JB |
4272 | ((eq ada-tab-policy 'indent-auto) (error "Not implemented")) |
4273 | ((eq ada-tab-policy 'always-tab) (error "Not implemented")) | |
4274 | )) | |
972579f9 | 4275 | |
972579f9 | 4276 | (defun ada-indent-current-function () |
6d533a6e | 4277 | "Ada mode version of the `indent-line-function'." |
972579f9 RS |
4278 | (interactive "*") |
4279 | (let ((starting-point (point-marker))) | |
7749c1a8 | 4280 | (beginning-of-line) |
972579f9 RS |
4281 | (ada-tab) |
4282 | (if (< (point) starting-point) | |
f70b58b0 | 4283 | (goto-char starting-point)) |
972579f9 RS |
4284 | (set-marker starting-point nil) |
4285 | )) | |
4286 | ||
972579f9 RS |
4287 | (defun ada-tab-hard () |
4288 | "Indent current line to next tab stop." | |
4289 | (interactive) | |
4290 | (save-excursion | |
4291 | (beginning-of-line) | |
4292 | (insert-char ? ada-indent)) | |
4293 | (if (save-excursion (= (point) (progn (beginning-of-line) (point)))) | |
4294 | (forward-char ada-indent))) | |
4295 | ||
972579f9 | 4296 | (defun ada-untab-hard () |
6d533a6e | 4297 | "Indent current line to previous tab stop." |
972579f9 | 4298 | (interactive) |
ff003dc7 | 4299 | (let ((bol (save-excursion (progn (beginning-of-line) (point)))) |
f70b58b0 | 4300 | (eol (save-excursion (progn (end-of-line) (point))))) |
ff003dc7 | 4301 | (indent-rigidly bol eol (- 0 ada-indent)))) |
972579f9 RS |
4302 | |
4303 | ||
972579f9 | 4304 | \f |
655880d2 GM |
4305 | ;; ------------------------------------------------------------ |
4306 | ;; -- Miscellaneous | |
4307 | ;; ------------------------------------------------------------ | |
972579f9 | 4308 | |
4607c7f4 SM |
4309 | ;; Not needed any more for Emacs 21.2, but still needed for backward |
4310 | ;; compatibility | |
ff003dc7 | 4311 | (defun ada-remove-trailing-spaces () |
4607c7f4 SM |
4312 | "Remove trailing spaces in the whole buffer." |
4313 | (interactive) | |
4314 | (save-match-data | |
4315 | (save-excursion | |
4316 | (save-restriction | |
f70b58b0 JB |
4317 | (widen) |
4318 | (goto-char (point-min)) | |
4319 | (while (re-search-forward "[ \t]+$" (point-max) t) | |
4320 | (replace-match "" nil nil)))))) | |
4607c7f4 | 4321 | |
cadd3658 RS |
4322 | (defun ada-gnat-style () |
4323 | "Clean up comments, `(' and `,' for GNAT style checking switch." | |
4324 | (interactive) | |
4325 | (save-excursion | |
4607c7f4 SM |
4326 | |
4327 | ;; The \n is required, or the line after an empty comment line is | |
4328 | ;; simply ignored. | |
cadd3658 | 4329 | (goto-char (point-min)) |
4607c7f4 SM |
4330 | (while (re-search-forward "--[ \t]*\\([^-\n]\\)" nil t) |
4331 | (replace-match "-- \\1") | |
4332 | (forward-line 1) | |
4333 | (beginning-of-line)) | |
a1506d29 | 4334 | |
cadd3658 RS |
4335 | (goto-char (point-min)) |
4336 | (while (re-search-forward "\\>(" nil t) | |
4607c7f4 SM |
4337 | (if (not (ada-in-string-or-comment-p)) |
4338 | (replace-match " ("))) | |
4339 | (goto-char (point-min)) | |
4340 | (while (re-search-forward ";--" nil t) | |
4341 | (forward-char -1) | |
4342 | (if (not (ada-in-string-or-comment-p)) | |
4343 | (replace-match "; --"))) | |
cadd3658 | 4344 | (goto-char (point-min)) |
4cc7e498 | 4345 | (while (re-search-forward "([ \t]+" nil t) |
4607c7f4 SM |
4346 | (if (not (ada-in-string-or-comment-p)) |
4347 | (replace-match "("))) | |
4cc7e498 GM |
4348 | (goto-char (point-min)) |
4349 | (while (re-search-forward ")[ \t]+)" nil t) | |
4607c7f4 SM |
4350 | (if (not (ada-in-string-or-comment-p)) |
4351 | (replace-match "))"))) | |
4cc7e498 GM |
4352 | (goto-char (point-min)) |
4353 | (while (re-search-forward "\\>:" nil t) | |
4607c7f4 SM |
4354 | (if (not (ada-in-string-or-comment-p)) |
4355 | (replace-match " :"))) | |
4356 | ||
4357 | ;; Make sure there is a space after a ','. | |
4358 | ;; Always go back to the beginning of the match, since otherwise | |
4359 | ;; a statement like ('F','D','E') is incorrectly modified. | |
4cc7e498 | 4360 | (goto-char (point-min)) |
4607c7f4 SM |
4361 | (while (re-search-forward ",[ \t]*\\(.\\)" nil t) |
4362 | (if (not (save-excursion | |
4363 | (goto-char (match-beginning 0)) | |
4364 | (ada-in-string-or-comment-p))) | |
4365 | (replace-match ", \\1"))) | |
4366 | ||
4367 | ;; Operators should be surrounded by spaces. | |
4cc7e498 | 4368 | (goto-char (point-min)) |
4607c7f4 SM |
4369 | (while (re-search-forward |
4370 | "[ \t]*\\(/=\\|\\*\\*\\|:=\\|\\.\\.\\|[-:+*/]\\)[ \t]*" | |
4371 | nil t) | |
4372 | (goto-char (match-beginning 1)) | |
4373 | (if (or (looking-at "--") | |
4374 | (ada-in-string-or-comment-p)) | |
4cc7e498 | 4375 | (progn |
4607c7f4 SM |
4376 | (forward-line 1) |
4377 | (beginning-of-line)) | |
4378 | (cond | |
4379 | ((string= (match-string 1) "/=") | |
4380 | (replace-match " /= ")) | |
4381 | ((string= (match-string 1) "..") | |
4382 | (replace-match " .. ")) | |
4383 | ((string= (match-string 1) "**") | |
4384 | (replace-match " ** ")) | |
4385 | ((string= (match-string 1) ":=") | |
4386 | (replace-match " := ")) | |
4387 | (t | |
4388 | (replace-match " \\1 "))) | |
4389 | (forward-char 1))) | |
cadd3658 RS |
4390 | )) |
4391 | ||
4392 | ||
972579f9 | 4393 | \f |
655880d2 | 4394 | ;; ------------------------------------------------------------- |
4cc7e498 | 4395 | ;; -- Moving To Procedures/Packages/Statements |
655880d2 GM |
4396 | ;; ------------------------------------------------------------- |
4397 | ||
4cc7e498 | 4398 | (defun ada-move-to-start () |
6d533a6e | 4399 | "Move point to the matching start of the current Ada structure." |
4cc7e498 GM |
4400 | (interactive) |
4401 | (let ((pos (point)) | |
f70b58b0 | 4402 | (previous-syntax-table (syntax-table))) |
4cc7e498 | 4403 | (unwind-protect |
f70b58b0 JB |
4404 | (progn |
4405 | (set-syntax-table ada-mode-symbol-syntax-table) | |
4406 | ||
4407 | (save-excursion | |
4408 | ;; | |
4409 | ;; do nothing if in string or comment or not on 'end ...;' | |
4410 | ;; or if an error occurs during processing | |
4411 | ;; | |
4412 | (or | |
4413 | (ada-in-string-or-comment-p) | |
4414 | (and (progn | |
4415 | (or (looking-at "[ \t]*\\<end\\>") | |
4416 | (backward-word 1)) | |
4417 | (or (looking-at "[ \t]*\\<end\\>") | |
4418 | (backward-word 1)) | |
4419 | (or (looking-at "[ \t]*\\<end\\>") | |
4420 | (error "Not on end ...;"))) | |
4421 | (ada-goto-matching-start 1) | |
4422 | (setq pos (point)) | |
4423 | ||
4424 | ;; | |
4425 | ;; on 'begin' => go on, according to user option | |
4426 | ;; | |
4427 | ada-move-to-declaration | |
4428 | (looking-at "\\<begin\\>") | |
6a47c86a | 4429 | (ada-goto-decl-start) |
f70b58b0 JB |
4430 | (setq pos (point)))) |
4431 | ||
4432 | ) ; end of save-excursion | |
4433 | ||
4434 | ;; now really move to the found position | |
4435 | (goto-char pos)) | |
4cc7e498 GM |
4436 | |
4437 | ;; restore syntax-table | |
4438 | (set-syntax-table previous-syntax-table)))) | |
4439 | ||
4440 | (defun ada-move-to-end () | |
6a47c86a | 4441 | "Move point to the end of the block around point. |
4cc7e498 GM |
4442 | Moves to 'begin' if in a declarative part." |
4443 | (interactive) | |
4444 | (let ((pos (point)) | |
4607c7f4 | 4445 | decl-start |
f70b58b0 | 4446 | (previous-syntax-table (syntax-table))) |
4cc7e498 | 4447 | (unwind-protect |
f70b58b0 JB |
4448 | (progn |
4449 | (set-syntax-table ada-mode-symbol-syntax-table) | |
4cc7e498 | 4450 | |
f70b58b0 | 4451 | (save-excursion |
4cc7e498 | 4452 | |
f70b58b0 JB |
4453 | (cond |
4454 | ;; Go to the beginning of the current word, and check if we are | |
4455 | ;; directly on 'begin' | |
4607c7f4 | 4456 | ((save-excursion |
80d50f88 | 4457 | (skip-syntax-backward "w") |
4607c7f4 | 4458 | (looking-at "\\<begin\\>")) |
f7a80909 JB |
4459 | (ada-goto-matching-end 1) |
4460 | ) | |
a1506d29 | 4461 | |
4607c7f4 SM |
4462 | ;; on first line of subprogram body |
4463 | ;; Do nothing for specs or generic instantion, since these are | |
4464 | ;; handled as the general case (find the enclosing block) | |
4465 | ;; We also need to make sure that we ignore nested subprograms | |
4466 | ((save-excursion | |
4467 | (and (skip-syntax-backward "w") | |
4468 | (looking-at "\\<function\\>\\|\\<procedure\\>" ) | |
f70b58b0 JB |
4469 | (ada-search-ignore-string-comment "is\\|;") |
4470 | (not (= (char-before) ?\;)) | |
4471 | )) | |
4607c7f4 SM |
4472 | (skip-syntax-backward "w") |
4473 | (ada-goto-matching-end 0 t)) | |
a1506d29 | 4474 | |
f70b58b0 JB |
4475 | ;; on first line of task declaration |
4476 | ((save-excursion | |
4477 | (and (ada-goto-stmt-start) | |
4478 | (looking-at "\\<task\\>" ) | |
4479 | (forward-word 1) | |
4480 | (ada-goto-next-non-ws) | |
4481 | (looking-at "\\<body\\>"))) | |
4482 | (ada-search-ignore-string-comment "begin" nil nil nil | |
4483 | 'word-search-forward)) | |
4484 | ;; accept block start | |
4485 | ((save-excursion | |
4486 | (and (ada-goto-stmt-start) | |
4487 | (looking-at "\\<accept\\>" ))) | |
4488 | (ada-goto-matching-end 0)) | |
4489 | ;; package start | |
4490 | ((save-excursion | |
6a47c86a | 4491 | (setq decl-start (and (ada-goto-decl-start t) (point))) |
f70b58b0 JB |
4492 | (and decl-start (looking-at "\\<package\\>"))) |
4493 | (ada-goto-matching-end 1)) | |
80d50f88 SM |
4494 | |
4495 | ;; On a "declare" keyword | |
4496 | ((save-excursion | |
4497 | (skip-syntax-backward "w") | |
4498 | (looking-at "\\<declare\\>")) | |
4499 | (ada-goto-matching-end 0 t)) | |
a1506d29 | 4500 | |
f70b58b0 JB |
4501 | ;; inside a 'begin' ... 'end' block |
4502 | (decl-start | |
4607c7f4 SM |
4503 | (goto-char decl-start) |
4504 | (ada-goto-matching-end 0 t)) | |
a1506d29 | 4505 | |
f70b58b0 JB |
4506 | ;; (hopefully ;-) everything else |
4507 | (t | |
4508 | (ada-goto-matching-end 1))) | |
4509 | (setq pos (point)) | |
4510 | ) | |
4cc7e498 | 4511 | |
f70b58b0 JB |
4512 | ;; now really move to the position found |
4513 | (goto-char pos)) | |
4cc7e498 GM |
4514 | |
4515 | ;; restore syntax-table | |
4516 | (set-syntax-table previous-syntax-table)))) | |
4517 | ||
972579f9 | 4518 | (defun ada-next-procedure () |
6d533a6e | 4519 | "Move point to next procedure." |
972579f9 RS |
4520 | (interactive) |
4521 | (end-of-line) | |
4522 | (if (re-search-forward ada-procedure-start-regexp nil t) | |
dc786b8a | 4523 | (goto-char (match-beginning 4)) |
972579f9 RS |
4524 | (error "No more functions/procedures/tasks"))) |
4525 | ||
4526 | (defun ada-previous-procedure () | |
6d533a6e | 4527 | "Move point to previous procedure." |
972579f9 RS |
4528 | (interactive) |
4529 | (beginning-of-line) | |
4530 | (if (re-search-backward ada-procedure-start-regexp nil t) | |
dc786b8a | 4531 | (goto-char (match-beginning 4)) |
972579f9 RS |
4532 | (error "No more functions/procedures/tasks"))) |
4533 | ||
4534 | (defun ada-next-package () | |
6d533a6e | 4535 | "Move point to next package." |
972579f9 RS |
4536 | (interactive) |
4537 | (end-of-line) | |
4538 | (if (re-search-forward ada-package-start-regexp nil t) | |
4539 | (goto-char (match-beginning 1)) | |
4540 | (error "No more packages"))) | |
4541 | ||
4542 | (defun ada-previous-package () | |
6d533a6e | 4543 | "Move point to previous package." |
972579f9 RS |
4544 | (interactive) |
4545 | (beginning-of-line) | |
4546 | (if (re-search-backward ada-package-start-regexp nil t) | |
4547 | (goto-char (match-beginning 1)) | |
4548 | (error "No more packages"))) | |
4549 | ||
4550 | \f | |
655880d2 GM |
4551 | ;; ------------------------------------------------------------ |
4552 | ;; -- Define keymap and menus for Ada | |
4553 | ;; ------------------------------------------------------------- | |
972579f9 | 4554 | |
7749c1a8 | 4555 | (defun ada-create-keymap () |
655880d2 | 4556 | "Create the keymap associated with the Ada mode." |
7749c1a8 | 4557 | |
a3507bd3 SM |
4558 | ;; All non-standard keys go into ada-mode-extra-map |
4559 | (define-key ada-mode-map ada-mode-extra-prefix ada-mode-extra-map) | |
4560 | ||
7749c1a8 GM |
4561 | ;; Indentation and Formatting |
4562 | (define-key ada-mode-map "\C-j" 'ada-indent-newline-indent-conditional) | |
4563 | (define-key ada-mode-map "\C-m" 'ada-indent-newline-indent-conditional) | |
4564 | (define-key ada-mode-map "\t" 'ada-tab) | |
4565 | (define-key ada-mode-map "\C-c\t" 'ada-justified-indent-current) | |
4566 | (define-key ada-mode-map "\C-c\C-l" 'ada-indent-region) | |
23b747d1 | 4567 | (define-key ada-mode-map [(shift tab)] 'ada-untab) |
7749c1a8 GM |
4568 | (define-key ada-mode-map "\C-c\C-f" 'ada-format-paramlist) |
4569 | ;; We don't want to make meta-characters case-specific. | |
4570 | ||
4571 | ;; Movement | |
4572 | (define-key ada-mode-map "\M-\C-e" 'ada-next-procedure) | |
4573 | (define-key ada-mode-map "\M-\C-a" 'ada-previous-procedure) | |
4574 | (define-key ada-mode-map "\C-c\C-a" 'ada-move-to-start) | |
4575 | (define-key ada-mode-map "\C-c\C-e" 'ada-move-to-end) | |
4576 | ||
4577 | ;; Compilation | |
4578 | (unless (lookup-key ada-mode-map "\C-c\C-c") | |
4579 | (define-key ada-mode-map "\C-c\C-c" 'compile)) | |
4580 | ||
4581 | ;; Casing | |
4582 | (define-key ada-mode-map "\C-c\C-b" 'ada-adjust-case-buffer) | |
4583 | (define-key ada-mode-map "\C-c\C-t" 'ada-case-read-exceptions) | |
4584 | (define-key ada-mode-map "\C-c\C-y" 'ada-create-case-exception) | |
4607c7f4 | 4585 | (define-key ada-mode-map "\C-c\C-\M-y" 'ada-create-case-exception-substring) |
7749c1a8 | 4586 | |
4cc7e498 GM |
4587 | ;; On XEmacs, you can easily specify whether DEL should deletes |
4588 | ;; one character forward or one character backward. Take this into | |
4589 | ;; account | |
23b747d1 SM |
4590 | (define-key ada-mode-map |
4591 | (if (boundp 'delete-key-deletes-forward) [backspace] "\177") | |
d5dac3b9 | 4592 | 'backward-delete-char-untabify) |
7749c1a8 GM |
4593 | |
4594 | ;; Make body | |
4595 | (define-key ada-mode-map "\C-c\C-n" 'ada-make-subprogram-body) | |
4596 | ||
655880d2 | 4597 | ;; Use predefined function of Emacs19 for comments (RE) |
7749c1a8 GM |
4598 | (define-key ada-mode-map "\C-c;" 'comment-region) |
4599 | (define-key ada-mode-map "\C-c:" 'ada-uncomment-region) | |
f7a80909 JB |
4600 | |
4601 | ;; The following keys are bound to functions defined in ada-xref.el or | |
4602 | ;; ada-prj,el., However, RMS rightly thinks that the code should be shared, | |
4603 | ;; and activated only if the right compiler is used | |
65c96997 | 4604 | |
23b747d1 SM |
4605 | (define-key ada-mode-map (if (featurep 'xemacs) '(shift button3) [S-mouse-3]) |
4606 | 'ada-point-and-xref) | |
4607 | (define-key ada-mode-map [(control tab)] 'ada-complete-identifier) | |
f7a80909 | 4608 | |
a3507bd3 | 4609 | (define-key ada-mode-extra-map "o" 'ff-find-other-file) |
f7a80909 JB |
4610 | (define-key ada-mode-map "\C-c5\C-d" 'ada-goto-declaration-other-frame) |
4611 | (define-key ada-mode-map "\C-c\C-d" 'ada-goto-declaration) | |
4612 | (define-key ada-mode-map "\C-c\C-s" 'ada-xref-goto-previous-reference) | |
4613 | (define-key ada-mode-map "\C-c\C-c" 'ada-compile-application) | |
a3507bd3 SM |
4614 | (define-key ada-mode-extra-map "c" 'ada-change-prj) |
4615 | (define-key ada-mode-extra-map "d" 'ada-set-default-project-file) | |
4616 | (define-key ada-mode-extra-map "g" 'ada-gdb-application) | |
d4ee31d3 | 4617 | (define-key ada-mode-map "\C-c\C-m" 'ada-set-main-compile-application) |
a3507bd3 | 4618 | (define-key ada-mode-extra-map "r" 'ada-run-application) |
f7a80909 JB |
4619 | (define-key ada-mode-map "\C-c\C-o" 'ada-goto-parent) |
4620 | (define-key ada-mode-map "\C-c\C-r" 'ada-find-references) | |
a3507bd3 | 4621 | (define-key ada-mode-extra-map "l" 'ada-find-local-references) |
f7a80909 | 4622 | (define-key ada-mode-map "\C-c\C-v" 'ada-check-current) |
a3507bd3 | 4623 | (define-key ada-mode-extra-map "f" 'ada-find-file) |
f7a80909 | 4624 | |
a3507bd3 | 4625 | (define-key ada-mode-extra-map "u" 'ada-prj-edit) |
f7a80909 | 4626 | |
80e18d20 SL |
4627 | (define-key ada-mode-map "\C-xnd" 'ada-narrow-to-defun); override narrow-to-defun |
4628 | ||
f7a80909 JB |
4629 | ;; The templates, defined in ada-stmt.el |
4630 | ||
4631 | (let ((map (make-sparse-keymap))) | |
4632 | (define-key map "h" 'ada-header) | |
4633 | (define-key map "\C-a" 'ada-array) | |
4634 | (define-key map "b" 'ada-exception-block) | |
4635 | (define-key map "d" 'ada-declare-block) | |
4636 | (define-key map "c" 'ada-case) | |
4637 | (define-key map "\C-e" 'ada-elsif) | |
4638 | (define-key map "e" 'ada-else) | |
4639 | (define-key map "\C-k" 'ada-package-spec) | |
4640 | (define-key map "k" 'ada-package-body) | |
4641 | (define-key map "\C-p" 'ada-procedure-spec) | |
4642 | (define-key map "p" 'ada-subprogram-body) | |
4643 | (define-key map "\C-f" 'ada-function-spec) | |
4644 | (define-key map "f" 'ada-for-loop) | |
4645 | (define-key map "i" 'ada-if) | |
4646 | (define-key map "l" 'ada-loop) | |
4647 | (define-key map "\C-r" 'ada-record) | |
4648 | (define-key map "\C-s" 'ada-subtype) | |
4649 | (define-key map "S" 'ada-tabsize) | |
4650 | (define-key map "\C-t" 'ada-task-spec) | |
4651 | (define-key map "t" 'ada-task-body) | |
4652 | (define-key map "\C-y" 'ada-type) | |
4653 | (define-key map "\C-v" 'ada-private) | |
4654 | (define-key map "u" 'ada-use) | |
4655 | (define-key map "\C-u" 'ada-with) | |
4656 | (define-key map "\C-w" 'ada-when) | |
4657 | (define-key map "w" 'ada-while-loop) | |
4658 | (define-key map "\C-x" 'ada-exception) | |
4659 | (define-key map "x" 'ada-exit) | |
a3507bd3 | 4660 | (define-key ada-mode-extra-map "t" map)) |
7749c1a8 | 4661 | ) |
972579f9 | 4662 | |
655880d2 | 4663 | |
7749c1a8 | 4664 | (defun ada-create-menu () |
6d533a6e | 4665 | "Create the Ada menu as shown in the menu bar." |
f7a80909 JB |
4666 | (let ((m '("Ada" |
4667 | ("Help" | |
4668 | ["Ada Mode" (info "ada-mode") t] | |
4669 | ["GNAT User's Guide" (info "gnat_ugn") | |
4670 | (eq ada-which-compiler 'gnat)] | |
4671 | ["GNAT Reference Manual" (info "gnat_rm") | |
4672 | (eq ada-which-compiler 'gnat)] | |
4673 | ["Gcc Documentation" (info "gcc") | |
4674 | (eq ada-which-compiler 'gnat)] | |
4675 | ["Gdb Documentation" (info "gdb") | |
4676 | (eq ada-which-compiler 'gnat)] | |
7fdb5d54 | 4677 | ["Ada95 Reference Manual" (info "arm95") t]) |
f7a80909 JB |
4678 | ("Options" :included (eq major-mode 'ada-mode) |
4679 | ["Auto Casing" (setq ada-auto-case (not ada-auto-case)) | |
4680 | :style toggle :selected ada-auto-case] | |
4681 | ["Auto Indent After Return" | |
4682 | (setq ada-indent-after-return (not ada-indent-after-return)) | |
4683 | :style toggle :selected ada-indent-after-return] | |
4684 | ["Automatically Recompile For Cross-references" | |
4685 | (setq ada-xref-create-ali (not ada-xref-create-ali)) | |
4686 | :style toggle :selected ada-xref-create-ali | |
4687 | :included (eq ada-which-compiler 'gnat)] | |
4688 | ["Confirm Commands" | |
4689 | (setq ada-xref-confirm-compile (not ada-xref-confirm-compile)) | |
4690 | :style toggle :selected ada-xref-confirm-compile | |
4691 | :included (eq ada-which-compiler 'gnat)] | |
4692 | ["Show Cross-references In Other Buffer" | |
4693 | (setq ada-xref-other-buffer (not ada-xref-other-buffer)) | |
4694 | :style toggle :selected ada-xref-other-buffer | |
4695 | :included (eq ada-which-compiler 'gnat)] | |
4696 | ["Tight Integration With GNU Visual Debugger" | |
4697 | (setq ada-tight-gvd-integration (not ada-tight-gvd-integration)) | |
4698 | :style toggle :selected ada-tight-gvd-integration | |
4699 | :included (string-match "gvd" ada-prj-default-debugger)]) | |
4700 | ["Customize" (customize-group 'ada) | |
4701 | :included (fboundp 'customize-group)] | |
f70b58b0 JB |
4702 | ["Check file" ada-check-current t] |
4703 | ["Compile file" ada-compile-current t] | |
d4ee31d3 JB |
4704 | ["Set main and Build" ada-set-main-compile-application t] |
4705 | ["Show main" ada-show-current-main t] | |
f70b58b0 | 4706 | ["Build" ada-compile-application t] |
f7a80909 JB |
4707 | ["Run" ada-run-application t] |
4708 | ["Debug" ada-gdb-application (eq ada-which-compiler 'gnat)] | |
4709 | ["------" nil nil] | |
4710 | ("Project" | |
d4ee31d3 | 4711 | ["Show project" ada-show-current-project t] |
f7a80909 JB |
4712 | ["Load..." ada-set-default-project-file t] |
4713 | ["New..." ada-prj-new t] | |
4714 | ["Edit..." ada-prj-edit t]) | |
4715 | ("Goto" :included (eq major-mode 'ada-mode) | |
4716 | ["Goto Declaration/Body" ada-goto-declaration | |
4717 | (eq ada-which-compiler 'gnat)] | |
4718 | ["Goto Body" ada-goto-body | |
4719 | (eq ada-which-compiler 'gnat)] | |
4720 | ["Goto Declaration Other Frame" | |
4721 | ada-goto-declaration-other-frame | |
4722 | (eq ada-which-compiler 'gnat)] | |
4723 | ["Goto Previous Reference" ada-xref-goto-previous-reference | |
4724 | (eq ada-which-compiler 'gnat)] | |
4725 | ["List Local References" ada-find-local-references | |
4726 | (eq ada-which-compiler 'gnat)] | |
4727 | ["List References" ada-find-references | |
4728 | (eq ada-which-compiler 'gnat)] | |
4729 | ["Goto Reference To Any Entity" ada-find-any-references | |
4730 | (eq ada-which-compiler 'gnat)] | |
4731 | ["Goto Parent Unit" ada-goto-parent | |
4732 | (eq ada-which-compiler 'gnat)] | |
4733 | ["--" nil nil] | |
4734 | ["Next compilation error" next-error t] | |
4735 | ["Previous Package" ada-previous-package t] | |
4736 | ["Next Package" ada-next-package t] | |
4737 | ["Previous Procedure" ada-previous-procedure t] | |
6f9a2614 JB |
4738 | ["Next Procedure" ada-next-procedure t] |
4739 | ["Goto Start Of Statement" ada-move-to-start t] | |
f7a80909 JB |
4740 | ["Goto End Of Statement" ada-move-to-end t] |
4741 | ["-" nil nil] | |
4742 | ["Other File" ff-find-other-file t] | |
4743 | ["Other File Other Window" ada-ff-other-window t]) | |
4744 | ("Edit" :included (eq major-mode 'ada-mode) | |
4745 | ["Search File On Source Path" ada-find-file t] | |
4746 | ["------" nil nil] | |
4747 | ["Complete Identifier" ada-complete-identifier t] | |
4748 | ["-----" nil nil] | |
4749 | ["Indent Line" ada-indent-current-function t] | |
4750 | ["Justify Current Indentation" ada-justified-indent-current t] | |
4751 | ["Indent Lines in Selection" ada-indent-region t] | |
4752 | ["Indent Lines in File" | |
4753 | (ada-indent-region (point-min) (point-max)) t] | |
4754 | ["Format Parameter List" ada-format-paramlist t] | |
4755 | ["-" nil nil] | |
4756 | ["Comment Selection" comment-region t] | |
4757 | ["Uncomment Selection" ada-uncomment-region t] | |
4758 | ["--" nil nil] | |
4759 | ["Fill Comment Paragraph" fill-paragraph t] | |
4760 | ["Fill Comment Paragraph Justify" | |
4761 | ada-fill-comment-paragraph-justify t] | |
4762 | ["Fill Comment Paragraph Postfix" | |
4763 | ada-fill-comment-paragraph-postfix t] | |
4764 | ["---" nil nil] | |
4765 | ["Adjust Case Selection" ada-adjust-case-region t] | |
4766 | ["Adjust Case in File" ada-adjust-case-buffer t] | |
6f9a2614 JB |
4767 | ["Create Case Exception" ada-create-case-exception t] |
4768 | ["Create Case Exception Substring" | |
f7a80909 JB |
4769 | ada-create-case-exception-substring t] |
4770 | ["Reload Case Exceptions" ada-case-read-exceptions t] | |
4771 | ["----" nil nil] | |
4772 | ["Make body for subprogram" ada-make-subprogram-body t] | |
4773 | ["-----" nil nil] | |
f70b58b0 | 4774 | ["Narrow to subprogram" ada-narrow-to-defun t]) |
f7a80909 JB |
4775 | ("Templates" |
4776 | :included (eq major-mode 'ada-mode) | |
4777 | ["Header" ada-header t] | |
4778 | ["-" nil nil] | |
4779 | ["Package Body" ada-package-body t] | |
4780 | ["Package Spec" ada-package-spec t] | |
4781 | ["Function Spec" ada-function-spec t] | |
4782 | ["Procedure Spec" ada-procedure-spec t] | |
4783 | ["Proc/func Body" ada-subprogram-body t] | |
4784 | ["Task Body" ada-task-body t] | |
4785 | ["Task Spec" ada-task-spec t] | |
4786 | ["Declare Block" ada-declare-block t] | |
4787 | ["Exception Block" ada-exception-block t] | |
4788 | ["--" nil nil] | |
4789 | ["Entry" ada-entry t] | |
4790 | ["Entry family" ada-entry-family t] | |
4791 | ["Select" ada-select t] | |
4792 | ["Accept" ada-accept t] | |
4793 | ["Or accept" ada-or-accep t] | |
4794 | ["Or delay" ada-or-delay t] | |
4795 | ["Or terminate" ada-or-terminate t] | |
4796 | ["---" nil nil] | |
4797 | ["Type" ada-type t] | |
4798 | ["Private" ada-private t] | |
4799 | ["Subtype" ada-subtype t] | |
4800 | ["Record" ada-record t] | |
4801 | ["Array" ada-array t] | |
4802 | ["----" nil nil] | |
4803 | ["If" ada-if t] | |
4804 | ["Else" ada-else t] | |
4805 | ["Elsif" ada-elsif t] | |
4806 | ["Case" ada-case t] | |
4807 | ["-----" nil nil] | |
4808 | ["While Loop" ada-while-loop t] | |
4809 | ["For Loop" ada-for-loop t] | |
4810 | ["Loop" ada-loop t] | |
4811 | ["------" nil nil] | |
4812 | ["Exception" ada-exception t] | |
4813 | ["Exit" ada-exit t] | |
4814 | ["When" ada-when t]) | |
4815 | ))) | |
4816 | ||
4cc7e498 | 4817 | (easy-menu-define ada-mode-menu ada-mode-map "Menu keymap for Ada mode" m) |
6f9a2614 JB |
4818 | (if (featurep 'xemacs) |
4819 | (progn | |
4820 | (define-key ada-mode-map [menu-bar] ada-mode-menu) | |
4821 | (set 'mode-popup-menu (cons "Ada mode" ada-mode-menu)))))) | |
972579f9 RS |
4822 | |
4823 | \f | |
655880d2 GM |
4824 | ;; ------------------------------------------------------- |
4825 | ;; Commenting/Uncommenting code | |
4cc7e498 | 4826 | ;; The following two calls are provided to enhance the standard |
7749c1a8 | 4827 | ;; comment-region function, which only allows uncommenting if the |
655880d2 | 4828 | ;; comment is at the beginning of a line. If the line have been re-indented, |
7749c1a8 GM |
4829 | ;; we are unable to use comment-region, which makes no sense. |
4830 | ;; | |
655880d2 GM |
4831 | ;; In addition, we provide an interface to the standard comment handling |
4832 | ;; function for justifying the comments. | |
4833 | ;; ------------------------------------------------------- | |
4834 | ||
80d50f88 | 4835 | (defadvice comment-region (before ada-uncomment-anywhere disable) |
3da360a7 | 4836 | (if (and (consp arg) ;; a prefix with \C-u is of the form '(4), whereas |
f70b58b0 | 4837 | ;; \C-u 2 sets arg to '2' (fixed by S.Leake) |
3da360a7 | 4838 | (derived-mode-p 'ada-mode)) |
7749c1a8 | 4839 | (save-excursion |
f70b58b0 JB |
4840 | (let ((cs (concat "^[ \t]*" (regexp-quote comment-start)))) |
4841 | (goto-char beg) | |
4842 | (while (re-search-forward cs end t) | |
4843 | (replace-match comment-start)) | |
4844 | )))) | |
972579f9 | 4845 | |
7749c1a8 | 4846 | (defun ada-uncomment-region (beg end &optional arg) |
f70b58b0 JB |
4847 | "Uncomment region BEG .. END. |
4848 | ARG gives number of comment characters." | |
7749c1a8 | 4849 | (interactive "r\nP") |
4cc7e498 GM |
4850 | |
4851 | ;; This advice is not needed anymore with Emacs21. However, for older | |
4852 | ;; versions, as well as for XEmacs, we still need to enable it. | |
6f9a2614 | 4853 | (if (or (<= emacs-major-version 20) (featurep 'xemacs)) |
4cc7e498 GM |
4854 | (progn |
4855 | (ad-activate 'comment-region) | |
4607c7f4 | 4856 | (comment-region beg end (- (or arg 2))) |
4cc7e498 | 4857 | (ad-deactivate 'comment-region)) |
80d50f88 SM |
4858 | (comment-region beg end (list (- (or arg 2)))) |
4859 | (ada-indent-region beg end))) | |
7749c1a8 GM |
4860 | |
4861 | (defun ada-fill-comment-paragraph-justify () | |
6d533a6e | 4862 | "Fill current comment paragraph and justify each line as well." |
7749c1a8 GM |
4863 | (interactive) |
4864 | (ada-fill-comment-paragraph 'full)) | |
4865 | ||
4866 | (defun ada-fill-comment-paragraph-postfix () | |
6d533a6e | 4867 | "Fill current comment paragraph and justify each line as well. |
655880d2 | 4868 | Adds `ada-fill-comment-postfix' at the end of each line." |
7749c1a8 GM |
4869 | (interactive) |
4870 | (ada-fill-comment-paragraph 'full t)) | |
972579f9 | 4871 | |
7749c1a8 | 4872 | (defun ada-fill-comment-paragraph (&optional justify postfix) |
6d533a6e | 4873 | "Fill the current comment paragraph. |
7749c1a8 | 4874 | If JUSTIFY is non-nil, each line is justified as well. |
6d533a6e JB |
4875 | If POSTFIX and JUSTIFY are non-nil, `ada-fill-comment-postfix' is appended |
4876 | to each line filled and justified. | |
7749c1a8 | 4877 | The paragraph is indented on the first line." |
972579f9 | 4878 | (interactive "P") |
7749c1a8 GM |
4879 | |
4880 | ;; check if inside comment or just in front a comment | |
4881 | (if (and (not (ada-in-comment-p)) | |
f70b58b0 | 4882 | (not (looking-at "[ \t]*--"))) |
6d533a6e | 4883 | (error "Not inside comment")) |
7749c1a8 | 4884 | |
80d50f88 | 4885 | (let* (indent from to |
f70b58b0 | 4886 | (opos (point-marker)) |
7749c1a8 | 4887 | |
f70b58b0 JB |
4888 | ;; Sets this variable to nil, otherwise it prevents |
4889 | ;; fill-region-as-paragraph to work on Emacs <= 20.2 | |
4890 | (parse-sexp-lookup-properties nil) | |
4cc7e498 | 4891 | |
f70b58b0 JB |
4892 | fill-prefix |
4893 | (fill-column (current-fill-column))) | |
7749c1a8 GM |
4894 | |
4895 | ;; Find end of paragraph | |
4896 | (back-to-indentation) | |
80d50f88 | 4897 | (while (and (not (eobp)) (looking-at ".*--[ \t]*[^ \t\n]")) |
7749c1a8 | 4898 | (forward-line 1) |
4cc7e498 GM |
4899 | |
4900 | ;; If we were at the last line in the buffer, create a dummy empty | |
4901 | ;; line at the end of the buffer. | |
4607c7f4 | 4902 | (if (eobp) |
4cc7e498 GM |
4903 | (insert "\n") |
4904 | (back-to-indentation))) | |
7749c1a8 | 4905 | (beginning-of-line) |
36144b26 | 4906 | (setq to (point-marker)) |
7749c1a8 GM |
4907 | (goto-char opos) |
4908 | ||
4909 | ;; Find beginning of paragraph | |
4607c7f4 | 4910 | (back-to-indentation) |
80d50f88 | 4911 | (while (and (not (bobp)) (looking-at ".*--[ \t]*[^ \t\n]")) |
4607c7f4 SM |
4912 | (forward-line -1) |
4913 | (back-to-indentation)) | |
4914 | ||
80d50f88 | 4915 | ;; We want one line above the first one, unless we are at the beginning |
4607c7f4 SM |
4916 | ;; of the buffer |
4917 | (unless (bobp) | |
10bcf543 | 4918 | (forward-line 1)) |
4607c7f4 | 4919 | (beginning-of-line) |
36144b26 | 4920 | (setq from (point-marker)) |
7749c1a8 GM |
4921 | |
4922 | ;; Calculate the indentation we will need for the paragraph | |
4923 | (back-to-indentation) | |
36144b26 | 4924 | (setq indent (current-column)) |
7749c1a8 GM |
4925 | ;; unindent the first line of the paragraph |
4926 | (delete-region from (point)) | |
4927 | ||
4928 | ;; Remove the old postfixes | |
4929 | (goto-char from) | |
4cc7e498 | 4930 | (while (re-search-forward "--\n" to t) |
7749c1a8 GM |
4931 | (replace-match "\n")) |
4932 | ||
4933 | (goto-char (1- to)) | |
36144b26 | 4934 | (setq to (point-marker)) |
7749c1a8 GM |
4935 | |
4936 | ;; Indent and justify the paragraph | |
36144b26 | 4937 | (setq fill-prefix ada-fill-comment-prefix) |
7749c1a8 GM |
4938 | (set-left-margin from to indent) |
4939 | (if postfix | |
f70b58b0 | 4940 | (setq fill-column (- fill-column (length ada-fill-comment-postfix)))) |
7749c1a8 GM |
4941 | |
4942 | (fill-region-as-paragraph from to justify) | |
4943 | ||
4944 | ;; Add the postfixes if required | |
4945 | (if postfix | |
f70b58b0 JB |
4946 | (save-restriction |
4947 | (goto-char from) | |
4948 | (narrow-to-region from to) | |
4949 | (while (not (eobp)) | |
4950 | (end-of-line) | |
4951 | (insert-char ? (- fill-column (current-column))) | |
4952 | (insert ada-fill-comment-postfix) | |
4953 | (forward-line)) | |
4954 | )) | |
7749c1a8 GM |
4955 | |
4956 | ;; In Emacs <= 20.2 and XEmacs <=20.4, there is a bug, and a newline is | |
4957 | ;; inserted at the end. Delete it | |
6f9a2614 | 4958 | (if (or (featurep 'xemacs) |
f70b58b0 JB |
4959 | (<= emacs-major-version 19) |
4960 | (and (= emacs-major-version 20) | |
4961 | (<= emacs-minor-version 2))) | |
4962 | (progn | |
4963 | (goto-char to) | |
4964 | (end-of-line) | |
4965 | (delete-char 1))) | |
7749c1a8 GM |
4966 | |
4967 | (goto-char opos))) | |
972579f9 | 4968 | |
4cc7e498 | 4969 | |
655880d2 GM |
4970 | ;; --------------------------------------------------- |
4971 | ;; support for find-file.el | |
4972 | ;; These functions are used by find-file to guess the file names from | |
4973 | ;; unit names, and to find the other file (spec or body) from the current | |
4974 | ;; file (body or spec). | |
4975 | ;; It is also used to find in which function we are, so as to put the | |
4976 | ;; cursor at the correct position. | |
4977 | ;; Standard Ada does not force any relation between unit names and file names, | |
4978 | ;; so some of these functions can only be a good approximation. However, they | |
d2bde04f | 4979 | ;; are also overridden in `ada-xref'.el when we know that the user is using |
655880d2 GM |
4980 | ;; GNAT. |
4981 | ;; --------------------------------------------------- | |
4982 | ||
d2bde04f | 4983 | ;; Overridden when we work with GNAT, to use gnatkrunch |
972579f9 | 4984 | (defun ada-make-filename-from-adaname (adaname) |
655880d2 | 4985 | "Determine the filename in which ADANAME is found. |
f70b58b0 JB |
4986 | This matches the GNAT default naming convention, except for |
4987 | pre-defined units." | |
7749c1a8 | 4988 | (while (string-match "\\." adaname) |
36144b26 | 4989 | (setq adaname (replace-match "-" t t adaname))) |
4cc7e498 | 4990 | (downcase adaname) |
972579f9 RS |
4991 | ) |
4992 | ||
7749c1a8 | 4993 | (defun ada-other-file-name () |
4cc7e498 | 4994 | "Return the name of the other file. |
6d533a6e JB |
4995 | The name returned is the body if `current-buffer' is the spec, |
4996 | or the spec otherwise." | |
4cc7e498 GM |
4997 | |
4998 | (let ((is-spec nil) | |
4999 | (is-body nil) | |
5000 | (suffixes ada-spec-suffixes) | |
ff003dc7 | 5001 | (name (buffer-file-name))) |
4cc7e498 GM |
5002 | |
5003 | ;; Guess whether we have a spec or a body, and get the basename of the | |
5004 | ;; file. Since the extension may not start with '.', we can not use | |
5005 | ;; file-name-extension | |
5006 | (while (and (not is-spec) | |
5007 | suffixes) | |
5008 | (if (string-match (concat "\\(.*\\)" (car suffixes) "$") name) | |
5009 | (setq is-spec t | |
5010 | name (match-string 1 name))) | |
36144b26 | 5011 | (setq suffixes (cdr suffixes))) |
4cc7e498 GM |
5012 | |
5013 | (if (not is-spec) | |
5014 | (progn | |
36144b26 | 5015 | (setq suffixes ada-body-suffixes) |
4cc7e498 GM |
5016 | (while (and (not is-body) |
5017 | suffixes) | |
5018 | (if (string-match (concat "\\(.*\\)" (car suffixes) "$") name) | |
5019 | (setq is-body t | |
5020 | name (match-string 1 name))) | |
36144b26 | 5021 | (setq suffixes (cdr suffixes))))) |
eaae8106 | 5022 | |
4cc7e498 GM |
5023 | ;; If this wasn't in either list, return name itself |
5024 | (if (not (or is-spec is-body)) | |
5025 | name | |
eaae8106 | 5026 | |
4cc7e498 GM |
5027 | ;; Else find the other possible names |
5028 | (if is-spec | |
36144b26 SM |
5029 | (setq suffixes ada-body-suffixes) |
5030 | (setq suffixes ada-spec-suffixes)) | |
5031 | (setq is-spec name) | |
4cc7e498 GM |
5032 | |
5033 | (while suffixes | |
4607c7f4 SM |
5034 | |
5035 | ;; If we are using project file, search for the other file in all | |
5036 | ;; the possible src directories. | |
a1506d29 | 5037 | |
6f9a2614 | 5038 | (if (fboundp 'ada-find-src-file-in-dir) |
4607c7f4 SM |
5039 | (let ((other |
5040 | (ada-find-src-file-in-dir | |
5041 | (file-name-nondirectory (concat name (car suffixes)))))) | |
5042 | (if other | |
5043 | (set 'is-spec other))) | |
5044 | ||
5045 | ;; Else search in the current directory | |
5046 | (if (file-exists-p (concat name (car suffixes))) | |
5047 | (setq is-spec (concat name (car suffixes))))) | |
36144b26 | 5048 | (setq suffixes (cdr suffixes))) |
4cc7e498 GM |
5049 | |
5050 | is-spec))) | |
f139ce87 | 5051 | |
f139ce87 | 5052 | (defun ada-which-function-are-we-in () |
655880d2 | 5053 | "Return the name of the function whose definition/declaration point is in. |
dc786b8a | 5054 | Used in `ff-pre-load-hook'." |
36144b26 | 5055 | (setq ff-function-name nil) |
f139ce87 | 5056 | (save-excursion |
4cc7e498 | 5057 | (end-of-line);; make sure we get the complete name |
dc786b8a | 5058 | (or (if (re-search-backward ada-procedure-start-regexp nil t) |
d5875b25 JB |
5059 | (setq ff-function-name (match-string 5))) |
5060 | (if (re-search-backward ada-package-start-regexp nil t) | |
5061 | (setq ff-function-name (match-string 4)))) | |
7749c1a8 | 5062 | )) |
f139ce87 | 5063 | |
4cc7e498 GM |
5064 | |
5065 | (defvar ada-last-which-function-line -1 | |
97a62f83 | 5066 | "Last line on which `ada-which-function' was called.") |
4cc7e498 | 5067 | (defvar ada-last-which-function-subprog 0 |
6d533a6e | 5068 | "Last subprogram name returned by `ada-which-function'.") |
4cc7e498 GM |
5069 | (make-variable-buffer-local 'ada-last-which-function-subprog) |
5070 | (make-variable-buffer-local 'ada-last-which-function-line) | |
5071 | ||
5072 | ||
5073 | (defun ada-which-function () | |
6d533a6e | 5074 | "Return the name of the function whose body the point is in. |
4cc7e498 | 5075 | This function works even in the case of nested subprograms, whereas the |
80d50f88 | 5076 | standard Emacs function `which-function' does not. |
4cc7e498 GM |
5077 | Since the search can be long, the results are cached." |
5078 | ||
80d50f88 | 5079 | (let ((line (count-lines 1 (point))) |
f70b58b0 JB |
5080 | (pos (point)) |
5081 | end-pos | |
5082 | func-name indent | |
5083 | found) | |
4cc7e498 GM |
5084 | |
5085 | ;; If this is the same line as before, simply return the same result | |
5086 | (if (= line ada-last-which-function-line) | |
f70b58b0 | 5087 | ada-last-which-function-subprog |
4cc7e498 GM |
5088 | |
5089 | (save-excursion | |
f70b58b0 JB |
5090 | ;; In case the current line is also the beginning of the body |
5091 | (end-of-line) | |
4cc7e498 | 5092 | |
4607c7f4 SM |
5093 | ;; Are we looking at "function Foo\n (paramlist)" |
5094 | (skip-chars-forward " \t\n(") | |
a1506d29 | 5095 | |
4607c7f4 | 5096 | (condition-case nil |
80d50f88 | 5097 | (up-list 1) |
4607c7f4 SM |
5098 | (error nil)) |
5099 | ||
5100 | (skip-chars-forward " \t\n") | |
5101 | (if (looking-at "return") | |
5102 | (progn | |
5103 | (forward-word 1) | |
5104 | (skip-chars-forward " \t\n") | |
5105 | (skip-chars-forward "a-zA-Z0-9_'"))) | |
a1506d29 | 5106 | |
f70b58b0 JB |
5107 | ;; Can't simply do forward-word, in case the "is" is not on the |
5108 | ;; same line as the closing parenthesis | |
5109 | (skip-chars-forward "is \t\n") | |
4cc7e498 | 5110 | |
f70b58b0 JB |
5111 | ;; No look for the closest subprogram body that has not ended yet. |
5112 | ;; Not that we expect all the bodies to be finished by "end <name>", | |
5113 | ;; or a simple "end;" indented in the same column as the start of | |
4607c7f4 | 5114 | ;; the subprogram. The goal is to be as efficient as possible. |
4cc7e498 | 5115 | |
f70b58b0 JB |
5116 | (while (and (not found) |
5117 | (re-search-backward ada-imenu-subprogram-menu-re nil t)) | |
4607c7f4 SM |
5118 | |
5119 | ;; Get the function name, but not the properties, or this changes | |
5120 | ;; the face in the modeline on Emacs 21 | |
fb0d1545 | 5121 | (setq func-name (match-string-no-properties 3)) |
f70b58b0 JB |
5122 | (if (and (not (ada-in-comment-p)) |
5123 | (not (save-excursion | |
5124 | (goto-char (match-end 0)) | |
5125 | (looking-at "[ \t\n]*new")))) | |
5126 | (save-excursion | |
4607c7f4 SM |
5127 | (back-to-indentation) |
5128 | (setq indent (current-column)) | |
f70b58b0 JB |
5129 | (if (ada-search-ignore-string-comment |
5130 | (concat "end[ \t]+" func-name "[ \t]*;\\|^" | |
4607c7f4 | 5131 | (make-string indent ? ) "end;")) |
f70b58b0 JB |
5132 | (setq end-pos (point)) |
5133 | (setq end-pos (point-max))) | |
5134 | (if (>= end-pos pos) | |
5135 | (setq found func-name)))) | |
5136 | ) | |
5137 | (setq ada-last-which-function-line line | |
5138 | ada-last-which-function-subprog found) | |
5139 | found)))) | |
4cc7e498 GM |
5140 | |
5141 | (defun ada-ff-other-window () | |
5142 | "Find other file in other window using `ff-find-other-file'." | |
5143 | (interactive) | |
5144 | (and (fboundp 'ff-find-other-file) | |
5145 | (ff-find-other-file t))) | |
5146 | ||
7749c1a8 | 5147 | (defun ada-set-point-accordingly () |
f70b58b0 | 5148 | "Move to the function declaration that was set by `ff-which-function-are-we-in'." |
7749c1a8 GM |
5149 | (if ff-function-name |
5150 | (progn | |
f70b58b0 JB |
5151 | (goto-char (point-min)) |
5152 | (unless (ada-search-ignore-string-comment | |
5153 | (concat ff-function-name "\\b") nil) | |
5154 | (goto-char (point-min)))))) | |
f139ce87 | 5155 | |
4cc7e498 | 5156 | (defun ada-get-body-name (&optional spec-name) |
6d533a6e JB |
5157 | "Return the file name for the body of SPEC-NAME. |
5158 | If SPEC-NAME is nil, return the body for the current package. | |
97a62f83 | 5159 | Return nil if no body was found." |
4cc7e498 GM |
5160 | (interactive) |
5161 | ||
36144b26 | 5162 | (unless spec-name (setq spec-name (buffer-file-name))) |
4cc7e498 | 5163 | |
4607c7f4 SM |
5164 | ;; Remove the spec extension. We can not simply remove the file extension, |
5165 | ;; but we need to take into account the specific non-GNAT extensions that the | |
5166 | ;; user might have specified. | |
5167 | ||
5168 | (let ((suffixes ada-spec-suffixes) | |
5169 | end) | |
5170 | (while suffixes | |
5171 | (setq end (- (length spec-name) (length (car suffixes)))) | |
5172 | (if (string-equal (car suffixes) (substring spec-name end)) | |
5173 | (setq spec-name (substring spec-name 0 end))) | |
5174 | (setq suffixes (cdr suffixes)))) | |
5175 | ||
4cc7e498 | 5176 | ;; If find-file.el was available, use its functions |
6f9a2614 JB |
5177 | (if (fboundp 'ff-get-file-name) |
5178 | (ff-get-file-name ada-search-directories-internal | |
f70b58b0 JB |
5179 | (ada-make-filename-from-adaname |
5180 | (file-name-nondirectory | |
5181 | (file-name-sans-extension spec-name))) | |
5182 | ada-body-suffixes) | |
4cc7e498 GM |
5183 | ;; Else emulate it very simply |
5184 | (concat (ada-make-filename-from-adaname | |
f70b58b0 JB |
5185 | (file-name-nondirectory |
5186 | (file-name-sans-extension spec-name))) | |
5187 | ".adb"))) | |
4cc7e498 | 5188 | |
655880d2 GM |
5189 | \f |
5190 | ;; --------------------------------------------------- | |
5191 | ;; support for font-lock.el | |
cadd3658 RS |
5192 | ;; Strings are a real pain in Ada because a single quote character is |
5193 | ;; overloaded as a string quote and type/instance delimiter. By default, a | |
5194 | ;; single quote is given punctuation syntax in `ada-mode-syntax-table'. | |
5195 | ;; So, for Font Lock mode purposes, we mark single quotes as having string | |
655880d2 GM |
5196 | ;; syntax when the gods that created Ada determine them to be. |
5197 | ;; | |
5198 | ;; This only works in Emacs. See the comments before the grammar functions | |
5199 | ;; at the beginning of this file for how this is done with XEmacs. | |
5200 | ;; ---------------------------------------------------- | |
cadd3658 RS |
5201 | |
5202 | (defconst ada-font-lock-syntactic-keywords | |
5203 | ;; Mark single quotes as having string quote syntax in 'c' instances. | |
ed3b86bf SM |
5204 | ;; We used to explicitly avoid ''' as a special case for fear the buffer |
5205 | ;; be highlighted as a string, but it seems this fear is unfounded. | |
d5875b25 JB |
5206 | ;; |
5207 | ;; This sets the properties of the characters, so that ada-in-string-p | |
5208 | ;; correctly handles '"' too... | |
ed3b86bf | 5209 | '(("[^a-zA-Z0-9)]\\('\\)[^\n]\\('\\)" (1 (7 . ?')) (2 (7 . ?'))) |
bef83666 | 5210 | ("^[ \t]*\\(#\\(if\\|else\\|elsif\\|end\\)\\)" (1 (11 . ?\n))))) |
972579f9 | 5211 | |
7749c1a8 GM |
5212 | (defvar ada-font-lock-keywords |
5213 | (eval-when-compile | |
5214 | (list | |
5215 | ;; | |
5216 | ;; handle "type T is access function return S;" | |
5217 | (list "\\<\\(function[ \t]+return\\)\\>" '(1 font-lock-keyword-face) ) | |
cadd3658 | 5218 | |
7749c1a8 GM |
5219 | ;; preprocessor line |
5220 | (list "^[ \t]*\\(#.*\n\\)" '(1 font-lock-type-face t)) | |
cadd3658 | 5221 | |
7749c1a8 GM |
5222 | ;; |
5223 | ;; accept, entry, function, package (body), protected (body|type), | |
5224 | ;; pragma, procedure, task (body) plus name. | |
5225 | (list (concat | |
f70b58b0 JB |
5226 | "\\<\\(" |
5227 | "accept\\|" | |
5228 | "entry\\|" | |
5229 | "function\\|" | |
5230 | "package[ \t]+body\\|" | |
5231 | "package\\|" | |
5232 | "pragma\\|" | |
5233 | "procedure\\|" | |
5234 | "protected[ \t]+body\\|" | |
5235 | "protected[ \t]+type\\|" | |
5236 | "protected\\|" | |
5237 | "task[ \t]+body\\|" | |
5238 | "task[ \t]+type\\|" | |
5239 | "task" | |
5240 | "\\)\\>[ \t]*" | |
5241 | "\\(\\sw+\\(\\.\\sw*\\)*\\)?") | |
5242 | '(1 font-lock-keyword-face) '(2 font-lock-function-name-face nil t)) | |
7749c1a8 GM |
5243 | ;; |
5244 | ;; Optional keywords followed by a type name. | |
5245 | (list (concat ; ":[ \t]*" | |
f70b58b0 JB |
5246 | "\\<\\(access[ \t]+all\\|access[ \t]+constant\\|access\\|constant\\|in[ \t]+reverse\\|\\|in[ \t]+out\\|in\\|out\\)\\>" |
5247 | "[ \t]*" | |
5248 | "\\(\\sw+\\(\\.\\sw*\\)*\\)?") | |
5249 | '(1 font-lock-keyword-face nil t) '(2 font-lock-type-face nil t)) | |
cadd3658 | 5250 | |
7749c1a8 GM |
5251 | ;; |
5252 | ;; Main keywords, except those treated specially below. | |
5253 | (concat "\\<" | |
f70b58b0 JB |
5254 | (regexp-opt |
5255 | '("abort" "abs" "abstract" "accept" "access" "aliased" "all" | |
5256 | "and" "array" "at" "begin" "case" "declare" "delay" "delta" | |
5257 | "digits" "do" "else" "elsif" "entry" "exception" "exit" "for" | |
dc786b8a JB |
5258 | "generic" "if" "in" "interface" "is" "limited" "loop" "mod" "not" |
5259 | "null" "or" "others" "overriding" "private" "protected" "raise" | |
f70b58b0 | 5260 | "range" "record" "rem" "renames" "requeue" "return" "reverse" |
dc786b8a | 5261 | "select" "separate" "synchronized" "tagged" "task" "terminate" |
d5875b25 | 5262 | "then" "until" "when" "while" "with" "xor") t) |
f70b58b0 | 5263 | "\\>") |
7749c1a8 GM |
5264 | ;; |
5265 | ;; Anything following end and not already fontified is a body name. | |
5266 | '("\\<\\(end\\)\\>\\([ \t]+\\)?\\(\\(\\sw\\|[_.]\\)+\\)?" | |
5267 | (1 font-lock-keyword-face) (3 font-lock-function-name-face nil t)) | |
5268 | ;; | |
5269 | ;; Keywords followed by a type or function name. | |
5270 | (list (concat "\\<\\(" | |
f70b58b0 JB |
5271 | "new\\|of\\|subtype\\|type" |
5272 | "\\)\\>[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?[ \t]*\\((\\)?") | |
5273 | '(1 font-lock-keyword-face) | |
5274 | '(2 (if (match-beginning 4) | |
5275 | font-lock-function-name-face | |
5276 | font-lock-type-face) nil t)) | |
7749c1a8 GM |
5277 | ;; |
5278 | ;; Keywords followed by a (comma separated list of) reference. | |
4607c7f4 SM |
5279 | ;; Note that font-lock only works on single lines, thus we can not |
5280 | ;; correctly highlight a with_clause that spans multiple lines. | |
5281 | (list (concat "\\<\\(goto\\|raise\\|use\\|with\\)" | |
f70b58b0 JB |
5282 | "[ \t]+\\([a-zA-Z0-9_., \t]+\\)\\W") |
5283 | '(1 font-lock-keyword-face) '(2 font-lock-reference-face nil t)) | |
f7a80909 | 5284 | |
7749c1a8 GM |
5285 | ;; |
5286 | ;; Goto tags. | |
5287 | '("<<\\(\\sw+\\)>>" 1 font-lock-reference-face) | |
4607c7f4 SM |
5288 | |
5289 | ;; Highlight based-numbers (R. Reagan <robin-reply@reagans.org>) | |
5290 | (list "\\([0-9]+#[0-9a-fA-F_]+#\\)" '(1 font-lock-constant-face t)) | |
5291 | ||
5292 | ;; Ada unnamed numerical constants | |
5293 | (list "\\W\\([-+]?[0-9._]+\\)\\>" '(1 font-lock-constant-face)) | |
a1506d29 | 5294 | |
7749c1a8 GM |
5295 | )) |
5296 | "Default expressions to highlight in Ada mode.") | |
5297 | ||
4cc7e498 | 5298 | |
655880d2 GM |
5299 | ;; --------------------------------------------------------- |
5300 | ;; Support for outline.el | |
5301 | ;; --------------------------------------------------------- | |
cadd3658 | 5302 | |
cadd3658 | 5303 | (defun ada-outline-level () |
6d533a6e | 5304 | "This is so that `current-column' DTRT in otherwise-hidden text." |
7749c1a8 | 5305 | ;; patch from Dave Love <fx@gnu.org> |
b073b657 DL |
5306 | (let (buffer-invisibility-spec) |
5307 | (save-excursion | |
7749c1a8 | 5308 | (back-to-indentation) |
b073b657 | 5309 | (current-column)))) |
972579f9 | 5310 | |
f7a80909 JB |
5311 | ;; --------------------------------------------------------- |
5312 | ;; Support for narrow-to-region | |
5313 | ;; --------------------------------------------------------- | |
5314 | ||
5315 | (defun ada-narrow-to-defun (&optional arg) | |
6d533a6e | 5316 | "Make text outside current subprogram invisible. |
f7a80909 JB |
5317 | The subprogram visible is the one that contains or follow point. |
5318 | Optional ARG is ignored. | |
97a62f83 | 5319 | Use \\[widen] to go back to the full visibility for the buffer." |
f7a80909 JB |
5320 | |
5321 | (interactive) | |
5322 | (save-excursion | |
5323 | (let (end) | |
5324 | (widen) | |
5325 | (forward-line 1) | |
5326 | (ada-previous-procedure) | |
5327 | ||
5328 | (save-excursion | |
f70b58b0 JB |
5329 | (beginning-of-line) |
5330 | (setq end (point))) | |
f7a80909 JB |
5331 | |
5332 | (ada-move-to-end) | |
5333 | (end-of-line) | |
5334 | (narrow-to-region end (point)) | |
5335 | (message | |
5336 | "Use M-x widen to get back to full visibility in the buffer")))) | |
5337 | ||
655880d2 GM |
5338 | ;; --------------------------------------------------------- |
5339 | ;; Automatic generation of code | |
0347188a | 5340 | ;; The Ada mode has a set of function to automatically generate a subprogram |
655880d2 GM |
5341 | ;; or package body from its spec. |
5342 | ;; These function only use a primary and basic algorithm, this could use a | |
5343 | ;; lot of improvement. | |
5344 | ;; When the user is using GNAT, we rather use gnatstub to generate an accurate | |
5345 | ;; body. | |
5346 | ;; ---------------------------------------------------------- | |
972579f9 | 5347 | |
f139ce87 | 5348 | (defun ada-gen-treat-proc (match) |
655880d2 | 5349 | "Make dummy body of a procedure/function specification. |
6d533a6e JB |
5350 | MATCH is a cons cell containing the start and end locations of the last search |
5351 | for `ada-procedure-start-regexp'." | |
f139ce87 | 5352 | (goto-char (car match)) |
7749c1a8 | 5353 | (let (func-found procname functype) |
f139ce87 | 5354 | (cond |
7749c1a8 | 5355 | ((or (looking-at "^[ \t]*procedure") |
f70b58b0 | 5356 | (setq func-found (looking-at "^[ \t]*function"))) |
f139ce87 | 5357 | ;; treat it as a proc/func |
7749c1a8 | 5358 | (forward-word 2) |
f139ce87 | 5359 | (forward-word -1) |
36144b26 | 5360 | (setq procname (buffer-substring (point) (cdr match))) ; store proc name |
7749c1a8 GM |
5361 | |
5362 | ;; goto end of procname | |
5363 | (goto-char (cdr match)) | |
5364 | ||
5365 | ;; skip over parameterlist | |
5366 | (unless (looking-at "[ \t\n]*\\(;\\|return\\)") | |
f70b58b0 | 5367 | (forward-sexp)) |
7749c1a8 GM |
5368 | |
5369 | ;; if function, skip over 'return' and result type. | |
f139ce87 | 5370 | (if func-found |
f70b58b0 JB |
5371 | (progn |
5372 | (forward-word 1) | |
5373 | (skip-chars-forward " \t\n") | |
5374 | (setq functype (buffer-substring (point) | |
5375 | (progn | |
5376 | (skip-chars-forward | |
5377 | "a-zA-Z0-9_\.") | |
5378 | (point)))))) | |
7749c1a8 GM |
5379 | ;; look for next non WS |
5380 | (cond | |
5381 | ((looking-at "[ \t]*;") | |
f70b58b0 JB |
5382 | (delete-region (match-beginning 0) (match-end 0));; delete the ';' |
5383 | (ada-indent-newline-indent) | |
5384 | (insert "is") | |
5385 | (ada-indent-newline-indent) | |
5386 | (if func-found | |
5387 | (progn | |
5388 | (insert "Result : " functype ";") | |
5389 | (ada-indent-newline-indent))) | |
5390 | (insert "begin") | |
5391 | (ada-indent-newline-indent) | |
5392 | (if func-found | |
5393 | (insert "return Result;") | |
5394 | (insert "null;")) | |
5395 | (ada-indent-newline-indent) | |
5396 | (insert "end " procname ";") | |
5397 | (ada-indent-newline-indent) | |
5398 | ) | |
d5875b25 | 5399 | |
7749c1a8 | 5400 | ((looking-at "[ \t\n]*is") |
f70b58b0 JB |
5401 | ;; do nothing |
5402 | ) | |
d5875b25 | 5403 | |
7749c1a8 | 5404 | ((looking-at "[ \t\n]*rename") |
f70b58b0 JB |
5405 | ;; do nothing |
5406 | ) | |
d5875b25 | 5407 | |
7749c1a8 | 5408 | (t |
f70b58b0 | 5409 | (message "unknown syntax")))) |
f139ce87 | 5410 | (t |
7749c1a8 | 5411 | (if (looking-at "^[ \t]*task") |
f70b58b0 JB |
5412 | (progn |
5413 | (message "Task conversion is not yet implemented") | |
5414 | (forward-word 2) | |
5415 | (if (looking-at "[ \t]*;") | |
5416 | (forward-line) | |
5417 | (ada-move-to-end)) | |
5418 | )))))) | |
f139ce87 KH |
5419 | |
5420 | (defun ada-make-body () | |
5421 | "Create an Ada package body in the current buffer. | |
dc786b8a | 5422 | The spec must be the previously visited buffer. |
f7eb6f23 | 5423 | This function typically is to be hooked into `ff-file-created-hook'." |
f139ce87 | 5424 | (delete-region (point-min) (point-max)) |
877dde9e JB |
5425 | (insert-buffer-substring (car (cdr (buffer-list)))) |
5426 | (goto-char (point-min)) | |
f139ce87 KH |
5427 | (ada-mode) |
5428 | ||
7749c1a8 | 5429 | (let (found ada-procedure-or-package-start-regexp) |
36144b26 | 5430 | (if (setq found |
f70b58b0 JB |
5431 | (ada-search-ignore-string-comment ada-package-start-regexp nil)) |
5432 | (progn (goto-char (cdr found)) | |
5433 | (insert " body") | |
5434 | ) | |
972579f9 | 5435 | (error "No package")) |
f139ce87 | 5436 | |
36144b26 | 5437 | (setq ada-procedure-or-package-start-regexp |
f70b58b0 JB |
5438 | (concat ada-procedure-start-regexp |
5439 | "\\|" | |
5440 | ada-package-start-regexp)) | |
972579f9 | 5441 | |
36144b26 | 5442 | (while (setq found |
f70b58b0 JB |
5443 | (ada-search-ignore-string-comment |
5444 | ada-procedure-or-package-start-regexp nil)) | |
7749c1a8 | 5445 | (progn |
f70b58b0 JB |
5446 | (goto-char (car found)) |
5447 | (if (looking-at ada-package-start-regexp) | |
5448 | (progn (goto-char (cdr found)) | |
5449 | (insert " body")) | |
5450 | (ada-gen-treat-proc found)))))) | |
7749c1a8 | 5451 | |
4cc7e498 | 5452 | |
7749c1a8 | 5453 | (defun ada-make-subprogram-body () |
dc786b8a | 5454 | "Create a dummy subprogram body in package body file from spec surrounding point." |
7749c1a8 GM |
5455 | (interactive) |
5456 | (let* ((found (re-search-backward ada-procedure-start-regexp nil t)) | |
f70b58b0 JB |
5457 | (spec (match-beginning 0)) |
5458 | body-file) | |
7749c1a8 | 5459 | (if found |
f70b58b0 JB |
5460 | (progn |
5461 | (goto-char spec) | |
5462 | (if (and (re-search-forward "(\\|;" nil t) | |
5463 | (= (char-before) ?\()) | |
5464 | (progn | |
5465 | (ada-search-ignore-string-comment ")" nil) | |
5466 | (ada-search-ignore-string-comment ";" nil))) | |
5467 | (setq spec (buffer-substring spec (point))) | |
5468 | ||
5469 | ;; If find-file.el was available, use its functions | |
5470 | (setq body-file (ada-get-body-name)) | |
5471 | (if body-file | |
5472 | (find-file body-file) | |
5473 | (error "No body found for the package. Create it first")) | |
5474 | ||
5475 | (save-restriction | |
5476 | (widen) | |
5477 | (goto-char (point-max)) | |
5478 | (forward-comment -10000) | |
5479 | (re-search-backward "\\<end\\>" nil t) | |
5480 | ;; Move to the beginning of the elaboration part, if any | |
5481 | (re-search-backward "^begin" nil t) | |
5482 | (newline) | |
5483 | (forward-char -1) | |
5484 | (insert spec) | |
5485 | (re-search-backward ada-procedure-start-regexp nil t) | |
5486 | (ada-gen-treat-proc (cons (match-beginning 0) (match-end 0))) | |
5487 | )) | |
7749c1a8 GM |
5488 | (error "Not in subprogram spec")))) |
5489 | ||
655880d2 GM |
5490 | ;; -------------------------------------------------------- |
5491 | ;; Global initializations | |
5492 | ;; -------------------------------------------------------- | |
5493 | ||
7749c1a8 GM |
5494 | ;; Create the keymap once and for all. If we do that in ada-mode, |
5495 | ;; the keys changed in the user's .emacs have to be modified | |
5496 | ;; every time | |
5497 | (ada-create-keymap) | |
5498 | (ada-create-menu) | |
5499 | ||
5500 | ;; Create the syntax tables, but do not activate them | |
5501 | (ada-create-syntax-table) | |
5502 | ||
5503 | ;; Add the default extensions (and set up speedbar) | |
5504 | (ada-add-extensions ".ads" ".adb") | |
5505 | ;; This two files are generated by GNAT when running with -gnatD | |
5506 | (if (equal ada-which-compiler 'gnat) | |
5507 | (ada-add-extensions ".ads.dg" ".adb.dg")) | |
5508 | ||
5509 | ;; Read the special cases for exceptions | |
5510 | (ada-case-read-exceptions) | |
5511 | ||
0347188a | 5512 | ;; Setup auto-loading of the other Ada mode files. |
dc786b8a JB |
5513 | (autoload 'ada-change-prj "ada-xref" nil t) |
5514 | (autoload 'ada-check-current "ada-xref" nil t) | |
5515 | (autoload 'ada-compile-application "ada-xref" nil t) | |
5516 | (autoload 'ada-compile-current "ada-xref" nil t) | |
5517 | (autoload 'ada-complete-identifier "ada-xref" nil t) | |
5518 | (autoload 'ada-find-file "ada-xref" nil t) | |
5519 | (autoload 'ada-find-any-references "ada-xref" nil t) | |
5520 | (autoload 'ada-find-src-file-in-dir "ada-xref" nil t) | |
5521 | (autoload 'ada-find-local-references "ada-xref" nil t) | |
5522 | (autoload 'ada-find-references "ada-xref" nil t) | |
5523 | (autoload 'ada-gdb-application "ada-xref" nil t) | |
5524 | (autoload 'ada-goto-declaration "ada-xref" nil t) | |
5525 | (autoload 'ada-goto-declaration-other-frame "ada-xref" nil t) | |
5526 | (autoload 'ada-goto-parent "ada-xref" nil t) | |
5527 | (autoload 'ada-make-body-gnatstub "ada-xref" nil t) | |
5528 | (autoload 'ada-point-and-xref "ada-xref" nil t) | |
5529 | (autoload 'ada-reread-prj-file "ada-xref" nil t) | |
5530 | (autoload 'ada-run-application "ada-xref" nil t) | |
dc786b8a JB |
5531 | (autoload 'ada-set-default-project-file "ada-xref" nil t) |
5532 | (autoload 'ada-xref-goto-previous-reference "ada-xref" nil t) | |
d4ee31d3 JB |
5533 | (autoload 'ada-set-main-compile-application "ada-xref" nil t) |
5534 | (autoload 'ada-show-current-main "ada-xref" nil t) | |
dc786b8a JB |
5535 | |
5536 | (autoload 'ada-customize "ada-prj" nil t) | |
5537 | (autoload 'ada-prj-edit "ada-prj" nil t) | |
5538 | (autoload 'ada-prj-new "ada-prj" nil t) | |
5539 | (autoload 'ada-prj-save "ada-prj" nil t) | |
f7a80909 JB |
5540 | |
5541 | (autoload 'ada-array "ada-stmt" nil t) | |
5542 | (autoload 'ada-case "ada-stmt" nil t) | |
5543 | (autoload 'ada-declare-block "ada-stmt" nil t) | |
5544 | (autoload 'ada-else "ada-stmt" nil t) | |
5545 | (autoload 'ada-elsif "ada-stmt" nil t) | |
5546 | (autoload 'ada-exception "ada-stmt" nil t) | |
5547 | (autoload 'ada-exception-block "ada-stmt" nil t) | |
5548 | (autoload 'ada-exit "ada-stmt" nil t) | |
5549 | (autoload 'ada-for-loop "ada-stmt" nil t) | |
5550 | (autoload 'ada-function-spec "ada-stmt" nil t) | |
5551 | (autoload 'ada-header "ada-stmt" nil t) | |
5552 | (autoload 'ada-if "ada-stmt" nil t) | |
5553 | (autoload 'ada-loop "ada-stmt" nil t) | |
5554 | (autoload 'ada-package-body "ada-stmt" nil t) | |
5555 | (autoload 'ada-package-spec "ada-stmt" nil t) | |
5556 | (autoload 'ada-private "ada-stmt" nil t) | |
5557 | (autoload 'ada-procedure-spec "ada-stmt" nil t) | |
5558 | (autoload 'ada-record "ada-stmt" nil t) | |
5559 | (autoload 'ada-subprogram-body "ada-stmt" nil t) | |
5560 | (autoload 'ada-subtype "ada-stmt" nil t) | |
5561 | (autoload 'ada-tabsize "ada-stmt" nil t) | |
5562 | (autoload 'ada-task-body "ada-stmt" nil t) | |
5563 | (autoload 'ada-task-spec "ada-stmt" nil t) | |
5564 | (autoload 'ada-type "ada-stmt" nil t) | |
5565 | (autoload 'ada-use "ada-stmt" nil t) | |
5566 | (autoload 'ada-when "ada-stmt" nil t) | |
5567 | (autoload 'ada-while-loop "ada-stmt" nil t) | |
5568 | (autoload 'ada-with "ada-stmt" nil t) | |
972579f9 | 5569 | |
7749c1a8 | 5570 | ;;; provide ourselves |
972579f9 RS |
5571 | (provide 'ada-mode) |
5572 | ||
23b747d1 | 5573 | ;; arch-tag: 1b7d45ec-1698-43b5-8d4a-e479ea023270 |
a681b2a1 | 5574 | ;;; ada-mode.el ends here |