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