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