Mercurial > emacs
annotate lisp/progmodes/ada-mode.el @ 11002:ff115809a39e
(Fash): Fix previous change.
author | Richard M. Stallman <rms@gnu.org> |
---|---|
date | Tue, 14 Mar 1995 18:38:28 +0000 |
parents | 7c5fe757600b |
children | 394f205af26d |
rev | line source |
---|---|
10705 | 1 ;;; ada-mode.el - An Emacs major-mode for editing Ada source. |
2 ;;; Copyright (C) 1994 Free Software Foundation, Inc. | |
3 | |
4 ;;; Authors: Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de> | |
5 ;;; Rolf Ebert <ebert@inf.enst.fr> | |
6 | |
7 ;;; This file is part of GNU Emacs. | |
8 | |
9 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
10 ;; it under the terms of the GNU General Public License as published by | |
11 ;; the Free Software Foundation; either version 2, or (at your option) | |
12 ;; any later version. | |
13 | |
14 ;; GNU Emacs is distributed in the hope that it will be useful, | |
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 ;; GNU General Public License for more details. | |
18 | |
19 ;; You should have received a copy of the GNU General Public License | |
20 ;; along with GNU Emacs; see the file COPYING. If not, write to | |
21 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
22 | |
23 ;;; This mode is a complete rewrite of a major mode for editing Ada 83 | |
24 ;;; and Ada 94 source code under Emacs-19. It contains completely new | |
25 ;;; indenting code and support for code browsing (see ada-xref). | |
26 | |
27 | |
28 ;;; USAGE | |
29 ;;; ===== | |
30 ;;; If you have modified your startup file as described above, emacs | |
31 ;;; should enter ada-mode when you load an ada source into emacs. | |
32 ;;; | |
33 ;;; When you have entered ada-mode, you may get more info by pressing | |
34 ;;; C-h m. You may also get online help describing various functions by: | |
35 ;;; C-h d <Name of function you want described> | |
36 | |
37 | |
38 ;;; HISTORY | |
39 ;;; ======= | |
40 ;;; The first Ada mode for GNU Emacs was written by V. Bowman in | |
41 ;;; 1985. He based his work on the already existing Modula-2 mode. The | |
42 ;;; file is called ada.el and is currently distributed with Emacs. | |
43 ;;; | |
44 ;;; Lynn Slater wrote an extensive Ada mode in 1989. It consisted of | |
45 ;;; several files with support for dired commands and other nice | |
46 ;;; things. It is currently available from the PAL | |
47 ;;; (wuarchive.wustl.edu:/languages/ada) as ada-mode-1.06a.tar.Z. | |
48 ;;; | |
49 ;;; The probably very first Ada mode (called electric-ada.el) was | |
50 ;;; written by Steven D. Litvintchouk and Steven M. Rosen for the | |
51 ;;; Gosling Emacs. L. Slater based his development on ada.el and | |
52 ;;; electric-ada.el. | |
53 ;;; | |
54 ;;; The current Ada mode is a complete rewrite by M. Heritsch and | |
55 ;;; R. Ebert. Some ideas from the ada-mode mailing list have been | |
56 ;;; added. Some of the functionality of L. Slater's mode has not | |
57 ;;; (yet) been recoded in this new mode. Perhaps you prefer sticking | |
58 ;;; to his version. | |
59 | |
60 | |
61 ;;; KNOWN BUGS / BUGREPORTS | |
62 ;;; ======================= | |
63 ;;; | |
64 ;;; In the presence of comments and/or incorrect syntax | |
65 ;;; ada-format-paramlist produces weird results. | |
66 ;;; | |
67 ;;; Indentation is sometimes wrong at the very beginning of the buffer. | |
68 ;;; So please try it on different locations. If it's still wrong then | |
69 ;;; report the bug. | |
70 ;;; | |
71 ;;; At the moment the browsing functions are limited to the use of the | |
72 ;;; separate packages "find-file.el" and "ada-xref.el" (ada-xref.el is | |
73 ;;; only for GNAT users). | |
74 ;;; | |
75 ;;; indenting of some tasking constructs is not yet supported. | |
76 ;;; | |
77 ;;; `reformat-region' sometimes generates some weird indentation. | |
78 ;;; | |
79 ;;;> I have the following suggestions for the function template: 1) I | |
80 ;;;> don't want it automatically assigning it a name for the return variable. I | |
81 ;;;> never want it to be called "Result" because that is nondescriptive. If you | |
82 ;;;> must define a variable, give me the ability to specify its name. | |
83 ;;;> | |
84 ;;;> 2) You do not provide a type for variable 'Result'. Its type is the same | |
85 ;;;> as the function's return type, which the template knows, so why force me | |
86 ;;;> to type it in? | |
87 ;;;> | |
88 | |
89 ;;;As alwyas, different users have different tastes. | |
90 ;;;It would be nice if one could configure such layout details separately | |
91 ;;;without patching the LISP code. Maybe the metalanguage used in ada-stmt.el | |
92 ;;;could be taken even further, providing the user with some nice syntax | |
93 ;;;for describing layout. Then my own hacks would survive the next | |
94 ;;;update of the package :-) | |
95 | |
96 ;;;By the way, there are som more quirks: | |
97 | |
98 ;;;1) text entered in prompt mode (*) is not converted to upper case (I have | |
99 ;;; choosen upper case for indentifiers). | |
100 ;;; (*) I would like to suggest the term "template code" instead of | |
101 ;;; "pseudo code". | |
102 | |
103 ;;; There are quite a few problems in the crossreferencing part. These | |
104 ;;; are partly due to errors in gnatf. One of the major bugs in | |
105 ;;; ada-xref is, that we do not wait for gnatf to rebuild the xref file. | |
106 ;;; We start the job, but do not wait for finishing. | |
107 | |
108 | |
109 ;;; LCD Archive Entry: | |
110 ;;; ada-mode|Rolf Ebert|<ebert@inf.enst.fr> | |
111 ;;; |Major-mode for Ada | |
10880
7c5fe757600b
Use font-lock-maximum-decoration when setting ada-font-lock-keywords
Simon Marshall <simon@gnu.org>
parents:
10707
diff
changeset
|
112 ;;; |$Date: 1995/02/09 00:17:31 $|$Revision: 1.2 $| |
10705 | 113 |
114 | |
10880
7c5fe757600b
Use font-lock-maximum-decoration when setting ada-font-lock-keywords
Simon Marshall <simon@gnu.org>
parents:
10707
diff
changeset
|
115 (defconst ada-mode-version (substring "$Revision: 1.2 $" 11 -2) |
7c5fe757600b
Use font-lock-maximum-decoration when setting ada-font-lock-keywords
Simon Marshall <simon@gnu.org>
parents:
10707
diff
changeset
|
116 "$Id: ada-mode.el,v 1.2 1995/02/09 00:17:31 rms Exp simon $ |
10705 | 117 |
118 Report bugs to: Rolf Ebert <ebert@inf.enst.fr>") | |
119 | |
120 | |
121 ;;;-------------------- | |
122 ;;; USER OPTIONS | |
123 ;;;-------------------- | |
124 | |
125 ;; ---- configure indentation | |
126 | |
127 (defvar ada-indent 3 | |
128 "*Defines the size of Ada indentation.") | |
129 | |
130 (defvar ada-broken-indent 2 | |
131 "*# of columns to indent the continuation of a broken line.") | |
132 | |
133 (defvar ada-label-indent -4 | |
134 "*# of columns to indent a label.") | |
135 | |
136 (defvar ada-stmt-end-indent 0 | |
137 "*# of columns to indent a statement end keyword in a separate line. | |
138 Examples are 'is', 'loop', 'record', ...") | |
139 | |
140 (defvar ada-when-indent 3 | |
141 "*Defines the indentation for 'when' relative to 'exception' or 'case'.") | |
142 | |
143 (defvar ada-indent-record-rel-type 3 | |
144 "*Defines the indentation for 'record' relative to 'type' or 'use'.") | |
145 | |
146 (defvar ada-indent-comment-as-code t | |
147 "*If non-nil, comment-lines get indented as ada-code.") | |
148 | |
149 (defvar ada-indent-is-separate t | |
150 "*If non-nil, 'is separate' or 'is abstract' on a separate line are | |
151 indented.") | |
152 | |
153 (defvar ada-indent-to-open-paren t | |
154 "*If non-nil, following lines get indented according to the innermost | |
155 open parenthesis.") | |
156 | |
157 (defvar ada-search-paren-line-count-limit 5 | |
158 "*Search that many non-blank non-comment lines for an open parenthesis. | |
159 Values higher than about 5 horribly slow down the indenting.") | |
160 | |
161 | |
162 ;; ---- other user options | |
163 | |
164 (defvar ada-tab-policy 'indent-auto | |
165 "*Control behaviour of the TAB key. | |
166 Must be one of 'indent-rigidly, 'indent-auto, 'gei, 'indent-af or 'always-tab. | |
167 | |
168 'indent-rigidly : always adds ada-indent blanks at the beginning of the line. | |
169 'indent-auto : use indentation functions in this file. | |
170 'gei : use David K}gedal's Generic Indentation Engine. | |
171 'indent-af : use Gary E. Barnes' ada-format.el | |
172 'always-tab : do indent-relative.") | |
173 | |
174 (defvar ada-move-to-declaration nil | |
175 "*If non-nil, ada-move-to-start moves point to the subprog-declaration, | |
176 not to 'begin'.") | |
177 | |
178 (defvar ada-spec-suffix ".ads" | |
179 "*Suffix of Ada specification files.") | |
180 | |
181 (defvar ada-body-suffix ".adb" | |
182 "*Suffix of Ada body files.") | |
183 | |
184 (defvar ada-language-version 'ada94 | |
185 "*Do we program in 'ada83 or 'ada94?") | |
186 | |
187 (defvar ada-case-keyword 'downcase-word | |
188 "*downcase-word, upcase-word, ada-loose-case-word or capitalize-word | |
189 to adjust ada keywords case.") | |
190 | |
191 (defvar ada-case-identifier 'ada-loose-case-word | |
192 "*downcase-word, upcase-word, ada-loose-case-word or capitalize-word | |
193 to adjust ada identifier case.") | |
194 | |
195 (defvar ada-auto-case t | |
196 "*Non-nil automatically changes casing of preceeding word while typing. | |
197 Casing is done according to ada-case-keyword and ada-case-identifier.") | |
198 | |
199 (defvar ada-clean-buffer-before-saving nil | |
200 "*If non-nil, remove-trailing-spaces and untabify buffer before saving.") | |
201 | |
202 (defvar ada-mode-hook nil | |
203 "*List of functions to call when Ada Mode is invoked. | |
204 This is a good place to add Ada environment specific bindings.") | |
205 | |
206 (defvar ada-external-pretty-print-program "aimap" | |
207 "*External pretty printer to call from within Ada Mode.") | |
208 | |
209 (defvar ada-tmp-directory "/tmp/" | |
210 "*Directory to store the temporary file for the Ada pretty printer.") | |
211 | |
212 (defvar ada-fill-comment-prefix "-- " | |
213 "*This is inserted in the first columns when filling a comment paragraph.") | |
214 | |
215 (defvar ada-fill-comment-postfix " --" | |
216 "*This is inserted at the end of each line when filling a comment paragraph | |
217 with ada-fill-comment-paragraph postfix.") | |
218 | |
219 (defvar ada-krunch-args "250" | |
220 "*Argument of gnatk8, a string containing the max number of characters. | |
221 Set to a big number, if you dont use crunched filenames.") | |
222 | |
223 ;;; ---- end of user configurable variables | |
224 | |
225 | |
226 (defvar ada-mode-abbrev-table nil | |
227 "Abbrev table used in Ada mode.") | |
228 (define-abbrev-table 'ada-mode-abbrev-table ()) | |
229 | |
230 (defvar ada-mode-map () | |
231 "Local keymap used for ada-mode.") | |
232 | |
233 (defvar ada-mode-syntax-table nil | |
234 "Syntax table to be used for editing Ada source code.") | |
235 | |
236 (defconst ada-83-keywords | |
237 "\\<\\(abort\\|abs\\|accept\\|access\\|all\\|and\\|array\\|\ | |
238 at\\|begin\\|body\\|case\\|constant\\|declare\\|delay\\|delta\\|\ | |
239 digits\\|do\\|else\\|elsif\\|end\\|entry\\|exception\\|exit\\|for\\|\ | |
240 function\\|generic\\|goto\\|if\\|in\\|is\\|limited\\|loop\\|mod\\|\ | |
241 new\\|not\\|null\\|of\\|or\\|others\\|out\\|package\\|pragma\\|\ | |
242 private\\|procedure\\|raise\\|range\\|record\\|rem\\|renames\\|\ | |
243 return\\|reverse\\|select\\|separate\\|subtype\\|task\\|terminate\\|\ | |
244 then\\|type\\|use\\|when\\|while\\|with\\|xor\\)\\>" | |
245 "regular expression for looking at Ada83 keywords.") | |
246 | |
247 (defconst ada-94-keywords | |
248 "\\<\\(abort\\|abs\\|abstract\\|accept\\|access\\|aliased\\|\ | |
249 all\\|and\\|array\\|at\\|begin\\|body\\|case\\|constant\\|declare\\|\ | |
250 delay\\|delta\\|digits\\|do\\|else\\|elsif\\|end\\|entry\\|\ | |
251 exception\\|exit\\|for\\|function\\|generic\\|goto\\|if\\|in\\|\ | |
252 is\\|limited\\|loop\\|mod\\|new\\|not\\|null\\|of\\|or\\|others\\|\ | |
253 out\\|package\\|pragma\\|private\\|procedure\\|protected\\|raise\\|\ | |
254 range\\|record\\|rem\\|renames\\|requeue\\|return\\|reverse\\|\ | |
255 select\\|separate\\|subtype\\|tagged\\|task\\|terminate\\|then\\|\ | |
256 type\\|until\\|use\\|when\\|while\\|with\\|xor\\)\\>" | |
257 "regular expression for looking at Ad94 keywords.") | |
258 | |
259 (defvar ada-keywords ada-94-keywords | |
260 "regular expression for looking at Ada keywords.") | |
261 | |
262 (defvar ada-ret-binding nil | |
263 "Variable to save key binding of RET when casing is activated.") | |
264 | |
265 (defvar ada-lfd-binding nil | |
266 "Variable to save key binding of LFD when casing is activated.") | |
267 | |
268 ;;; ---- Regexps to find procedures/functions/packages | |
269 | |
270 (defvar ada-procedure-start-regexp | |
271 "^[ \t]*\\(procedure\\|function\\|task\\)[ \t\n]+\\([a-zA-Z0-9_\\.]+\\)" | |
272 "Regexp used to find Ada procedures/functions.") | |
273 | |
274 (defvar ada-package-start-regexp | |
275 "^[ \t]*\\(package\\)" | |
276 "Regexp used to find Ada packages") | |
277 | |
278 | |
279 ;;; ---- regexps for indentation functions | |
280 | |
281 (defvar ada-block-start-re | |
282 "\\<\\(begin\\|select\\|declare\\|private\\|or\\|generic\\|\ | |
283 exception\\|loop\\|record\\|else\\)\\>" | |
284 "Regexp for keywords starting ada-blocks.") | |
285 | |
286 (defvar ada-end-stmt-re | |
287 "\\(;\\|=>\\|\\<\\(begin\\|record\\|loop\\|select\\|do\\|\ | |
288 exception\\|declare\\|generic\\|private\\)\\>\\)" | |
289 "Regexp of possible ends for a non-broken statement. | |
290 'end' means that there has to start a new statement after these.") | |
291 | |
292 (defvar ada-loop-start-re | |
293 "\\<\\(for\\|while\\|loop\\)\\>" | |
294 "Regexp for the start of a loop.") | |
295 | |
296 (defvar ada-subprog-start-re | |
297 "\\<\\(procedure\\|function\\|task\\|accept\\)\\>" | |
298 "Regexp for the start of a subprogram.") | |
299 | |
300 | |
301 ;;;------------- | |
302 ;;; functions | |
303 ;;;------------- | |
304 | |
305 (defun ada-create-syntax-table () | |
306 "Create the syntax table for ada-mode." | |
307 ;; This syntax table is a merge of two syntax tables I found | |
308 ;; in the two ada modes in the old ada.el and the old | |
309 ;; electric-ada.el. (jsl) | |
310 ;; There still remains the problem, if the underscore '_' is a word | |
311 ;; constituent or not. (re) | |
312 ;; The Emacs doc clearly states that it is a symbol, and that is what most | |
313 ;; on the ada-mode list prefer. (re) | |
314 ;; For some functions, the syntactical meaning of '_' is temporaryly | |
315 ;; changed to 'w'. (mh) | |
316 (setq ada-mode-syntax-table (make-syntax-table)) | |
317 (set-syntax-table ada-mode-syntax-table) | |
318 | |
319 ;; define string brackets (% is alternative string bracket) | |
320 (modify-syntax-entry ?% "\"" ada-mode-syntax-table) | |
321 (modify-syntax-entry ?\" "\"" ada-mode-syntax-table) | |
322 | |
323 (modify-syntax-entry ?\# "$" ada-mode-syntax-table) | |
324 | |
325 (modify-syntax-entry ?: "." ada-mode-syntax-table) | |
326 (modify-syntax-entry ?\; "." ada-mode-syntax-table) | |
327 (modify-syntax-entry ?& "." ada-mode-syntax-table) | |
328 (modify-syntax-entry ?\| "." ada-mode-syntax-table) | |
329 (modify-syntax-entry ?+ "." ada-mode-syntax-table) | |
330 (modify-syntax-entry ?* "." ada-mode-syntax-table) | |
331 (modify-syntax-entry ?/ "." ada-mode-syntax-table) | |
332 (modify-syntax-entry ?= "." ada-mode-syntax-table) | |
333 (modify-syntax-entry ?< "." ada-mode-syntax-table) | |
334 (modify-syntax-entry ?> "." ada-mode-syntax-table) | |
335 (modify-syntax-entry ?$ "." ada-mode-syntax-table) | |
336 (modify-syntax-entry ?\[ "." ada-mode-syntax-table) | |
337 (modify-syntax-entry ?\] "." ada-mode-syntax-table) | |
338 (modify-syntax-entry ?\{ "." ada-mode-syntax-table) | |
339 (modify-syntax-entry ?\} "." ada-mode-syntax-table) | |
340 (modify-syntax-entry ?. "." ada-mode-syntax-table) | |
341 (modify-syntax-entry ?\\ "." ada-mode-syntax-table) | |
342 (modify-syntax-entry ?\' "." ada-mode-syntax-table) | |
343 | |
344 ;; a single hyphen is punctuation, but a double hyphen starts a comment | |
345 (modify-syntax-entry ?- ". 12" ada-mode-syntax-table) | |
346 | |
347 ;; and \f and \n end a comment | |
348 (modify-syntax-entry ?\f "> " ada-mode-syntax-table) | |
349 (modify-syntax-entry ?\n "> " ada-mode-syntax-table) | |
350 | |
351 ;; define what belongs in ada symbols | |
352 (modify-syntax-entry ?_ "_" ada-mode-syntax-table) | |
353 | |
354 ;; define parentheses to match | |
355 (modify-syntax-entry ?\( "()" ada-mode-syntax-table) | |
356 (modify-syntax-entry ?\) ")(" ada-mode-syntax-table) | |
357 ) | |
358 | |
359 | |
10707 | 360 ;;;###autoload |
10705 | 361 (defun ada-mode () |
362 "Ada Mode is the major mode for editing Ada code. | |
363 | |
364 Bindings are as follows: (Note: 'LFD' is control-j.) | |
365 | |
366 Indent line '\\[ada-tab]' | |
367 Indent line, insert newline and indent the new line. '\\[newline-and-indent]' | |
368 | |
369 Re-format the parameter-list point is in '\\[ada-format-paramlist]' | |
370 Indent all lines in region '\\[ada-indent-region]' | |
371 Call external pretty printer program '\\[ada-call-pretty-printer]' | |
372 | |
373 Adjust case of identifiers and keywords in region '\\[ada-adjust-case-region]' | |
374 Adjust case of identifiers and keywords in buffer '\\[ada-adjust-case-buffer]' | |
375 | |
376 Call EXTERNAL pretty printer (if you have one) '\\[ada-call-pretty-printer]' | |
377 | |
378 Fill comment paragraph '\\[ada-fill-comment-paragraph]' | |
379 Fill comment paragraph and justify each line '\\[ada-fill-comment-paragraph-justify]' | |
380 Fill comment paragraph, justify and append postfix '\\[ada-fill-comment-paragraph-postfix]' | |
381 | |
382 Next func/proc/task '\\[ada-next-procedure]' Previous func/proc/task '\\[ada-previous-procedure]' | |
383 Next package '\\[ada-next-package]' Previous package '\\[ada-previous-package]' | |
384 | |
385 Goto matching start of current 'end ...;' '\\[ada-move-to-start]' | |
386 Goto end of current block '\\[ada-move-to-end]' | |
387 | |
388 Comments are handled using standard GNU Emacs conventions, including: | |
389 Start a comment '\\[indent-for-comment]' | |
390 Comment region '\\[comment-region]' | |
391 Uncomment region '\\[ada-uncomment-region]' | |
392 Continue comment on next line '\\[indent-new-comment-line]' | |
393 | |
394 If you use imenu.el: | |
395 Display index-menu of functions & procedures '\\[imenu]' | |
396 | |
397 If you use find-file.el: | |
398 Switch to other file (Body <-> Spec) '\\[ff-find-other-file]' | |
399 or '\\[ff-mouse-find-other-file] | |
400 Switch to other file in other window '\\[ada-ff-other-window]' | |
401 or '\\[ff-mouse-find-other-file-other-window] | |
402 | |
403 If you use ada-xref.el: | |
404 Goto declaration: '\\[ada-point-and-xref]' on the identifier | |
405 or '\\[ada-goto-declaration]' with point on the identifier | |
406 Complete identifier: '\\[ada-complete-identifier]' | |
407 Execute Gnatf: '\\[ada-gnatf-current]'" | |
408 | |
409 (interactive) | |
410 (kill-all-local-variables) | |
411 | |
412 (make-local-variable 'require-final-newline) | |
413 (setq require-final-newline t) | |
414 | |
415 (make-local-variable 'comment-start) | |
416 (setq comment-start "-- ") | |
417 | |
418 ;; comment end must be set because it may hold a wrong value if | |
419 ;; this buffer had been in another mode before. RE | |
420 (make-local-variable 'comment-end) | |
421 (setq comment-end "") | |
422 | |
423 (make-local-variable 'comment-start-skip) ;; used by autofill | |
424 (setq comment-start-skip "--+[ \t]*") | |
425 | |
426 (make-local-variable 'indent-line-function) | |
427 (setq indent-line-function 'ada-indent-current-function) | |
428 | |
429 (make-local-variable 'fill-column) | |
430 (setq fill-column 75) | |
431 | |
432 (make-local-variable 'comment-column) | |
433 (setq comment-column 40) | |
434 | |
435 (make-local-variable 'parse-sexp-ignore-comments) | |
436 (setq parse-sexp-ignore-comments t) | |
437 | |
438 (make-local-variable 'case-fold-search) | |
439 (setq case-fold-search t) | |
440 | |
10707 | 441 (make-local-variable 'fill-paragraph-function) |
442 (setq fill-paragraph-function 'ada-fill-comment-paragraph) | |
443 | |
10705 | 444 (make-local-variable 'font-lock-defaults) |
445 (setq font-lock-defaults '(ada-font-lock-keywords nil t ((?\_ . "w")))) | |
446 | |
447 (setq major-mode 'ada-mode) | |
448 (setq mode-name "Ada") | |
449 | |
450 (setq blink-matching-paren t) | |
451 | |
452 (use-local-map ada-mode-map) | |
453 | |
454 (if ada-mode-syntax-table | |
455 (set-syntax-table ada-mode-syntax-table) | |
456 (ada-create-syntax-table)) | |
457 | |
458 (if ada-clean-buffer-before-saving | |
459 (progn | |
460 ;; remove all spaces at the end of lines in the whole buffer. | |
461 (add-hook 'local-write-file-hooks 'ada-remove-trailing-spaces) | |
462 ;; convert all tabs to the correct number of spaces. | |
463 (add-hook 'local-write-file-hooks 'ada-untabify-buffer))) | |
464 | |
465 | |
466 ;; add menu 'Ada' to the menu bar | |
467 (ada-add-ada-menu) | |
468 | |
469 (run-hooks 'ada-mode-hook) | |
470 | |
471 ;; the following has to be done after running the ada-mode-hook | |
472 ;; because users might want to set the values of these variable | |
473 ;; inside the hook (MH) | |
474 | |
475 (cond ((eq ada-language-version 'ada83) | |
476 (setq ada-keywords ada-83-keywords)) | |
477 ((eq ada-language-version 'ada94) | |
478 (setq ada-keywords ada-94-keywords))) | |
479 | |
480 (if ada-auto-case | |
481 (ada-activate-keys-for-case))) | |
482 | |
483 | |
484 ;;;-------------------------- | |
485 ;;; Fill Comment Paragraph | |
486 ;;;-------------------------- | |
487 | |
488 (defun ada-fill-comment-paragraph-justify () | |
489 "Fills current comment paragraph and justifies each line as well." | |
490 (interactive) | |
491 (ada-fill-comment-paragraph t)) | |
492 | |
493 | |
494 (defun ada-fill-comment-paragraph-postfix () | |
495 "Fills current comment paragraph and justifies each line as well. | |
496 Prompts for a postfix to be appended to each line." | |
497 (interactive) | |
498 (ada-fill-comment-paragraph t t)) | |
499 | |
500 | |
501 (defun ada-fill-comment-paragraph (&optional justify postfix) | |
502 "Fills the current comment paragraph. | |
503 If JUSTIFY is non-nil, each line is justified as well. | |
504 If POSTFIX and JUSTIFY are non-nil, ada-fill-comment-postfix is appended | |
505 to each filled and justified line. | |
506 If ada-indent-comment-as code is non-nil, the paragraph is idented." | |
507 (interactive "P") | |
508 (let ((opos (point-marker)) | |
509 (begin nil) | |
510 (end nil) | |
511 (end-2 nil) | |
512 (indent nil) | |
513 (ada-fill-comment-old-postfix "") | |
514 (fill-prefix nil)) | |
515 | |
516 ;; check if inside comment | |
517 (if (not (ada-in-comment-p)) | |
518 (error "not inside comment")) | |
519 | |
520 ;; prompt for postfix if wanted | |
521 (if (and justify | |
522 postfix) | |
523 (setq ada-fill-comment-postfix | |
524 (read-from-minibuffer "enter new postfix string: " | |
525 ada-fill-comment-postfix))) | |
526 | |
527 ;; prompt for old postfix to remove if necessary | |
528 (if (and justify | |
529 postfix) | |
530 (setq ada-fill-comment-old-postfix | |
531 (read-from-minibuffer "enter already existing postfix string: " | |
532 ada-fill-comment-postfix))) | |
533 | |
534 ;; | |
535 ;; find limits of paragraph | |
536 ;; | |
537 (message "filling comment paragraph ...") | |
538 (save-excursion | |
539 (back-to-indentation) | |
540 ;; find end of paragraph | |
541 (while (and (looking-at "--.*$") | |
542 (not (looking-at "--[ \t]*$"))) | |
543 (forward-line 1) | |
544 (back-to-indentation)) | |
545 (beginning-of-line) | |
546 (setq end (point-marker)) | |
547 (goto-char opos) | |
548 ;; find begin of paragraph | |
549 (back-to-indentation) | |
550 (while (and (looking-at "--.*$") | |
551 (not (looking-at "--[ \t]*$"))) | |
552 (forward-line -1) | |
553 (back-to-indentation)) | |
554 (forward-line 1) | |
555 ;; get indentation to calculate width for filling | |
556 (ada-indent-current) | |
557 (back-to-indentation) | |
558 (setq indent (current-column)) | |
559 (setq begin (point-marker))) | |
560 | |
561 ;; delete old postfix if necessary | |
562 (if (and justify | |
563 postfix) | |
564 (save-excursion | |
565 (goto-char begin) | |
566 (while (re-search-forward (concat ada-fill-comment-old-postfix | |
567 "\n") | |
568 end t) | |
569 (replace-match "\n")))) | |
570 | |
571 ;; delete leading whitespace and uncomment | |
572 (save-excursion | |
573 (goto-char begin) | |
574 (beginning-of-line) | |
575 (while (re-search-forward "^[ \t]*--[ \t]*" end t) | |
576 (replace-match ""))) | |
577 | |
578 ;; calculate fill width | |
579 (setq fill-column (- fill-column indent | |
580 (length ada-fill-comment-prefix) | |
581 (if postfix | |
582 (length ada-fill-comment-postfix) | |
583 0))) | |
584 ;; fill paragraph | |
585 (fill-region begin (1- end) justify) | |
586 (setq fill-column (+ fill-column indent | |
587 (length ada-fill-comment-prefix) | |
588 (if postfix | |
589 (length ada-fill-comment-postfix) | |
590 0))) | |
591 ;; find end of second last line | |
592 (save-excursion | |
593 (goto-char end) | |
594 (forward-line -2) | |
595 (end-of-line) | |
596 (setq end-2 (point-marker))) | |
597 | |
598 ;; re-comment and re-indent region | |
599 (save-excursion | |
600 (goto-char begin) | |
601 (indent-to indent) | |
602 (insert ada-fill-comment-prefix) | |
603 (while (re-search-forward "\n" (1- end-2) t) | |
604 (replace-match (concat "\n" ada-fill-comment-prefix)) | |
605 (beginning-of-line) | |
606 (indent-to indent))) | |
607 | |
608 ;; append postfix if wanted | |
609 (if (and justify | |
610 postfix | |
611 ada-fill-comment-postfix) | |
612 (progn | |
613 ;; append postfix up to there | |
614 (save-excursion | |
615 (goto-char begin) | |
616 (while (re-search-forward "\n" (1- end-2) t) | |
617 (replace-match (concat ada-fill-comment-postfix "\n"))) | |
618 | |
619 ;; fill last line and append postfix | |
620 (end-of-line) | |
621 (insert-char ? | |
622 (- fill-column | |
623 (current-column) | |
624 (length ada-fill-comment-postfix))) | |
625 (insert ada-fill-comment-postfix)))) | |
626 | |
627 ;; delete the extra line that gets inserted somehow(??) | |
628 (save-excursion | |
629 (goto-char (1- end)) | |
630 (end-of-line) | |
631 (delete-char 1)) | |
632 | |
633 (message "filling comment paragraph ... done") | |
10707 | 634 (goto-char opos)) |
635 t) | |
10705 | 636 |
637 | |
638 ;;;--------------------------------;;; | |
639 ;;; Call External Pretty Printer ;;; | |
640 ;;;--------------------------------;;; | |
641 | |
642 (defun ada-call-pretty-printer () | |
643 "Calls the external Pretty Printer. | |
644 The name is specified in ada-external-pretty-print-program. Saves the | |
645 current buffer in a directory specified by ada-tmp-directory, | |
646 starts the Pretty Printer as external process on that file and then | |
647 reloads the beautyfied program in the buffer and cleans up | |
648 ada-tmp-directory." | |
649 (interactive) | |
650 (let ((filename-with-path buffer-file-name) | |
651 (curbuf (current-buffer)) | |
652 (orgpos (point)) | |
653 (mesgbuf nil) ;; for byte-compiling | |
654 (file-path (file-name-directory buffer-file-name)) | |
655 (filename-without-path (file-name-nondirectory buffer-file-name)) | |
656 (tmp-file-with-directory | |
657 (concat ada-tmp-directory | |
658 (file-name-nondirectory buffer-file-name)))) | |
659 ;; | |
660 ;; save buffer in temporary file | |
661 ;; | |
662 (message "saving current buffer to temporary file ...") | |
663 (write-file tmp-file-with-directory) | |
664 (auto-save-mode nil) | |
665 (message "saving current buffer to temporary file ... done") | |
666 ;; | |
667 ;; call external pretty printer program | |
668 ;; | |
669 | |
670 (message "running external pretty printer ...") | |
671 ;; create a temporary buffer for messages of pretty printer | |
672 (setq mesgbuf (get-buffer-create "Pretty Printer Messages")) | |
673 ;; execute pretty printer on temporary file | |
674 (call-process ada-external-pretty-print-program | |
675 nil mesgbuf t | |
676 tmp-file-with-directory) | |
677 ;; display messages if there are some | |
678 (if (buffer-modified-p mesgbuf) | |
679 ;; show the message buffer | |
680 (display-buffer mesgbuf t) | |
681 ;; kill the message buffer | |
682 (kill-buffer mesgbuf)) | |
683 (message "running external pretty printer ... done") | |
684 ;; | |
685 ;; kill current buffer and load pretty printer output | |
686 ;; or restore old buffer | |
687 ;; | |
688 (if (y-or-n-p | |
689 "Really replace current buffer with pretty printer output ? ") | |
690 (progn | |
691 (set-buffer-modified-p nil) | |
692 (kill-buffer curbuf) | |
693 (find-file tmp-file-with-directory)) | |
694 (message "old buffer contents restored")) | |
695 ;; | |
696 ;; delete temporary file and restore information of current buffer | |
697 ;; | |
698 (delete-file tmp-file-with-directory) | |
699 (set-visited-file-name filename-with-path) | |
700 (auto-save-mode t) | |
701 (goto-char orgpos))) | |
702 | |
703 | |
704 ;;;--------------- | |
705 ;;; auto-casing | |
706 ;;;--------------- | |
707 | |
708 ;; from Philippe Waroquiers <philippe@cfmu.eurocontrol.be> | |
709 ;; modifiedby RE and MH | |
710 | |
711 (defun ada-after-keyword-p () | |
712 ;; returns t if cursor is after a keyword. | |
713 (save-excursion | |
714 (forward-word -1) | |
715 (and (save-excursion | |
716 (or | |
717 (= (point) (point-min)) | |
718 (backward-char 1)) | |
719 (not (looking-at "_"))) ; (MH) | |
720 (looking-at (concat ada-keywords "[^_]"))))) | |
721 | |
722 (defun ada-after-char-p () | |
723 ;; returns t if after ada character "'". | |
724 (save-excursion | |
725 (if (> (point) 2) | |
726 (progn | |
727 (forward-char -2) | |
728 (looking-at "'")) | |
729 nil))) | |
730 | |
731 | |
732 (defun ada-adjust-case (&optional force-identifier) | |
733 "Adjust the case of the word before the just-typed character, | |
734 according to ada-case-keyword and ada-case-identifier | |
735 If FORCE-IDENTIFIER is non-nil then also adjust keyword as | |
736 identifier." ; (MH) | |
737 (forward-char -1) | |
738 (if (and (> (point) 1) (not (or (ada-in-string-p) | |
739 (ada-in-comment-p) | |
740 (ada-after-char-p)))) | |
741 (if (eq (char-syntax (char-after (1- (point)))) ?w) | |
742 (if (and | |
743 (not force-identifier) ; (MH) | |
744 (ada-after-keyword-p)) | |
745 (funcall ada-case-keyword -1) | |
746 (funcall ada-case-identifier -1)))) | |
747 (forward-char 1)) | |
748 | |
749 | |
750 (defun ada-adjust-case-interactive (arg) | |
751 (interactive "P") | |
752 (let ((lastk last-command-char)) | |
753 (cond ((or (eq lastk ?\n) | |
754 (eq lastk ?\r)) | |
755 ;; horrible kludge | |
756 (insert " ") | |
757 (ada-adjust-case) | |
758 ;; horrible dekludge | |
759 (delete-backward-char 1) | |
760 ;; some special keys and their bindings | |
761 (cond | |
762 ((eq lastk ?\n) | |
763 (funcall ada-lfd-binding)) | |
764 ((eq lastk ?\r) | |
765 (funcall ada-ret-binding)))) | |
766 ((eq lastk ?\C-i) (ada-tab)) | |
767 ((self-insert-command (prefix-numeric-value arg)))) | |
768 ;; if there is a keyword in front of the underscore | |
769 ;; then it should be part of an identifier (MH) | |
770 (if (eq lastk ?_) | |
771 (ada-adjust-case t) | |
772 (ada-adjust-case)))) | |
773 | |
774 | |
775 (defun ada-activate-keys-for-case () | |
776 ;; save original keybindings to allow swapping ret/lfd | |
777 ;; when casing is activated | |
778 ;; the 'or ...' is there to be sure that the value will not | |
779 ;; be changed again when ada-mode is called more than once (MH) | |
780 (or ada-ret-binding | |
781 (setq ada-ret-binding (key-binding "\C-M"))) | |
782 (or ada-lfd-binding | |
783 (setq ada-lfd-binding (key-binding "\C-j"))) | |
784 ;; call case modifying function after certain keys. | |
785 (mapcar (function (lambda(key) (define-key | |
786 ada-mode-map | |
787 (char-to-string key) | |
788 'ada-adjust-case-interactive))) | |
789 '( ?` ?~ ?! ?@ ?# ?$ ?% ?^ ?& ?* ?( ?) ?- ?= ?+ ?[ ?{ ?] ?} | |
790 ?_ ?\\ ?| ?\; ?: ?' ?\" ?< ?, ?. ?> ?? ?/ ?\n 32 ?\r ))) | |
791 ;; deleted ?\t from above list | |
792 | |
793 ;; | |
794 ;; added by MH | |
795 ;; | |
796 (defun ada-loose-case-word (&optional arg) | |
797 "Capitalizes the first and the letters following _ | |
798 ARG is ignored, it's there to fit the standard casing functions' style." | |
799 (let ((pos (point)) | |
800 (first t)) | |
801 (skip-chars-backward "a-zA-Z0-9_") | |
802 (while (or first | |
803 (search-forward "_" pos t)) | |
804 (and first | |
805 (setq first nil)) | |
806 (insert-char (upcase (following-char)) 1) | |
807 (delete-char 1)) | |
808 (goto-char pos))) | |
809 | |
810 | |
811 ;; | |
812 ;; added by MH | |
813 ;; | |
814 (defun ada-adjust-case-region (from to) | |
815 "Adjusts the case of all identifiers and keywords in the region. | |
816 ATTENTION: This function might take very long for big regions !" | |
817 (interactive "*r") | |
818 (let ((begin nil) | |
819 (end nil) | |
820 (keywordp nil) | |
821 (reldiff nil)) | |
822 (save-excursion | |
823 (goto-char to) | |
824 ;; | |
825 ;; loop: look for all identifiers and keywords | |
826 ;; | |
827 (while (re-search-backward | |
828 "[^a-zA-Z0-9_]\\([a-zA-Z0-9_]+\\)[^a-zA-Z0-9_]" | |
829 from | |
830 t) | |
831 ;; | |
832 ;; print status message | |
833 ;; | |
834 (setq reldiff (- (point) from)) | |
835 (message (format "adjusting case ... %5d characters left" | |
836 (- (point) from))) | |
837 (forward-char 1) | |
838 (or | |
839 ;; do nothing if it is a string or comment | |
840 (ada-in-string-or-comment-p) | |
841 (progn | |
842 ;; | |
843 ;; get the identifier or keyword | |
844 ;; | |
845 (setq begin (point)) | |
846 (setq keywordp (looking-at (concat ada-keywords "[^_]"))) | |
847 (skip-chars-forward "a-zA-Z0-9_") | |
848 ;; | |
849 ;; casing according to user-option | |
850 ;; | |
851 (if keywordp | |
852 (funcall ada-case-keyword -1) | |
853 (funcall ada-case-identifier -1)) | |
854 (goto-char begin)))) | |
855 (message "adjusting case ... done")))) | |
856 | |
857 | |
858 ;; | |
859 ;; added by MH | |
860 ;; | |
861 (defun ada-adjust-case-buffer () | |
862 "Adjusts the case of all identifiers and keywords in the whole buffer. | |
863 ATTENTION: This function might take very long for big buffers !" | |
864 (interactive) | |
865 (ada-adjust-case-region (point-min) (point-max))) | |
866 | |
867 | |
868 ;;;------------------------;;; | |
869 ;;; Format Parameter Lists ;;; | |
870 ;;;------------------------;;; | |
871 | |
872 (defun ada-format-paramlist () | |
873 "Re-formats a parameter-list. | |
874 ATTENTION: 1) Comments inside the list are killed ! | |
875 2) If the syntax is not correct (especially, if there are | |
876 semicolons missing), it can get totally confused ! | |
877 In such a case, use 'undo', correct the syntax and try again." | |
878 | |
879 (interactive) | |
880 (let ((begin nil) | |
881 (end nil) | |
882 (delend nil) | |
883 (paramlist nil)) | |
884 ;; | |
885 ;; ATTENTION: modify sntax-table temporary ! | |
886 ;; | |
887 (modify-syntax-entry ?_ "w") | |
888 | |
889 ;; check if really inside parameter list | |
890 (or (ada-in-paramlist-p) | |
891 (error "not in parameter list")) | |
892 ;; | |
893 ;; find start of current parameter-list | |
894 ;; | |
895 (ada-search-ignore-string-comment | |
896 (concat "\\<\\(" | |
897 "procedure\\|function\\|body\\|package\\|task\\|entry\\|accept" | |
898 "\\)\\>") t nil) | |
899 (ada-search-ignore-string-comment "(" nil nil t) | |
900 (backward-char 1) | |
901 (setq begin (point)) | |
902 | |
903 ;; | |
904 ;; find end of parameter-list | |
905 ;; | |
906 (forward-sexp 1) | |
907 (setq delend (point)) | |
908 (delete-char -1) | |
909 | |
910 ;; | |
911 ;; find end of last parameter-declaration | |
912 ;; | |
913 (ada-search-ignore-string-comment "[^ \t\n]" t nil t) | |
914 (forward-char 1) | |
915 (setq end (point)) | |
916 | |
917 ;; | |
918 ;; build a list of all elements of the parameter-list | |
919 ;; | |
920 (setq paramlist (ada-scan-paramlist (1+ begin) end)) | |
921 | |
922 ;; | |
923 ;; delete the original parameter-list | |
924 ;; | |
925 (delete-region begin (1- delend)) | |
926 | |
927 ;; | |
928 ;; insert the new parameter-list | |
929 ;; | |
930 (goto-char begin) | |
931 (ada-insert-paramlist paramlist) | |
932 | |
933 ;; | |
934 ;; restore syntax-table | |
935 ;; | |
936 (modify-syntax-entry ?_ "_"))) | |
937 | |
938 | |
939 (defun ada-scan-paramlist (begin end) | |
940 ;; Scans a parameter-list between BEGIN and END and returns a list | |
941 ;; of its contents. | |
942 ;; The list has the following format: | |
943 ;; | |
944 ;; Name of Param in? out? accept? Name of Type Default-Exp or nil | |
945 ;; | |
946 ;; ( ('Name_Param_1' t nil t Type_Param_1 ':= expression') | |
947 ;; ('Name_Param_2' nil nil t Type_Param_2 nil) ) | |
948 | |
949 (let ((paramlist (list)) | |
950 (param (list)) | |
951 (notend t) | |
952 (apos nil) | |
953 (epos nil) | |
954 (semipos nil) | |
955 (match-cons nil)) | |
956 | |
957 (goto-char begin) | |
958 ;; | |
959 ;; loop until end of last parameter | |
960 ;; | |
961 (while notend | |
962 | |
963 ;; | |
964 ;; find first character of parameter-declaration | |
965 ;; | |
966 (ada-goto-next-non-ws) | |
967 (setq apos (point)) | |
968 | |
969 ;; | |
970 ;; find last character of parameter-declaration | |
971 ;; | |
972 (if (setq match-cons | |
973 (ada-search-ignore-string-comment "[ \t\n]*;" nil end t)) | |
974 (progn | |
975 (setq epos (car match-cons)) | |
976 (setq semipos (cdr match-cons))) | |
977 (setq epos end)) | |
978 | |
979 ;; | |
980 ;; read name(s) of parameter(s) | |
981 ;; | |
982 (goto-char apos) | |
983 (looking-at "\\([a-zA-Z0-9_, \t\n]*[a-zA-Z0-9_]\\)[ \t\n]*:[^=]") | |
984 | |
985 (setq param (list (buffer-substring (match-beginning 1) | |
986 (match-end 1)))) | |
987 (ada-search-ignore-string-comment ":" nil epos t) | |
988 | |
989 ;; | |
990 ;; look for 'in' | |
991 ;; | |
992 (setq apos (point)) | |
993 (setq param | |
994 (append param | |
995 (list | |
996 (consp | |
997 (ada-search-ignore-string-comment "\\<in\\>" | |
998 nil | |
999 epos | |
1000 t))))) | |
1001 | |
1002 ;; | |
1003 ;; look for 'out' | |
1004 ;; | |
1005 (goto-char apos) | |
1006 (setq param | |
1007 (append param | |
1008 (list | |
1009 (consp | |
1010 (ada-search-ignore-string-comment "\\<out\\>" | |
1011 nil | |
1012 epos | |
1013 t))))) | |
1014 | |
1015 ;; | |
1016 ;; look for 'accept' | |
1017 ;; | |
1018 (goto-char apos) | |
1019 (setq param | |
1020 (append param | |
1021 (list | |
1022 (consp | |
1023 (ada-search-ignore-string-comment "\\<accept\\>" | |
1024 nil | |
1025 epos | |
1026 t))))) | |
1027 | |
1028 ;; | |
1029 ;; skip 'in'/'out'/'accept' | |
1030 ;; | |
1031 (goto-char apos) | |
1032 (ada-goto-next-non-ws) | |
1033 (while (looking-at "\\<\\(in\\|out\\|accept\\)\\>") | |
1034 (forward-word 1) | |
1035 (ada-goto-next-non-ws)) | |
1036 | |
1037 ;; | |
1038 ;; read type of parameter | |
1039 ;; | |
1040 (looking-at "\\<[a-zA-Z0-9_\\.]+\\>") | |
1041 (setq param | |
1042 (append param | |
1043 (list | |
1044 (buffer-substring (match-beginning 0) | |
1045 (match-end 0))))) | |
1046 | |
1047 ;; | |
1048 ;; read default-expression, if there is one | |
1049 ;; | |
1050 (goto-char (setq apos (match-end 0))) | |
1051 (setq param | |
1052 (append param | |
1053 (list | |
1054 (if (setq match-cons | |
1055 (ada-search-ignore-string-comment ":=" | |
1056 nil | |
1057 epos | |
1058 t)) | |
1059 (buffer-substring (car match-cons) | |
1060 epos) | |
1061 nil)))) | |
1062 ;; | |
1063 ;; add this parameter-declaration to the list | |
1064 ;; | |
1065 (setq paramlist (append paramlist (list param))) | |
1066 | |
1067 ;; | |
1068 ;; check if it was the last parameter | |
1069 ;; | |
1070 (if (eq epos end) | |
1071 (setq notend nil) | |
1072 (goto-char semipos)) | |
1073 | |
1074 ) ; end of loop | |
1075 | |
1076 (reverse paramlist))) | |
1077 | |
1078 | |
1079 (defun ada-insert-paramlist (paramlist) | |
1080 ;; Inserts a formatted PARAMLIST in the buffer. | |
1081 ;; See doc of ada-scan-paramlist for the format. | |
1082 (let ((i (length paramlist)) | |
1083 (parlen 0) | |
1084 (typlen 0) | |
1085 (temp 0) | |
1086 (inp nil) | |
1087 (outp nil) | |
1088 (acceptp nil) | |
1089 (column nil) | |
1090 (orgpoint 0) | |
1091 (firstcol nil)) | |
1092 | |
1093 ;; | |
1094 ;; loop until last parameter | |
1095 ;; | |
1096 (while (not (zerop i)) | |
1097 (setq i (1- i)) | |
1098 | |
1099 ;; | |
1100 ;; get max length of parameter-name | |
1101 ;; | |
1102 (setq parlen | |
1103 (if (<= parlen (setq temp | |
1104 (length (nth 0 (nth i paramlist))))) | |
1105 temp | |
1106 parlen)) | |
1107 | |
1108 ;; | |
1109 ;; get max length of type-name | |
1110 ;; | |
1111 (setq typlen | |
1112 (if (<= typlen (setq temp | |
1113 (length (nth 4 (nth i paramlist))))) | |
1114 temp | |
1115 typlen)) | |
1116 | |
1117 ;; | |
1118 ;; is there any 'in' ? | |
1119 ;; | |
1120 (setq inp | |
1121 (or inp | |
1122 (nth 1 (nth i paramlist)))) | |
1123 | |
1124 ;; | |
1125 ;; is there any 'out' ? | |
1126 ;; | |
1127 (setq outp | |
1128 (or outp | |
1129 (nth 2 (nth i paramlist)))) | |
1130 | |
1131 ;; | |
1132 ;; is there any 'accept' ? | |
1133 ;; | |
1134 (setq acceptp | |
1135 (or acceptp | |
1136 (nth 3 (nth i paramlist))))) ; end of loop | |
1137 | |
1138 ;; | |
1139 ;; does paramlist already start on a separate line ? | |
1140 ;; | |
1141 (if (save-excursion | |
1142 (re-search-backward "^.\\|[^ \t]" nil t) | |
1143 (looking-at "^.")) | |
1144 ;; yes => re-indent it | |
1145 (ada-indent-current) | |
1146 ;; | |
1147 ;; no => insert newline and indent it | |
1148 ;; | |
1149 (progn | |
1150 (ada-indent-current) | |
1151 (newline) | |
1152 (delete-horizontal-space) | |
1153 (setq orgpoint (point)) | |
1154 (setq column (save-excursion | |
1155 (funcall (ada-indent-function) orgpoint))) | |
1156 (indent-to column) | |
1157 )) | |
1158 | |
1159 (insert "(") | |
1160 | |
1161 (setq firstcol (current-column)) | |
1162 (setq i (length paramlist)) | |
1163 | |
1164 ;; | |
1165 ;; loop until last parameter | |
1166 ;; | |
1167 (while (not (zerop i)) | |
1168 (setq i (1- i)) | |
1169 (setq column firstcol) | |
1170 | |
1171 ;; | |
1172 ;; insert parameter-name, space and colon | |
1173 ;; | |
1174 (insert (nth 0 (nth i paramlist))) | |
1175 (indent-to (+ column parlen 1)) | |
1176 (insert ": ") | |
1177 (setq column (current-column)) | |
1178 | |
1179 ;; | |
1180 ;; insert 'in' or space | |
1181 ;; | |
1182 (if (nth 1 (nth i paramlist)) | |
1183 (insert "in ") | |
1184 (if (and | |
1185 (or inp | |
1186 acceptp) | |
1187 (not (nth 3 (nth i paramlist)))) | |
1188 (insert " "))) | |
1189 | |
1190 ;; | |
1191 ;; insert 'out' or space | |
1192 ;; | |
1193 (if (nth 2 (nth i paramlist)) | |
1194 (insert "out ") | |
1195 (if (and | |
1196 (or outp | |
1197 acceptp) | |
1198 (not (nth 3 (nth i paramlist)))) | |
1199 (insert " "))) | |
1200 | |
1201 ;; | |
1202 ;; insert 'accept' | |
1203 ;; | |
1204 (if (nth 3 (nth i paramlist)) | |
1205 (insert "accept ")) | |
1206 | |
1207 (setq column (current-column)) | |
1208 | |
1209 ;; | |
1210 ;; insert type-name and, if necessary, space and default-expression | |
1211 ;; | |
1212 (insert (nth 4 (nth i paramlist))) | |
1213 (if (nth 5 (nth i paramlist)) | |
1214 (progn | |
1215 (indent-to (+ column typlen 1)) | |
1216 (insert (nth 5 (nth i paramlist))))) | |
1217 | |
1218 ;; | |
1219 ;; check if it was the last parameter | |
1220 ;; | |
1221 (if (not (zerop i)) | |
1222 ;; no => insert ';' and newline and indent | |
1223 (progn | |
1224 (insert ";") | |
1225 (newline) | |
1226 (indent-to firstcol)) | |
1227 ;; yes | |
1228 (insert ")")) | |
1229 | |
1230 ) ; end of loop | |
1231 | |
1232 ;; | |
1233 ;; if anything follows, except semicolon: | |
1234 ;; put it in a new line and indent it | |
1235 ;; | |
1236 (if (not (looking-at "[ \t]*[;\n]")) | |
1237 (ada-indent-newline-indent)) | |
1238 | |
1239 )) | |
1240 | |
1241 | |
1242 ;;;----------------------------;;; | |
1243 ;;; Move To Matching Start/End ;;; | |
1244 ;;;----------------------------;;; | |
1245 | |
1246 (defun ada-move-to-start () | |
1247 "Moves point to the matching start of the current end ... around point." | |
1248 (interactive) | |
1249 (let ((pos (point))) | |
1250 ;; | |
1251 ;; ATTENTION: modify sntax-table temporary ! | |
1252 ;; | |
1253 (modify-syntax-entry ?_ "w") | |
1254 | |
1255 (message "searching for block start ...") | |
1256 (save-excursion | |
1257 ;; | |
1258 ;; do nothing if in string or comment or not on 'end ...;' | |
1259 ;; or if an error occurs during processing | |
1260 ;; | |
1261 (or | |
1262 (ada-in-string-or-comment-p) | |
1263 (and (progn | |
1264 (or (looking-at "[ \t]*\\<end\\>") | |
1265 (backward-word 1)) | |
1266 (or (looking-at "[ \t]*\\<end\\>") | |
1267 (backward-word 1)) | |
1268 (or (looking-at "[ \t]*\\<end\\>") | |
1269 (error "not on end ...;"))) | |
1270 (ada-goto-matching-start 1) | |
1271 (setq pos (point)) | |
1272 | |
1273 ;; | |
1274 ;; on 'begin' => go on, according to user option | |
1275 ;; | |
1276 ada-move-to-declaration | |
1277 (looking-at "\\<begin\\>") | |
1278 (ada-goto-matching-decl-start) | |
1279 (setq pos (point)))) | |
1280 | |
1281 ) ; end of save-excursion | |
1282 | |
1283 ;; now really move to the found position | |
1284 (goto-char pos) | |
1285 (message "searching for block start ... done") | |
1286 | |
1287 ;; | |
1288 ;; restore syntax-table | |
1289 ;; | |
1290 (modify-syntax-entry ?_ "_"))) | |
1291 | |
1292 | |
1293 (defun ada-move-to-end () | |
1294 "Moves point to the matching end of the current block around point. | |
1295 Moves to 'begin' if in a declarative part." | |
1296 (interactive) | |
1297 (let ((pos (point)) | |
1298 (decstart nil) | |
1299 (packdecl nil)) | |
1300 ;; | |
1301 ;; ATTENTION: modify sntax-table temporary ! | |
1302 ;; | |
1303 (modify-syntax-entry ?_ "w") | |
1304 | |
1305 (message "searching for block end ...") | |
1306 (save-excursion | |
1307 | |
1308 (forward-char 1) | |
1309 (cond | |
1310 ;; directly on 'begin' | |
1311 ((save-excursion | |
1312 (ada-goto-previous-word) | |
1313 (looking-at "\\<begin\\>")) | |
1314 (ada-goto-matching-end 1)) | |
1315 ;; on first line of defun declaration | |
1316 ((save-excursion | |
1317 (and (ada-goto-stmt-start) | |
1318 (looking-at "\\<function\\>\\|\\<procedure\\>" ))) | |
1319 (ada-search-ignore-string-comment "\\<begin\\>")) | |
1320 ;; on first line of task declaration | |
1321 ((save-excursion | |
1322 (and (ada-goto-stmt-start) | |
1323 (looking-at "\\<task\\>" ) | |
1324 (forward-word 1) | |
1325 (ada-search-ignore-string-comment "[^ \n\t]") | |
1326 (not (backward-char 1)) | |
1327 (looking-at "\\<body\\>"))) | |
1328 (ada-search-ignore-string-comment "\\<begin\\>")) | |
1329 ;; accept block start | |
1330 ((save-excursion | |
1331 (and (ada-goto-stmt-start) | |
1332 (looking-at "\\<accept\\>" ))) | |
1333 (ada-goto-matching-end 0)) | |
1334 ;; package start | |
1335 ((save-excursion | |
1336 (and (ada-goto-matching-decl-start t) | |
1337 (looking-at "\\<package\\>"))) | |
1338 (ada-goto-matching-end 1)) | |
1339 ;; inside a 'begin' ... 'end' block | |
1340 ((save-excursion | |
1341 (ada-goto-matching-decl-start t)) | |
1342 (ada-search-ignore-string-comment "\\<begin\\>")) | |
1343 ;; (hopefully ;-) everything else | |
1344 (t | |
1345 (ada-goto-matching-end 1))) | |
1346 (setq pos (point)) | |
1347 | |
1348 ) ; end of save-excursion | |
1349 | |
1350 ;; now really move to the found position | |
1351 (goto-char pos) | |
1352 (message "searching for block end ... done") | |
1353 | |
1354 ;; | |
1355 ;; restore syntax-table | |
1356 ;; | |
1357 (modify-syntax-entry ?_ "_"))) | |
1358 | |
1359 | |
1360 ;;;-----------------------------;;; | |
1361 ;;; Functions For Indentation ;;; | |
1362 ;;;-----------------------------;;; | |
1363 | |
1364 ;; ---- main functions for indentation | |
1365 | |
1366 (defun ada-indent-region (beg end) | |
1367 "Indents the region using ada-indent-current on each line." | |
1368 (interactive "*r") | |
1369 (goto-char beg) | |
1370 ;; catch errors while indenting | |
1371 (condition-case err | |
1372 (while (< (point) end) | |
1373 (message (format "indenting ... %4d lines left" | |
1374 (count-lines (point) end))) | |
1375 (ada-indent-current) | |
1376 (forward-line 1)) | |
1377 ;; show line number where the error occured | |
1378 (error | |
1379 (error (format "line %d: %s" | |
1380 (1+ (count-lines (point-min) (point))) | |
1381 err) nil))) | |
1382 (message "indenting ... done")) | |
1383 | |
1384 | |
1385 (defun ada-indent-newline-indent () | |
1386 "Indents the current line, inserts a newline and then indents the new line." | |
1387 (interactive "*") | |
1388 (let ((column) | |
1389 (orgpoint)) | |
1390 | |
1391 (ada-indent-current) | |
1392 (newline) | |
1393 (delete-horizontal-space) | |
1394 (setq orgpoint (point)) | |
1395 | |
1396 ;; | |
1397 ;; ATTENTION: modify syntax-table temporary ! | |
1398 ;; | |
1399 (modify-syntax-entry ?_ "w") | |
1400 | |
1401 (setq column (save-excursion | |
1402 (funcall (ada-indent-function) orgpoint))) | |
1403 | |
1404 ;; | |
1405 ;; restore syntax-table | |
1406 ;; | |
1407 (modify-syntax-entry ?_ "_") | |
1408 | |
1409 (indent-to column) | |
1410 | |
1411 ;; The following is needed to ensure that indentation will still be | |
1412 ;; correct if something follows behind point when typing LFD | |
1413 ;; For example: Imagine point to be there (*) when LFD is typed: | |
1414 ;; while cond loop | |
1415 ;; null; *end loop; | |
1416 ;; Result without the following statement would be: | |
1417 ;; while cond loop | |
1418 ;; null; | |
1419 ;; *end loop; | |
1420 ;; You would then have to type TAB to correct it. | |
1421 ;; If that doesn't bother you, you can comment out the following | |
1422 ;; statement to speed up indentation a LITTLE bit. | |
1423 | |
1424 (if (not (looking-at "[ \t]*$")) | |
1425 (ada-indent-current)) | |
1426 )) | |
1427 | |
1428 | |
1429 (defun ada-indent-current () | |
1430 "Indents current line as Ada code. | |
1431 This works by two steps: | |
1432 1) It moves point to the end of the previous code-line. | |
1433 Then it calls the function to calculate the indentation for the | |
1434 following line as if a newline would be inserted there. | |
1435 The calculated column # is saved and the old position of point | |
1436 is restored. | |
1437 2) Then another function is called to calculate the indentation for | |
1438 the current line, based on the previously calculated column #." | |
1439 | |
1440 (interactive) | |
1441 | |
1442 ;; | |
1443 ;; ATTENTION: modify sntax-table temporary ! | |
1444 ;; | |
1445 (modify-syntax-entry ?_ "w") | |
1446 | |
1447 (let ((line-end) | |
1448 (orgpoint (point-marker)) | |
1449 (cur-indent) | |
1450 (prev-indent) | |
1451 (prevline t)) | |
1452 | |
1453 ;; | |
1454 ;; first step | |
1455 ;; | |
1456 (save-excursion | |
1457 (if (ada-goto-prev-nonblank-line t) | |
1458 ;; | |
1459 ;; we are not in the first accessible line in the buffer | |
1460 ;; | |
1461 (progn | |
1462 (end-of-line) | |
1463 (forward-char 1) | |
1464 (setq line-end (point)) | |
1465 (setq prev-indent (save-excursion | |
1466 (funcall (ada-indent-function) line-end)))) | |
1467 (setq prevline nil))) | |
1468 | |
1469 (if prevline | |
1470 ;; | |
1471 ;; we are not in the first accessible line in the buffer | |
1472 ;; | |
1473 (progn | |
1474 ;; | |
1475 ;; second step | |
1476 ;; | |
1477 (back-to-indentation) | |
1478 (setq cur-indent (ada-get-current-indent prev-indent)) | |
1479 (delete-horizontal-space) | |
1480 (indent-to cur-indent) | |
1481 | |
1482 ;; | |
1483 ;; restore position of point | |
1484 ;; | |
1485 (goto-char orgpoint) | |
1486 (if (< (current-column) (current-indentation)) | |
1487 (back-to-indentation))))) | |
1488 | |
1489 ;; | |
1490 ;; restore syntax-table | |
1491 ;; | |
1492 (modify-syntax-entry ?_ "_")) | |
1493 | |
1494 | |
1495 (defun ada-get-current-indent (prev-indent) | |
1496 ;; Returns the column # to indent the current line to. | |
1497 ;; PREV-INDENT is the indentation resulting from the previous lines. | |
1498 (let ((column nil) | |
1499 (pos nil) | |
1500 (match-cons nil)) | |
1501 | |
1502 (cond | |
1503 ;; | |
1504 ;; in open parenthesis, but not in parameter-list | |
1505 ;; | |
1506 ((and | |
1507 ada-indent-to-open-paren | |
1508 (not (ada-in-paramlist-p)) | |
1509 (setq column (ada-in-open-paren-p))) | |
1510 ;; check if we have something like this (Table_Component_Type => | |
1511 ;; Source_File_Record,) | |
1512 (save-excursion | |
1513 (if (and (ada-search-ignore-string-comment "[^ \t]" t nil) | |
1514 (looking-at "\n") | |
1515 (ada-search-ignore-string-comment "[^ \t\n]" t nil) | |
1516 (looking-at ">")) | |
1517 (setq column (+ ada-broken-indent column)))) | |
1518 column) | |
1519 | |
1520 ;; | |
1521 ;; end | |
1522 ;; | |
1523 ((looking-at "\\<end\\>") | |
1524 (save-excursion | |
1525 (ada-goto-matching-start 1) | |
1526 | |
1527 ;; | |
1528 ;; found 'loop' => skip back to 'while' or 'for' | |
1529 ;; if 'loop' is not on a separate line | |
1530 ;; | |
1531 (if (and | |
1532 (looking-at "\\<loop\\>") | |
1533 (save-excursion | |
1534 (back-to-indentation) | |
1535 (not (looking-at "\\<loop\\>")))) | |
1536 (if (save-excursion | |
1537 (and | |
1538 (setq match-cons | |
1539 (ada-search-ignore-string-comment | |
1540 ada-loop-start-re t nil)) | |
1541 (not (looking-at "\\<loop\\>")))) | |
1542 (goto-char (car match-cons)))) | |
1543 | |
1544 (current-indentation))) | |
1545 ;; | |
1546 ;; exception | |
1547 ;; | |
1548 ((looking-at "\\<exception\\>") | |
1549 (save-excursion | |
1550 (ada-goto-matching-start 1) | |
1551 (current-indentation))) | |
1552 ;; | |
1553 ;; when | |
1554 ;; | |
1555 ((looking-at "\\<when\\>") | |
1556 (save-excursion | |
1557 (ada-goto-matching-start 1) | |
1558 (+ (current-indentation) ada-when-indent))) | |
1559 ;; | |
1560 ;; else | |
1561 ;; | |
1562 ((looking-at "\\<else\\>") | |
1563 (if (save-excursion | |
1564 (ada-goto-previous-word) | |
1565 (looking-at "\\<or\\>")) | |
1566 prev-indent | |
1567 (save-excursion | |
1568 (ada-goto-matching-start 1 nil t) | |
1569 (current-indentation)))) | |
1570 ;; | |
1571 ;; elsif | |
1572 ;; | |
1573 ((looking-at "\\<elsif\\>") | |
1574 (save-excursion | |
1575 (ada-goto-matching-start 1 nil t) | |
1576 (current-indentation))) | |
1577 ;; | |
1578 ;; then | |
1579 ;; | |
1580 ((looking-at "\\<then\\>") | |
1581 (if (save-excursion | |
1582 (ada-goto-previous-word) | |
1583 (looking-at "\\<and\\>")) | |
1584 prev-indent | |
1585 (save-excursion | |
1586 (ada-search-ignore-string-comment "\\<elsif\\>\\|\\<if\\>" t nil) | |
1587 (+ (current-indentation) ada-stmt-end-indent)))) | |
1588 ;; | |
1589 ;; loop | |
1590 ;; | |
1591 ((looking-at "\\<loop\\>") | |
1592 (setq pos (point)) | |
1593 (save-excursion | |
1594 (goto-char (match-end 0)) | |
1595 (ada-goto-stmt-start) | |
1596 (if (looking-at "\\<loop\\>\\|\\<if\\>") | |
1597 prev-indent | |
1598 (progn | |
1599 (if (not (looking-at ada-loop-start-re)) | |
1600 (ada-search-ignore-string-comment ada-loop-start-re | |
1601 nil pos)) | |
1602 (if (looking-at "\\<loop\\>") | |
1603 prev-indent | |
1604 (+ (current-indentation) ada-stmt-end-indent)))))) | |
1605 ;; | |
1606 ;; begin | |
1607 ;; | |
1608 ((looking-at "\\<begin\\>") | |
1609 (save-excursion | |
1610 (if (ada-goto-matching-decl-start t) | |
1611 (current-indentation) | |
1612 (progn | |
1613 (message "no matching declaration start") | |
1614 prev-indent)))) | |
1615 ;; | |
1616 ;; is | |
1617 ;; | |
1618 ((looking-at "\\<is\\>") | |
1619 (if (and | |
1620 ada-indent-is-separate | |
1621 (save-excursion | |
1622 (goto-char (match-end 0)) | |
1623 (ada-goto-next-non-ws (save-excursion | |
1624 (end-of-line) | |
1625 (point))) | |
1626 (looking-at "\\<abstract\\>\\|\\<separate\\>"))) | |
1627 (save-excursion | |
1628 (ada-goto-stmt-start) | |
1629 (+ (current-indentation) ada-indent)) | |
1630 (save-excursion | |
1631 (ada-goto-stmt-start) | |
1632 (+ (current-indentation) ada-stmt-end-indent)))) | |
1633 ;; | |
1634 ;; record | |
1635 ;; | |
1636 ((looking-at "\\<record\\>") | |
1637 (save-excursion | |
1638 (ada-search-ignore-string-comment | |
1639 "\\<\\(type\\|use\\)\\>" t nil) | |
1640 (if (looking-at "\\<use\\>") | |
1641 (ada-search-ignore-string-comment "\\<for\\>" t nil)) | |
1642 (+ (current-indentation) ada-indent-record-rel-type))) | |
1643 ;; | |
1644 ;; or as statement-start | |
1645 ;; | |
1646 ((ada-looking-at-semi-or) | |
1647 (save-excursion | |
1648 (ada-goto-matching-start 1) | |
1649 (current-indentation))) | |
1650 ;; | |
1651 ;; private as statement-start | |
1652 ;; | |
1653 ((ada-looking-at-semi-private) | |
1654 (save-excursion | |
1655 (ada-goto-matching-decl-start) | |
1656 (current-indentation))) | |
1657 ;; | |
1658 ;; new/abstract/separate | |
1659 ;; | |
1660 ((looking-at "\\<\\(new\\|abstract\\|separate\\)\\>") | |
1661 (- prev-indent ada-indent (- ada-broken-indent))) | |
1662 ;; | |
1663 ;; return | |
1664 ;; | |
1665 ((looking-at "\\<return\\>") | |
1666 (save-excursion | |
1667 (forward-sexp -1) | |
1668 (if (and (looking-at "(") | |
1669 (save-excursion | |
1670 (backward-sexp 2) | |
1671 (looking-at "\\<function\\>"))) | |
1672 (1+ (current-column)) | |
1673 prev-indent))) | |
1674 ;; | |
1675 ;; do | |
1676 ;; | |
1677 ((looking-at "\\<do\\>") | |
1678 (save-excursion | |
1679 (ada-goto-stmt-start) | |
1680 (+ (current-indentation) ada-stmt-end-indent))) | |
1681 ;; | |
1682 ;; package/function/procedure | |
1683 ;; | |
1684 ((and (looking-at "\\<\\(package\\|function\\|procedure\\)\\>") | |
1685 (save-excursion | |
1686 (forward-char 1) | |
1687 (ada-goto-stmt-start) | |
1688 (looking-at "\\<\\(package\\|function\\|procedure\\)\\>"))) | |
1689 (save-excursion | |
1690 ;; look for 'generic' | |
1691 (if (and (ada-goto-matching-decl-start t) | |
1692 (looking-at "generic")) | |
1693 (current-column) | |
1694 prev-indent))) | |
1695 ;; | |
1696 ;; label | |
1697 ;; | |
1698 ((looking-at "\\<[a-zA-Z0-9_]+[ \t\n]*:[^=]") | |
1699 (if (ada-in-decl-p) | |
1700 prev-indent | |
1701 (+ prev-indent ada-label-indent))) | |
1702 ;; | |
1703 ;; identifier and other noindent-statements | |
1704 ;; | |
1705 ((looking-at "\\<[a-zA-Z0-9_]+[ \t\n]*") | |
1706 prev-indent) | |
1707 ;; | |
1708 ;; beginning of a parameter list | |
1709 ;; | |
1710 ((looking-at "(") | |
1711 prev-indent) | |
1712 ;; | |
1713 ;; end of a parameter list | |
1714 ;; | |
1715 ((looking-at ")") | |
1716 (save-excursion | |
1717 (forward-char 1) | |
1718 (backward-sexp 1) | |
1719 (current-column))) | |
1720 ;; | |
1721 ;; comment | |
1722 ;; | |
1723 ((looking-at "--") | |
1724 (if ada-indent-comment-as-code | |
1725 prev-indent | |
1726 (current-indentation))) | |
1727 ;; | |
1728 ;; unknown syntax - maybe this should signal an error ? | |
1729 ;; | |
1730 (t | |
1731 prev-indent)))) | |
1732 | |
1733 | |
1734 (defun ada-indent-function (&optional nomove) | |
1735 ;; Returns the function to calculate the indentation for the current | |
1736 ;; line according to the previous statement, ignoring the contents | |
1737 ;; of the current line after point. Moves point to the beginning of | |
1738 ;; the current statement, if NOMOVE is nil. | |
1739 | |
1740 (let ((orgpoint (point)) | |
1741 (func nil) | |
1742 (stmt-start nil)) | |
1743 ;; | |
1744 ;; inside a parameter-list | |
1745 ;; | |
1746 (if (ada-in-paramlist-p) | |
1747 (setq func 'ada-get-indent-paramlist) | |
1748 (progn | |
1749 ;; | |
1750 ;; move to beginning of current statement | |
1751 ;; | |
1752 (if (not nomove) | |
1753 (setq stmt-start (ada-goto-stmt-start))) | |
1754 ;; | |
1755 ;; no beginning found => don't change indentation | |
1756 ;; | |
1757 (if (and | |
1758 (eq orgpoint (point)) | |
1759 (not nomove)) | |
1760 (setq func 'ada-get-indent-nochange) | |
1761 | |
1762 (cond | |
1763 ;; | |
1764 ((and | |
1765 ada-indent-to-open-paren | |
1766 (ada-in-open-paren-p)) | |
1767 (setq func 'ada-get-indent-open-paren)) | |
1768 ;; | |
1769 ((looking-at "\\<end\\>") | |
1770 (setq func 'ada-get-indent-end)) | |
1771 ;; | |
1772 ((looking-at ada-loop-start-re) | |
1773 (setq func 'ada-get-indent-loop)) | |
1774 ;; | |
1775 ((looking-at ada-subprog-start-re) | |
1776 (setq func 'ada-get-indent-subprog)) | |
1777 ;; | |
1778 ((looking-at "\\<package\\>") | |
1779 (setq func 'ada-get-indent-subprog)) ; maybe it needs a | |
1780 ; special function | |
1781 ; sometimes ? | |
1782 ;; | |
1783 ((looking-at ada-block-start-re) | |
1784 (setq func 'ada-get-indent-block-start)) | |
1785 ;; | |
1786 ((looking-at "\\<type\\>") | |
1787 (setq func 'ada-get-indent-type)) | |
1788 ;; | |
1789 ((looking-at "\\<if\\>") | |
1790 (setq func 'ada-get-indent-if)) | |
1791 ;; | |
1792 ((looking-at "\\<elsif\\>") | |
1793 (setq func 'ada-get-indent-if)) ; maybe it needs a special | |
1794 ; function sometimes ? | |
1795 ;; | |
1796 ((looking-at "\\<case\\>") | |
1797 (setq func 'ada-get-indent-case)) | |
1798 ;; | |
1799 ((looking-at "\\<when\\>") | |
1800 (setq func 'ada-get-indent-when)) | |
1801 ;; | |
1802 ((looking-at "--") | |
1803 (setq func 'ada-get-indent-comment)) | |
1804 ;; | |
1805 ((looking-at "[a-zA-Z0-9_]+[ \t\n]*:[^=]") | |
1806 (setq func 'ada-get-indent-label)) | |
1807 ;; | |
1808 (t | |
1809 (setq func 'ada-get-indent-noindent)))))) | |
1810 | |
1811 func)) | |
1812 | |
1813 | |
1814 ;; ---- functions to return indentation for special cases | |
1815 | |
1816 (defun ada-get-indent-open-paren (orgpoint) | |
1817 ;; Returns the indentation (column #) for the new line after ORGPOINT. | |
1818 ;; Assumes point to be behind an open paranthesis not yet closed. | |
1819 (ada-in-open-paren-p)) | |
1820 | |
1821 | |
1822 (defun ada-get-indent-nochange (orgpoint) | |
1823 ;; Returns the indentation (column #) of the current line. | |
1824 (save-excursion | |
1825 (forward-line -1) | |
1826 (current-indentation))) | |
1827 | |
1828 | |
1829 (defun ada-get-indent-paramlist (orgpoint) | |
1830 ;; Returns the indentation (column #) for the new line after ORGPOINT. | |
1831 ;; Assumes point to be inside a parameter-list. | |
1832 (save-excursion | |
1833 (ada-search-ignore-string-comment "[^ \t\n]" t nil t) | |
1834 (cond | |
1835 ;; | |
1836 ;; in front of the first parameter | |
1837 ;; | |
1838 ((looking-at "(") | |
1839 (goto-char (match-end 0)) | |
1840 (current-column)) | |
1841 ;; | |
1842 ;; in front of another parameter | |
1843 ;; | |
1844 ((looking-at ";") | |
1845 (goto-char (cdr (ada-search-ignore-string-comment "(\\|;" t nil t))) | |
1846 (ada-goto-next-non-ws) | |
1847 (current-column)) | |
1848 ;; | |
1849 ;; inside a parameter declaration | |
1850 ;; | |
1851 (t | |
1852 (goto-char (cdr (ada-search-ignore-string-comment "(\\|;" t nil t))) | |
1853 (ada-goto-next-non-ws) | |
1854 (+ (current-column) ada-broken-indent))))) | |
1855 | |
1856 | |
1857 (defun ada-get-indent-end (orgpoint) | |
1858 ;; Returns the indentation (column #) for the new line after ORGPOINT. | |
1859 ;; Assumes point to be at the beginning of an end-statement. | |
1860 ;; Therefore it has to find the corresponding start. This can be a little | |
1861 ;; slow, if it has to search through big files with many nested blocks. | |
1862 ;; Signals an error if the corresponding block-start doesn't match. | |
1863 (let ((defun-name nil) | |
1864 (indent nil)) | |
1865 ;; | |
1866 ;; is the line already terminated by ';' ? | |
1867 ;; | |
1868 (if (save-excursion | |
1869 (ada-search-ignore-string-comment ";" nil orgpoint)) | |
1870 ;; | |
1871 ;; yes, look what's following 'end' | |
1872 ;; | |
1873 (progn | |
1874 (forward-word 1) | |
1875 (ada-goto-next-non-ws) | |
1876 (cond | |
1877 ;; | |
1878 ;; loop/select/if/case/record/select | |
1879 ;; | |
1880 ((looking-at "\\<\\(loop\\|select\\|if\\|case\\|record\\)\\>") | |
1881 (save-excursion | |
1882 (ada-check-matching-start | |
1883 (buffer-substring (match-beginning 0) | |
1884 (match-end 0))) | |
1885 (if (looking-at "\\<\\(loop\\|record\\)\\>") | |
1886 (progn | |
1887 (forward-word 1) | |
1888 (ada-goto-stmt-start))) | |
1889 ;; a label ? => skip it | |
1890 (if (looking-at "[a-zA-Z0-9_]+[ \n\t]+:") | |
1891 (progn | |
1892 (goto-char (match-end 0)) | |
1893 (ada-goto-next-non-ws))) | |
1894 ;; really looking-at the right thing ? | |
1895 (or (looking-at (concat "\\<\\(" | |
1896 "loop\\|select\\|if\\|case\\|" | |
1897 "record\\|while\\|type\\)\\>")) | |
1898 (progn | |
1899 (ada-search-ignore-string-comment | |
1900 (concat "\\<\\(" | |
1901 "loop\\|select\\|if\\|case\\|" | |
1902 "record\\|while\\|type\\)\\>"))) | |
1903 (backward-word 1)) | |
1904 (current-indentation))) | |
1905 ;; | |
1906 ;; a named block end | |
1907 ;; | |
1908 ((looking-at "[a-zA-Z0-9_]+") | |
1909 (setq defun-name (buffer-substring (match-beginning 0) | |
1910 (match-end 0))) | |
1911 (save-excursion | |
1912 (ada-goto-matching-start 0) | |
1913 (ada-check-defun-name defun-name) | |
1914 (current-indentation))) | |
1915 ;; | |
1916 ;; a block-end without name | |
1917 ;; | |
1918 ((looking-at ";") | |
1919 (save-excursion | |
1920 (ada-goto-matching-start 0) | |
1921 (if (looking-at "\\<begin\\>") | |
1922 (progn | |
1923 (setq indent (current-column)) | |
1924 (if (ada-goto-matching-decl-start t) | |
1925 (current-indentation) | |
1926 indent))))) | |
1927 ;; | |
1928 ;; anything else - should maybe signal an error ? | |
1929 ;; | |
1930 (t | |
1931 (+ (current-indentation) ada-broken-indent)))) | |
1932 | |
1933 (+ (current-indentation) ada-broken-indent)))) | |
1934 | |
1935 | |
1936 (defun ada-get-indent-case (orgpoint) | |
1937 ;; Returns the indentation (column #) for the new line after ORGPOINT. | |
1938 ;; Assumes point to be at the beginning of an case-statement. | |
1939 (let ((cur-indent (current-indentation)) | |
1940 (match-cons nil) | |
1941 (opos (point))) | |
1942 (cond | |
1943 ;; | |
1944 ;; case..is..when..=> | |
1945 ;; | |
1946 ((save-excursion | |
1947 (setq match-cons (ada-search-ignore-string-comment | |
1948 "[ \t\n]+=>" nil orgpoint))) | |
1949 (save-excursion | |
1950 (goto-char (car match-cons)) | |
1951 (if (not (ada-search-ignore-string-comment "\\<when\\>" t opos)) | |
1952 (error "missing 'when' between 'case' and '=>'")) | |
1953 (+ (current-indentation) ada-indent))) | |
1954 ;; | |
1955 ;; case..is..when | |
1956 ;; | |
1957 ((save-excursion | |
1958 (setq match-cons (ada-search-ignore-string-comment | |
1959 "\\<when\\>" nil orgpoint))) | |
1960 (goto-char (cdr match-cons)) | |
1961 (+ (current-indentation) ada-broken-indent)) | |
1962 ;; | |
1963 ;; case..is | |
1964 ;; | |
1965 ((save-excursion | |
1966 (setq match-cons (ada-search-ignore-string-comment | |
1967 "\\<is\\>" nil orgpoint))) | |
1968 (+ (current-indentation) ada-when-indent)) | |
1969 ;; | |
1970 ;; incomplete case | |
1971 ;; | |
1972 (t | |
1973 (+ (current-indentation) ada-broken-indent))))) | |
1974 | |
1975 | |
1976 (defun ada-get-indent-when (orgpoint) | |
1977 ;; Returns the indentation (column #) for the new line after ORGPOINT. | |
1978 ;; Assumes point to be at the beginning of an when-statement. | |
1979 (let ((cur-indent (current-indentation))) | |
1980 (if (ada-search-ignore-string-comment | |
1981 "[ \t\n]+=>" nil orgpoint) | |
1982 (+ cur-indent ada-indent) | |
1983 (+ cur-indent ada-broken-indent)))) | |
1984 | |
1985 | |
1986 (defun ada-get-indent-if (orgpoint) | |
1987 ;; Returns the indentation (column #) for the new line after ORGPOINT. | |
1988 ;; Assumes point to be at the beginning of an if-statement. | |
1989 (let ((cur-indent (current-indentation)) | |
1990 (match-cons nil)) | |
1991 ;; | |
1992 ;; if..then ? | |
1993 ;; | |
1994 (if (ada-search-but-not | |
1995 "\\<then\\>" "\\<and\\>[ \t\n]+\\<then\\>" nil orgpoint) | |
1996 | |
1997 (progn | |
1998 ;; | |
1999 ;; 'then' first in separate line ? | |
2000 ;; => indent according to 'then' | |
2001 ;; | |
2002 (if (save-excursion | |
2003 (back-to-indentation) | |
2004 (looking-at "\\<then\\>")) | |
2005 (setq cur-indent (current-indentation))) | |
2006 (forward-word 1) | |
2007 ;; | |
2008 ;; something follows 'then' ? | |
2009 ;; | |
2010 (if (setq match-cons | |
2011 (ada-search-ignore-string-comment | |
2012 "[^ \t\n]" nil orgpoint)) | |
2013 (progn | |
2014 (goto-char (car match-cons)) | |
2015 (+ ada-indent | |
2016 (- cur-indent (current-indentation)) | |
2017 (funcall (ada-indent-function t) orgpoint))) | |
2018 | |
2019 (+ cur-indent ada-indent))) | |
2020 | |
2021 (+ cur-indent ada-broken-indent)))) | |
2022 | |
2023 | |
2024 (defun ada-get-indent-block-start (orgpoint) | |
2025 ;; Returns the indentation (column #) for the new line after | |
2026 ;; ORGPOINT. Assumes point to be at the beginning of a block start | |
2027 ;; keyword. | |
2028 (let ((cur-indent (current-indentation)) | |
2029 (pos nil)) | |
2030 (cond | |
2031 ((save-excursion | |
2032 (forward-word 1) | |
2033 (setq pos (car (ada-search-ignore-string-comment | |
2034 "[^ \t\n]" nil orgpoint)))) | |
2035 (goto-char pos) | |
2036 (save-excursion | |
2037 (funcall (ada-indent-function t) orgpoint))) | |
2038 ;; | |
2039 ;; nothing follows the block-start | |
2040 ;; | |
2041 (t | |
2042 (+ (current-indentation) ada-indent))))) | |
2043 | |
2044 | |
2045 (defun ada-get-indent-subprog (orgpoint) | |
2046 ;; Returns the indentation (column #) for the new line after ORGPOINT. | |
2047 ;; Assumes point to be at the beginning of a subprog-/package-declaration. | |
2048 (let ((match-cons nil) | |
2049 (cur-indent (current-indentation)) | |
2050 (foundis nil) | |
2051 (addind 0) | |
2052 (fstart (point))) | |
2053 ;; | |
2054 ;; is there an 'is' in front of point ? | |
2055 ;; | |
2056 (if (save-excursion | |
2057 (setq match-cons | |
2058 (ada-search-ignore-string-comment | |
2059 "\\<is\\>\\|\\<do\\>" nil orgpoint))) | |
2060 ;; | |
2061 ;; yes, then skip to its end | |
2062 ;; | |
2063 (progn | |
2064 (setq foundis t) | |
2065 (goto-char (cdr match-cons))) | |
2066 ;; | |
2067 ;; no, then goto next non-ws, if there is one in front of point | |
2068 ;; | |
2069 (progn | |
2070 (if (ada-search-ignore-string-comment "[^ \t\n]" nil orgpoint) | |
2071 (ada-goto-next-non-ws) | |
2072 (goto-char orgpoint)))) | |
2073 | |
2074 (cond | |
2075 ;; | |
2076 ;; nothing follows 'is' | |
2077 ;; | |
2078 ((and | |
2079 foundis | |
2080 (save-excursion | |
2081 (not (ada-search-ignore-string-comment | |
2082 "[^ \t\n]" nil orgpoint t)))) | |
2083 (+ cur-indent ada-indent)) | |
2084 ;; | |
2085 ;; is abstract/separate/new ... | |
2086 ;; | |
2087 ((and | |
2088 foundis | |
2089 (save-excursion | |
2090 (setq match-cons | |
2091 (ada-search-ignore-string-comment | |
2092 "\\<\\(separate\\|new\\|abstract\\)\\>" | |
2093 nil orgpoint)))) | |
2094 (goto-char (car match-cons)) | |
2095 (ada-search-ignore-string-comment (concat ada-subprog-start-re | |
2096 "\\|\\<package\\>") t) | |
2097 (ada-get-indent-noindent orgpoint)) | |
2098 ;; | |
2099 ;; something follows 'is' | |
2100 ;; | |
2101 ((and | |
2102 foundis | |
2103 (save-excursion | |
2104 (ada-search-ignore-string-comment "[^ \t\n]" nil orgpoint)) | |
2105 (ada-goto-next-non-ws) | |
2106 (funcall (ada-indent-function t) orgpoint))) | |
2107 ;; | |
2108 ;; no 'is' but ';' | |
2109 ;; | |
2110 ((save-excursion | |
2111 (ada-search-ignore-string-comment ";" nil orgpoint)) | |
2112 cur-indent) | |
2113 ;; | |
2114 ;; no 'is' or ';' | |
2115 ;; | |
2116 (t | |
2117 (+ cur-indent ada-broken-indent))))) | |
2118 | |
2119 | |
2120 (defun ada-get-indent-noindent (orgpoint) | |
2121 ;; Returns the indentation (column #) for the new line after ORGPOINT. | |
2122 ;; Assumes point to be at the beginning of a 'noindent statement'. | |
2123 (if (save-excursion | |
2124 (ada-search-ignore-string-comment ";" nil orgpoint)) | |
2125 (current-indentation) | |
2126 (+ (current-indentation) ada-broken-indent))) | |
2127 | |
2128 | |
2129 (defun ada-get-indent-label (orgpoint) | |
2130 ;; Returns the indentation (column #) for the new line after ORGPOINT. | |
2131 ;; Assumes point to be at the beginning of a label or variable declaration. | |
2132 ;; Checks the context to decide if it's a label or a variable declaration. | |
2133 ;; This check might be a bit slow. | |
2134 (let ((match-cons nil) | |
2135 (cur-indent (current-indentation))) | |
2136 (goto-char (cdr (ada-search-ignore-string-comment ":"))) | |
2137 (cond | |
2138 ;; | |
2139 ;; loop label | |
2140 ;; | |
2141 ((save-excursion | |
2142 (setq match-cons (ada-search-ignore-string-comment | |
2143 ada-loop-start-re nil orgpoint))) | |
2144 (goto-char (car match-cons)) | |
2145 (ada-get-indent-loop orgpoint)) | |
2146 ;; | |
2147 ;; declare label | |
2148 ;; | |
2149 ((save-excursion | |
2150 (setq match-cons (ada-search-ignore-string-comment | |
2151 "\\<declare\\>" nil orgpoint))) | |
2152 (save-excursion | |
2153 (goto-char (car match-cons)) | |
2154 (+ (current-indentation) ada-indent))) | |
2155 ;; | |
2156 ;; complete statement following colon | |
2157 ;; | |
2158 ((save-excursion | |
2159 (ada-search-ignore-string-comment ";" nil orgpoint)) | |
2160 (if (ada-in-decl-p) | |
2161 cur-indent ; variable-declaration | |
2162 (- cur-indent ada-label-indent))) ; label | |
2163 ;; | |
2164 ;; broken statement | |
2165 ;; | |
2166 ((save-excursion | |
2167 (ada-search-ignore-string-comment "[^ \t\n]" nil orgpoint)) | |
2168 (if (ada-in-decl-p) | |
2169 (+ cur-indent ada-broken-indent) | |
2170 (+ cur-indent ada-broken-indent (- ada-label-indent)))) | |
2171 ;; | |
2172 ;; nothing follows colon | |
2173 ;; | |
2174 (t | |
2175 (if (ada-in-decl-p) | |
2176 (+ cur-indent ada-broken-indent) ; variable-declaration | |
2177 (- cur-indent ada-label-indent)))))) ; label | |
2178 | |
2179 | |
2180 (defun ada-get-indent-loop (orgpoint) | |
2181 ;; Returns the indentation (column #) for the new line after ORGPOINT. | |
2182 ;; Assumes point to be at the beginning of a loop statement | |
2183 ;; or (unfortunately) also a for ... use statement. | |
2184 (let ((match-cons nil) | |
2185 (pos (point))) | |
2186 (cond | |
2187 | |
2188 ;; | |
2189 ;; statement complete | |
2190 ;; | |
2191 ((save-excursion | |
2192 (ada-search-ignore-string-comment ";" nil orgpoint)) | |
2193 (current-indentation)) | |
2194 ;; | |
2195 ;; simple loop | |
2196 ;; | |
2197 ((looking-at "loop\\>") | |
2198 (ada-get-indent-block-start orgpoint)) | |
2199 | |
2200 ;; | |
2201 ;; 'for'- loop (or also a for ... use statement) | |
2202 ;; | |
2203 ((looking-at "for\\>") | |
2204 (cond | |
2205 ;; | |
2206 ;; for ... use | |
2207 ;; | |
2208 ((save-excursion | |
2209 (and | |
2210 (goto-char (match-end 0)) | |
2211 (ada-search-ignore-string-comment "[^ /n/t]" nil orgpoint) | |
2212 (not (backward-char 1)) | |
2213 (not (zerop (skip-chars-forward "_a-zA-Z0-9'"))) | |
2214 (ada-search-ignore-string-comment "[^ /n/t]" nil orgpoint) | |
2215 (not (backward-char 1)) | |
2216 (looking-at "\\<use\\>") | |
2217 ;; | |
2218 ;; check if there is a 'record' before point | |
2219 ;; | |
2220 (progn | |
2221 (setq match-cons (ada-search-ignore-string-comment | |
2222 "\\<record\\>" nil orgpoint)) | |
2223 t))) | |
2224 (if match-cons | |
2225 (goto-char (car match-cons))) | |
2226 (+ (current-indentation) ada-indent)) | |
2227 ;; | |
2228 ;; for..loop | |
2229 ;; | |
2230 ((save-excursion | |
2231 (setq match-cons (ada-search-ignore-string-comment | |
2232 "\\<loop\\>" nil orgpoint))) | |
2233 (goto-char (car match-cons)) | |
2234 ;; | |
2235 ;; indent according to 'loop', if it's first in the line; | |
2236 ;; otherwise to 'for' | |
2237 ;; | |
2238 (if (not (save-excursion | |
2239 (back-to-indentation) | |
2240 (looking-at "\\<loop\\>"))) | |
2241 (goto-char pos)) | |
2242 (+ (current-indentation) ada-indent)) | |
2243 ;; | |
2244 ;; for-statement is broken | |
2245 ;; | |
2246 (t | |
2247 (+ (current-indentation) ada-broken-indent)))) | |
2248 | |
2249 ;; | |
2250 ;; 'while'-loop | |
2251 ;; | |
2252 ((looking-at "while\\>") | |
2253 ;; | |
2254 ;; while..loop ? | |
2255 ;; | |
2256 (if (save-excursion | |
2257 (setq match-cons (ada-search-ignore-string-comment | |
2258 "\\<loop\\>" nil orgpoint))) | |
2259 | |
2260 (progn | |
2261 (goto-char (car match-cons)) | |
2262 ;; | |
2263 ;; indent according to 'loop', if it's first in the line; | |
2264 ;; otherwise to 'while'. | |
2265 ;; | |
2266 (if (not (save-excursion | |
2267 (back-to-indentation) | |
2268 (looking-at "\\<loop\\>"))) | |
2269 (goto-char pos)) | |
2270 (+ (current-indentation) ada-indent)) | |
2271 | |
2272 (+ (current-indentation) ada-broken-indent)))))) | |
2273 | |
2274 | |
2275 (defun ada-get-indent-type (orgpoint) | |
2276 ;; Returns the indentation (column #) for the new line after ORGPOINT. | |
2277 ;; Assumes point to be at the beginning of a type statement. | |
2278 (let ((match-dat nil)) | |
2279 (cond | |
2280 ;; | |
2281 ;; complete record declaration | |
2282 ;; | |
2283 ((save-excursion | |
2284 (and | |
2285 (setq match-dat (ada-search-ignore-string-comment "\\<end\\>" | |
2286 nil | |
2287 orgpoint)) | |
2288 (ada-goto-next-non-ws) | |
2289 (looking-at "\\<record\\>") | |
2290 (forward-word 1) | |
2291 (ada-goto-next-non-ws) | |
2292 (looking-at ";"))) | |
2293 (goto-char (car match-dat)) | |
2294 (current-indentation)) | |
2295 ;; | |
2296 ;; record type | |
2297 ;; | |
2298 ((save-excursion | |
2299 (setq match-dat (ada-search-ignore-string-comment "\\<record\\>" | |
2300 nil | |
2301 orgpoint))) | |
2302 (goto-char (car match-dat)) | |
2303 (+ (current-indentation) ada-indent)) | |
2304 ;; | |
2305 ;; complete type declaration | |
2306 ;; | |
2307 ((save-excursion | |
2308 (ada-search-ignore-string-comment ";" nil orgpoint)) | |
2309 (current-indentation)) | |
2310 ;; | |
2311 ;; type ... is | |
2312 ;; | |
2313 ((save-excursion | |
2314 (ada-search-ignore-string-comment "\\<is\\>" nil orgpoint)) | |
2315 (+ (current-indentation) ada-indent)) | |
2316 ;; | |
2317 ;; broken statement | |
2318 ;; | |
2319 (t | |
2320 (+ (current-indentation) ada-broken-indent))))) | |
2321 | |
2322 | |
2323 ;;; ---- support-functions for indentation | |
2324 | |
2325 ;;; ---- searching and matching | |
2326 | |
2327 (defun ada-goto-stmt-start (&optional limit) | |
2328 ;; Moves point to the beginning of the statement that point is in or | |
2329 ;; after. Returns the new position of point. Beginnings are found | |
2330 ;; by searching for 'ada-end-stmt-re' and then moving to the | |
2331 ;; following non-ws that is not a comment. LIMIT is actually not | |
2332 ;; used by the indentation functions. | |
2333 (let ((match-dat nil) | |
2334 (orgpoint (point))) | |
2335 | |
2336 (setq match-dat (ada-search-prev-end-stmt limit)) | |
2337 (if match-dat | |
2338 ;; | |
2339 ;; found a previous end-statement => check if anything follows | |
2340 ;; | |
2341 (progn | |
2342 (if (not | |
2343 (save-excursion | |
2344 (goto-char (cdr match-dat)) | |
2345 (ada-search-ignore-string-comment | |
2346 "[^ \t\n]" nil orgpoint))) | |
2347 ;; | |
2348 ;; nothing follows => it's the end-statement directly in | |
2349 ;; front of point => search again | |
2350 ;; | |
2351 (setq match-dat (ada-search-prev-end-stmt limit))) | |
2352 ;; | |
2353 ;; if found the correct end-stetement => goto next non-ws | |
2354 ;; | |
2355 (if match-dat | |
2356 (goto-char (cdr match-dat))) | |
2357 (ada-goto-next-non-ws)) | |
2358 | |
2359 ;; | |
2360 ;; no previous end-statement => we are at the beginning of the | |
2361 ;; accessible part of the buffer | |
2362 ;; | |
2363 (progn | |
2364 (goto-char (point-min)) | |
2365 ;; | |
2366 ;; skip to the very first statement, if there is one | |
2367 ;; | |
2368 (if (setq match-dat | |
2369 (ada-search-ignore-string-comment | |
2370 "[^ \t\n]" nil orgpoint)) | |
2371 (goto-char (car match-dat)) | |
2372 (goto-char orgpoint)))) | |
2373 | |
2374 | |
2375 (point))) | |
2376 | |
2377 | |
2378 (defun ada-search-prev-end-stmt (&optional limit) | |
2379 ;; Moves point to previous end-statement. Returns a cons cell whose | |
2380 ;; car is the beginning and whose cdr the end of the match. | |
2381 ;; End-statements are defined by 'ada-end-stmt-re'. Checks for | |
2382 ;; certain keywords if they follow 'end', which means they are no | |
2383 ;; end-statement there. | |
2384 (let ((match-dat nil) | |
2385 (pos nil) | |
2386 (found nil)) | |
2387 ;; | |
2388 ;; search until found or beginning-of-buffer | |
2389 ;; | |
2390 (while | |
2391 (and | |
2392 (not found) | |
2393 (setq match-dat (ada-search-ignore-string-comment ada-end-stmt-re | |
2394 t | |
2395 limit))) | |
2396 | |
2397 (goto-char (car match-dat)) | |
2398 | |
2399 (if (not (ada-in-open-paren-p)) | |
2400 ;; | |
2401 ;; check if there is an 'end' in front of the match | |
2402 ;; | |
2403 (if (not (and | |
2404 (looking-at "\\<\\(record\\|loop\\|select\\)\\>") | |
2405 (save-excursion | |
2406 (ada-goto-previous-word) | |
2407 (looking-at "\\<end\\>")))) | |
2408 (setq found t) | |
2409 | |
2410 (backward-word 1)))) ; end of loop | |
2411 | |
2412 (if found | |
2413 match-dat | |
2414 nil))) | |
2415 | |
2416 | |
2417 (defun ada-goto-next-non-ws (&optional limit) | |
2418 ;; Skips whitespaces, newlines and comments to next non-ws | |
2419 ;; character. Signals an error if there is no more such character | |
2420 ;; and limit is nil. | |
2421 (let ((match-cons nil)) | |
2422 (setq match-cons (ada-search-ignore-string-comment | |
2423 "[^ \t\n]" nil limit t)) | |
2424 (if match-cons | |
2425 (goto-char (car match-cons)) | |
2426 (if (not limit) | |
2427 (error "no more non-ws") | |
2428 nil)))) | |
2429 | |
2430 | |
2431 (defun ada-goto-stmt-end (&optional limit) | |
2432 ;; Moves point to the end of the statement that point is in or | |
2433 ;; before. Returns the new position of point or nil if not found. | |
2434 (if (ada-search-ignore-string-comment ada-end-stmt-re nil limit) | |
2435 (point) | |
2436 nil)) | |
2437 | |
2438 | |
2439 (defun ada-goto-previous-word () | |
2440 ;; Moves point to the beginning of the previous word of ada-code. | |
2441 ;; Returns the new position of point or nil if not found. | |
2442 (let ((match-cons nil) | |
2443 (orgpoint (point))) | |
2444 (if (setq match-cons | |
2445 (ada-search-ignore-string-comment "[^ \t\n]" t nil t)) | |
2446 ;; | |
2447 ;; move to the beginning of the word found | |
2448 ;; | |
2449 (progn | |
2450 (goto-char (cdr match-cons)) | |
2451 (skip-chars-backward "_a-zA-Z0-9") | |
2452 (point)) | |
2453 ;; | |
2454 ;; if not found, restore old position of point | |
2455 ;; | |
2456 (progn | |
2457 (goto-char orgpoint) | |
2458 'nil)))) | |
2459 | |
2460 | |
2461 (defun ada-check-matching-start (keyword) | |
2462 ;; Signals an error if matching block start is not KEYWORD. | |
2463 ;; Moves point to the matching block start. | |
2464 (ada-goto-matching-start 0) | |
2465 (if (not (looking-at (concat "\\<" keyword "\\>"))) | |
2466 (error (concat | |
2467 "matching start is not '" | |
2468 keyword "'")))) | |
2469 | |
2470 | |
2471 (defun ada-check-defun-name (defun-name) | |
2472 ;; Checks if the name of the matching defun really is DEFUN-NAME. | |
2473 ;; Assumes point to be already positioned by 'ada-goto-matching-start'. | |
2474 ;; Moves point to the beginning of the declaration. | |
2475 | |
2476 ;; | |
2477 ;; 'accept' or 'package' ? | |
2478 ;; | |
2479 (if (not (looking-at "\\<\\(accept\\|package\\|task\\)\\>")) | |
2480 (ada-goto-matching-decl-start)) | |
2481 ;; | |
2482 ;; 'begin' of 'procedure'/'function'/'task' or 'declare' | |
2483 ;; | |
2484 (save-excursion | |
2485 ;; | |
2486 ;; a named 'declare'-block ? | |
2487 ;; | |
2488 (if (looking-at "\\<declare\\>") | |
2489 (ada-goto-stmt-start) | |
2490 ;; | |
2491 ;; no, => 'procedure'/'function'/'task' | |
2492 ;; | |
2493 (progn | |
2494 (forward-word 2) | |
2495 (backward-word 1) | |
2496 ;; | |
2497 ;; skip 'body' or 'type' | |
2498 ;; | |
2499 (if (looking-at "\\<\\(body\\|type\\)\\>") | |
2500 (forward-word 1)) | |
2501 (forward-sexp 1) | |
2502 (backward-sexp 1))) | |
2503 ;; | |
2504 ;; should be looking-at the correct name | |
2505 ;; | |
2506 (if (not (looking-at (concat "\\<" defun-name "\\>"))) | |
2507 (error | |
2508 (concat | |
2509 "matching defun has different name: " | |
2510 (buffer-substring | |
2511 (point) | |
2512 (progn | |
2513 (forward-sexp 1) | |
2514 (point)))))))) | |
2515 | |
2516 | |
2517 (defun ada-goto-matching-decl-start (&optional noerror nogeneric) | |
2518 ;; Moves point to the matching declaration start of the current 'begin'. | |
2519 ;; If NOERROR is non-nil, it only returns nil if no match was found. | |
2520 (let ((nest-count 1) | |
2521 (pos nil) | |
2522 (first t) | |
2523 (flag nil)) | |
2524 ;; | |
2525 ;; search backward for interesting keywords | |
2526 ;; | |
2527 (while (and | |
2528 (not (zerop nest-count)) | |
2529 (ada-search-ignore-string-comment | |
2530 (concat "\\<\\(" | |
2531 "is\\|separate\\|end\\|declare\\|new\\|begin\\|generic" | |
2532 "\\)\\>") t)) | |
2533 ;; | |
2534 ;; calculate nest-depth | |
2535 ;; | |
2536 (cond | |
2537 ;; | |
2538 ((looking-at "end") | |
2539 (ada-goto-matching-start 1 noerror) | |
2540 (if (progn | |
2541 (looking-at "begin")) | |
2542 (setq nest-count (1+ nest-count)))) | |
2543 ;; | |
2544 ((looking-at "declare\\|generic") | |
2545 (setq nest-count (1- nest-count)) | |
2546 (setq first nil)) | |
2547 ;; | |
2548 ((looking-at "is") | |
2549 ;; check if it is only a type definition | |
2550 (if (save-excursion | |
2551 (ada-goto-previous-word) | |
2552 (skip-chars-backward "a-zA-Z0-9_.'") | |
2553 (if (save-excursion | |
2554 (backward-char 1) | |
2555 (looking-at ")")) | |
2556 (progn | |
2557 (forward-char 1) | |
2558 (backward-sexp 1) | |
2559 (skip-chars-backward "a-zA-Z0-9_.'") | |
2560 )) | |
2561 (ada-goto-previous-word) | |
2562 (looking-at "\\<type\\>")) ; end of save-excursion | |
2563 (goto-char (match-beginning 0)) | |
2564 (progn | |
2565 (setq nest-count (1- nest-count)) | |
2566 (setq first nil)))) | |
2567 | |
2568 ;; | |
2569 ((looking-at "new") | |
2570 (if (save-excursion | |
2571 (ada-goto-previous-word) | |
2572 (looking-at "is")) | |
2573 (goto-char (match-beginning 0)))) | |
2574 ;; | |
2575 ((and first | |
2576 (looking-at "begin")) | |
2577 (setq nest-count 0) | |
2578 (setq flag t)) | |
2579 ;; | |
2580 (t | |
2581 (setq nest-count (1+ nest-count)) | |
2582 (setq first nil))) | |
2583 | |
2584 ) ;; end of loop | |
2585 | |
2586 ;; check if declaration-start is really found | |
2587 (if (not | |
2588 (and | |
2589 (zerop nest-count) | |
2590 (not flag) | |
2591 (progn | |
2592 (if (looking-at "is") | |
2593 (ada-search-ignore-string-comment | |
2594 "\\<\\(procedure\\|function\\|task\\|package\\)\\>" t) | |
2595 (looking-at "declare\\|generic"))))) | |
2596 (if noerror nil | |
2597 (error "no matching procedure/function/task/declare/package")) | |
2598 t))) | |
2599 | |
2600 | |
2601 (defun ada-goto-matching-start (&optional nest-level noerror gotothen) | |
2602 ;; Moves point to the beginning of a block-start. Which block | |
2603 ;; depends on the value of NEST-LEVEL, which defaults to zero. If | |
2604 ;; NOERROR is non-nil, it only returns nil if no matching start was | |
2605 ;; found. If GOTOTHEN is non-nil, point moves to the 'then' | |
2606 ;; following 'if'. | |
2607 (let ((nest-count (if nest-level nest-level 0)) | |
2608 (found nil) | |
2609 (pos nil)) | |
2610 | |
2611 ;; | |
2612 ;; search backward for interesting keywords | |
2613 ;; | |
2614 (while (and | |
2615 (not found) | |
2616 (ada-search-ignore-string-comment | |
2617 (concat "\\<\\(" | |
2618 "end\\|loop\\|select\\|begin\\|case\\|" | |
2619 "if\\|task\\|package\\|record\\|do\\)\\>") | |
2620 t)) | |
2621 | |
2622 ;; | |
2623 ;; calculate nest-depth | |
2624 ;; | |
2625 (cond | |
2626 ;; found block end => increase nest depth | |
2627 ((looking-at "end") | |
2628 (setq nest-count (1+ nest-count))) | |
2629 ;; found loop/select/record/case/if => check if it starts or | |
2630 ;; ends a block | |
2631 ((looking-at "loop\\|select\\|record\\|case\\|if") | |
2632 (setq pos (point)) | |
2633 (save-excursion | |
2634 ;; | |
2635 ;; check if keyword follows 'end' | |
2636 ;; | |
2637 (ada-goto-previous-word) | |
2638 (if (looking-at "\\<end\\>") | |
2639 ;; it ends a block => increase nest depth | |
2640 (progn | |
2641 (setq nest-count (1+ nest-count)) | |
2642 (setq pos (point))) | |
2643 ;; it starts a block => decrease nest depth | |
2644 (setq nest-count (1- nest-count)))) | |
2645 (goto-char pos)) | |
2646 ;; found package start => check if it really is a block | |
2647 ((looking-at "package") | |
2648 (save-excursion | |
2649 (ada-search-ignore-string-comment "\\<is\\>") | |
2650 (ada-goto-next-non-ws) | |
2651 ;; ignore it if it is only a declaration with 'new' | |
2652 (if (not (looking-at "\\<new\\>")) | |
2653 (setq nest-count (1- nest-count))))) | |
2654 ;; found task start => check if it has a body | |
2655 ((looking-at "task") | |
2656 (save-excursion | |
2657 (forward-word 1) | |
2658 (ada-goto-next-non-ws) | |
2659 ;; ignore it if it has no body | |
2660 (if (not (looking-at "\\<body\\>")) | |
2661 (setq nest-count (1- nest-count))))) | |
2662 ;; all the other block starts | |
2663 (t | |
2664 (setq nest-count (1- nest-count)))) ; end of 'cond' | |
2665 | |
2666 ;; match is found, if nest-depth is zero | |
2667 ;; | |
2668 (setq found (zerop nest-count))) ; end of loop | |
2669 | |
2670 (if found | |
2671 ;; | |
2672 ;; match found => is there anything else to do ? | |
2673 ;; | |
2674 (progn | |
2675 (cond | |
2676 ;; | |
2677 ;; found 'if' => skip to 'then', if it's on a separate line | |
2678 ;; and GOTOTHEN is non-nil | |
2679 ;; | |
2680 ((and | |
2681 gotothen | |
2682 (looking-at "if") | |
2683 (save-excursion | |
2684 (ada-search-ignore-string-comment "\\<then\\>" nil nil) | |
2685 (back-to-indentation) | |
2686 (looking-at "\\<then\\>"))) | |
2687 (goto-char (match-beginning 0))) | |
2688 ;; | |
2689 ;; found 'do' => skip back to 'accept' | |
2690 ;; | |
2691 ((looking-at "do") | |
2692 (if (not (ada-search-ignore-string-comment "\\<accept\\>" t nil)) | |
2693 (error "missing 'accept' in front of 'do'")))) | |
2694 (point)) | |
2695 | |
2696 (if noerror | |
2697 nil | |
2698 (error "no matching start"))))) | |
2699 | |
2700 | |
2701 (defun ada-goto-matching-end (&optional nest-level noerror) | |
2702 ;; Moves point to the end of a block. Which block depends on the | |
2703 ;; value of NEST-LEVEL, which defaults to zero. If NOERROR is | |
2704 ;; non-nil, it only returns nil if found no matching start. | |
2705 (let ((nest-count (if nest-level nest-level 0)) | |
2706 (found nil)) | |
2707 | |
2708 ;; | |
2709 ;; search forward for interesting keywords | |
2710 ;; | |
2711 (while (and | |
2712 (not found) | |
2713 (ada-search-ignore-string-comment | |
2714 (concat "\\<\\(end\\|loop\\|select\\|begin\\|case\\|" | |
2715 "if\\|task\\|package\\|record\\|do\\)\\>"))) | |
2716 | |
2717 ;; | |
2718 ;; calculate nest-depth | |
2719 ;; | |
2720 (backward-word 1) | |
2721 (cond | |
2722 ;; found block end => decrease nest depth | |
2723 ((looking-at "\\<end\\>") | |
2724 (setq nest-count (1- nest-count)) | |
2725 ;; skip the following keyword | |
2726 (if (progn | |
2727 (skip-chars-forward "end") | |
2728 (ada-goto-next-non-ws) | |
2729 (looking-at "\\<\\(loop\\|select\\|record\\|case\\|if\\)\\>")) | |
2730 (forward-word 1))) | |
2731 ;; found package start => check if it really starts a block | |
2732 ((looking-at "\\<package\\>") | |
2733 (ada-search-ignore-string-comment "\\<is\\>") | |
2734 (ada-goto-next-non-ws) | |
2735 ;; ignore and skip it if it is only a 'new' package | |
2736 (if (not (looking-at "\\<new\\>")) | |
2737 (setq nest-count (1+ nest-count)) | |
2738 (skip-chars-forward "new"))) | |
2739 ;; all the other block starts | |
2740 (t | |
2741 (setq nest-count (1+ nest-count)) | |
2742 (forward-word 1))) ; end of 'cond' | |
2743 | |
2744 ;; match is found, if nest-depth is zero | |
2745 ;; | |
2746 (setq found (zerop nest-count))) ; end of loop | |
2747 | |
2748 (if (not found) | |
2749 (if noerror | |
2750 nil | |
2751 (error "no matching end")) | |
2752 t))) | |
2753 | |
2754 | |
2755 (defun ada-forward-sexp-ignore-comment () | |
2756 ;; Skips one sexp forward, ignoring comments. | |
2757 (while (looking-at "[ \t\n]*--") | |
2758 (skip-chars-forward "[ \t\n]") | |
2759 (end-of-line)) | |
2760 (forward-sexp 1)) | |
2761 | |
2762 | |
2763 (defun ada-search-ignore-string-comment | |
2764 (search-re &optional backward limit paramlists) | |
2765 ;; Regexp-Search for SEARCH-RE, ignoring comments, strings and | |
2766 ;; parameter lists, if PARAMLISTS is nil. Returns a cons cell of | |
2767 ;; begin and end of match data or nil, if not found. | |
2768 (let ((found nil) | |
2769 (begin nil) | |
2770 (end nil) | |
2771 (pos nil) | |
2772 (search-func | |
2773 (if backward 're-search-backward | |
2774 're-search-forward))) | |
2775 | |
2776 ;; | |
2777 ;; search until found or end-of-buffer | |
2778 ;; | |
2779 (while (and (not found) | |
2780 (funcall search-func search-re limit 1)) | |
2781 (setq begin (match-beginning 0)) | |
2782 (setq end (match-end 0)) | |
2783 | |
2784 (cond | |
2785 ;; | |
2786 ;; found in comment => skip it | |
2787 ;; | |
2788 ((ada-in-comment-p) | |
2789 (if backward | |
2790 (progn | |
2791 (re-search-backward "--" nil 1) | |
2792 (goto-char (match-beginning 0))) | |
2793 (progn | |
2794 (forward-line 1) | |
2795 (beginning-of-line)))) | |
2796 ;; | |
2797 ;; found in string => skip it | |
2798 ;; | |
2799 ((ada-in-string-p) | |
2800 (if backward | |
2801 (progn | |
2802 (re-search-backward "\"\\|#" nil 1) | |
2803 (goto-char (match-beginning 0)))) | |
2804 (re-search-forward "\"\\|#" nil 1)) | |
2805 ;; | |
2806 ;; found character constant => ignore it | |
2807 ;; | |
2808 ((save-excursion | |
2809 (setq pos (- (point) (if backward 1 2))) | |
2810 (and (char-after pos) | |
2811 (= (char-after pos) ?') | |
2812 (= (char-after (+ pos 2)) ?'))) | |
2813 ()) | |
2814 ;; | |
2815 ;; found a parameter-list but should ignore it => skip it | |
2816 ;; | |
2817 ((and (not paramlists) | |
2818 (ada-in-paramlist-p)) | |
2819 (if backward | |
2820 (ada-search-ignore-string-comment "(" t nil t))) | |
2821 ;; | |
2822 ;; directly in front of a comment => skip it, if searching forward | |
2823 ;; | |
2824 ((save-excursion | |
2825 (goto-char begin) | |
2826 (looking-at "--")) | |
2827 (if (not backward) | |
2828 (progn | |
2829 (forward-line 1) | |
2830 (beginning-of-line)))) | |
2831 ;; | |
2832 ;; found what we were looking for | |
2833 ;; | |
2834 (t | |
2835 (setq found t)))) ; end of loop | |
2836 | |
2837 (if found | |
2838 (cons begin end) | |
2839 nil))) | |
2840 | |
2841 | |
2842 (defun ada-search-but-not (search-re not-search-re &optional backward limit) | |
2843 ;; Searches SEARCH-RE, ignoring parts of NOT-SEARCH-RE, strings, | |
2844 ;; comments and parameter-lists. | |
2845 (let ((begin nil) | |
2846 (end nil) | |
2847 (begin-not nil) | |
2848 (begin-end nil) | |
2849 (end-not nil) | |
2850 (ret-cons nil) | |
2851 (found nil)) | |
2852 | |
2853 ;; | |
2854 ;; search until found or end-of-buffer | |
2855 ;; | |
2856 (while (and | |
2857 (not found) | |
2858 (save-excursion | |
2859 (setq ret-cons | |
2860 (ada-search-ignore-string-comment search-re | |
2861 backward limit)) | |
2862 (if (consp ret-cons) | |
2863 (progn | |
2864 (setq begin (car ret-cons)) | |
2865 (setq end (cdr ret-cons)) | |
2866 t) | |
2867 nil))) | |
2868 | |
2869 (if (or | |
2870 ;; | |
2871 ;; if no NO-SEARCH-RE was found | |
2872 ;; | |
2873 (not | |
2874 (save-excursion | |
2875 (setq ret-cons | |
2876 (ada-search-ignore-string-comment not-search-re | |
2877 backward nil)) | |
2878 (if (consp ret-cons) | |
2879 (progn | |
2880 (setq begin-not (car ret-cons)) | |
2881 (setq end-not (cdr ret-cons)) | |
2882 t) | |
2883 nil))) | |
2884 ;; | |
2885 ;; or this NO-SEARCH-RE is not a part of the SEARCH-RE | |
2886 ;; found before. | |
2887 ;; | |
2888 (or | |
2889 (<= end-not begin) | |
2890 (>= begin-not end))) | |
2891 | |
2892 (setq found t) | |
2893 | |
2894 ;; | |
2895 ;; not found the correct match => skip this match | |
2896 ;; | |
2897 (goto-char (if backward | |
2898 begin | |
2899 end)))) ; end of loop | |
2900 | |
2901 (if found | |
2902 (progn | |
2903 (goto-char begin) | |
2904 (cons begin end)) | |
2905 nil))) | |
2906 | |
2907 | |
2908 (defun ada-goto-prev-nonblank-line ( &optional ignore-comment) | |
2909 ;; Moves point to previous non-blank line, | |
2910 ;; ignoring comments if IGNORE-COMMENT is non-nil. | |
2911 ;; It returns t if a matching line was found. | |
2912 (let ((notfound t) | |
2913 (newpoint nil)) | |
2914 | |
2915 (save-excursion | |
2916 ;; | |
2917 ;; backward one line, if there is one | |
2918 ;; | |
2919 (if (zerop (forward-line -1)) | |
2920 ;; | |
2921 ;; there is some kind of previous line | |
2922 ;; | |
2923 (progn | |
2924 (beginning-of-line) | |
2925 (setq newpoint (point)) | |
2926 | |
2927 ;; | |
2928 ;; search until found or beginning-of-buffer | |
2929 ;; | |
2930 (while (and (setq notfound | |
2931 (or (looking-at "[ \t]*$") | |
2932 (and (looking-at "[ \t]*--") | |
2933 ignore-comment))) | |
2934 (not (in-limit-line-p))) | |
2935 (forward-line -1) | |
2936 (beginning-of-line) | |
2937 (setq newpoint (point))) ; end of loop | |
2938 | |
2939 )) ; end of if | |
2940 | |
2941 ) ; end of save-excursion | |
2942 | |
2943 (if notfound nil | |
2944 (progn | |
2945 (goto-char newpoint) | |
2946 t)))) | |
2947 | |
2948 | |
2949 (defun ada-goto-next-nonblank-line ( &optional ignore-comment) | |
2950 ;; Moves point to next non-blank line, | |
2951 ;; ignoring comments if IGNORE-COMMENT is non-nil. | |
2952 ;; It returns t if a matching line was found. | |
2953 (let ((notfound t) | |
2954 (newpoint nil)) | |
2955 | |
2956 (save-excursion | |
2957 ;; | |
2958 ;; forward one line | |
2959 ;; | |
2960 (if (zerop (forward-line 1)) | |
2961 ;; | |
2962 ;; there is some kind of previous line | |
2963 ;; | |
2964 (progn | |
2965 (beginning-of-line) | |
2966 (setq newpoint (point)) | |
2967 | |
2968 ;; | |
2969 ;; search until found or end-of-buffer | |
2970 ;; | |
2971 (while (and (setq notfound | |
2972 (or (looking-at "[ \t]*$") | |
2973 (and (looking-at "[ \t]*--") | |
2974 ignore-comment))) | |
2975 (not (in-limit-line-p))) | |
2976 (forward-line 1) | |
2977 (beginning-of-line) | |
2978 (setq newpoint (point))) ; end of loop | |
2979 | |
2980 )) ; end of if | |
2981 | |
2982 ) ; end of save-excursion | |
2983 | |
2984 (if notfound nil | |
2985 (progn | |
2986 (goto-char newpoint) | |
2987 t)))) | |
2988 | |
2989 | |
2990 ;; ---- boolean functions for indentation | |
2991 | |
2992 (defun ada-in-decl-p () | |
2993 ;; Returns t if point is inside a declarative part. | |
2994 ;; Assumes point to be at the end of a statement. | |
2995 (or | |
2996 (ada-in-paramlist-p) | |
2997 (save-excursion | |
2998 (ada-goto-matching-decl-start t)))) | |
2999 | |
3000 | |
3001 (defun ada-looking-at-semi-or () | |
3002 ;; Returns t if looking-at an 'or' following a semicolon. | |
3003 (save-excursion | |
3004 (and (looking-at "\\<or\\>") | |
3005 (progn | |
3006 (forward-word 1) | |
3007 (ada-goto-stmt-start) | |
3008 (looking-at "\\<or\\>"))))) | |
3009 | |
3010 | |
3011 (defun ada-looking-at-semi-private () | |
3012 ;; Returns t if looking-at an 'private' following a semicolon. | |
3013 (save-excursion | |
3014 (and (looking-at "\\<private\\>") | |
3015 (progn | |
3016 (forward-word 1) | |
3017 (ada-goto-stmt-start) | |
3018 (looking-at "\\<private\\>"))))) | |
3019 | |
3020 | |
3021 (defun in-limit-line-p () | |
3022 ;; Returns t if point is in first or last accessible line. | |
3023 (or | |
3024 (>= 1 (count-lines (point-min) (point))) | |
3025 (>= 1 (count-lines (point) (point-max))))) | |
3026 | |
3027 | |
3028 (defun ada-in-comment-p () | |
3029 ;; Returns t if inside a comment. | |
3030 (save-excursion (and (re-search-backward "\\(--\\|\n\\)" nil 1) | |
3031 (looking-at "-")))) | |
3032 | |
3033 | |
3034 (defun ada-in-string-p () | |
3035 ;; Returns t if point is inside a string | |
3036 ;; (Taken from pascal-mode.el, modified by MH). | |
3037 (save-excursion | |
3038 (and | |
3039 (nth 3 (parse-partial-sexp | |
3040 (save-excursion | |
3041 (beginning-of-line) | |
3042 (point)) (point))) | |
3043 ;; check if 'string quote' is only a character constant | |
3044 (progn | |
3045 (re-search-backward "\"\\|#" nil t) | |
3046 (not (= (char-after (1- (point))) ?')))))) | |
3047 | |
3048 | |
3049 (defun ada-in-string-or-comment-p () | |
3050 ;; Returns t if point is inside a string or a comment. | |
3051 (or (ada-in-comment-p) | |
3052 (ada-in-string-p))) | |
3053 | |
3054 | |
3055 (defun ada-in-paramlist-p () | |
3056 ;; Returns t if point is inside a parameter-list | |
3057 ;; following 'function'/'procedure'/'package'. | |
3058 (save-excursion | |
3059 (and | |
3060 (re-search-backward "(\\|)" nil t) | |
3061 ;; inside parentheses ? | |
3062 (looking-at "(") | |
3063 (backward-word 2) | |
3064 ;; right keyword before paranthesis ? | |
3065 (looking-at (concat "\\<\\(" | |
3066 "procedure\\|function\\|body\\|package\\|" | |
3067 "task\\|entry\\|accept\\)\\>")) | |
3068 (re-search-forward ")\\|:" nil t) | |
3069 ;; at least one ':' inside the parentheses ? | |
3070 (not (backward-char 1)) | |
3071 (looking-at ":")))) | |
3072 | |
3073 | |
3074 ;; not really a boolean function ... | |
3075 (defun ada-in-open-paren-p () | |
3076 ;; If point is somewhere behind an open parenthesis not yet closed, | |
3077 ;; it returns the column # of the first non-ws behind this open | |
3078 ;; parenthesis, otherwise nil." | |
3079 (let ((nest-count 1) | |
3080 (limit nil) | |
3081 (found nil) | |
3082 (pos nil) | |
3083 (col nil) | |
3084 (counter ada-search-paren-line-count-limit)) | |
3085 | |
3086 ;; | |
3087 ;; get search-limit | |
3088 ;; | |
3089 (if ada-search-paren-line-count-limit | |
3090 (setq limit | |
3091 (save-excursion | |
3092 (while (not (zerop counter)) | |
3093 (ada-goto-prev-nonblank-line) | |
3094 (setq counter (1- counter))) | |
3095 (beginning-of-line) | |
3096 (point)))) | |
3097 | |
3098 (save-excursion | |
3099 | |
3100 ;; | |
3101 ;; loop until found or limit | |
3102 ;; | |
3103 (while (and | |
3104 (not found) | |
3105 (ada-search-ignore-string-comment "(\\|)" t limit t)) | |
3106 (setq nest-count | |
3107 (if (looking-at ")") | |
3108 (1+ nest-count) | |
3109 (1- nest-count))) | |
3110 (setq found (zerop nest-count))) ; end of loop | |
3111 | |
3112 (if found | |
3113 ;; if found => return column of first non-ws after the parenthesis | |
3114 (progn | |
3115 (forward-char 1) | |
3116 (if (save-excursion | |
3117 (re-search-forward "[^ \t]" nil 1) | |
3118 (backward-char 1) | |
3119 (and | |
3120 (not (looking-at "\n")) | |
3121 (setq col (current-column)))) | |
3122 col | |
3123 (current-column))) | |
3124 nil)))) | |
3125 | |
3126 | |
3127 ;;;-----------------------------;;; | |
3128 ;;; Simple Completion Functions ;;; | |
3129 ;;;-----------------------------;;; | |
3130 | |
3131 ;; These are my first steps in Emacs-Lisp ... :-) They can be replaced | |
3132 ;; by functions based on the output of the Gnatf Tool that comes with | |
3133 ;; the GNAT Ada compiler. See the file ada-xref.el (MH) But you might | |
3134 ;; use these functions if you don't use GNAT | |
3135 | |
3136 (defun ada-use-last-with () | |
3137 "Inserts the package name of the last 'with' statement after use." | |
3138 (interactive) | |
3139 (let ((pakname nil)) | |
3140 (save-excursion | |
3141 (forward-word -1) | |
3142 (if (looking-at "use") | |
3143 ;; | |
3144 ;; find last 'with' | |
3145 ;; | |
3146 (progn (re-search-backward | |
3147 "\\(\\<with\\s-+\\)\\([a-zA-Z0-9_.]+\\)\\(\\s-*;\\)") | |
3148 ;; | |
3149 ;; get the name of the package | |
3150 ;; | |
3151 (setq pakname (concat | |
3152 (buffer-substring (match-beginning 2) | |
3153 (match-end 2)) | |
3154 ";"))) | |
3155 (setq pakname ""))) | |
3156 (insert pakname))) | |
3157 | |
3158 | |
3159 (defun ada-complete-symbol (symboldef position symalist) | |
3160 ;; Tries to complete a symbol in the buffer. | |
3161 ;; SYMBOLDEF is the regexp to find the definition of the desired symbol. | |
3162 ;; POSITION is the position of the subexpression in SYMBOLDEF to match | |
3163 ;; the symbol itself. | |
3164 ;; SYMALIST is an alist with possibly predefined completions." | |
3165 (let ((sofar nil) | |
3166 (completed nil) | |
3167 (insertpos nil)) | |
3168 (save-excursion | |
3169 ;; | |
3170 ;; get the part of the symbol already typed | |
3171 ;; | |
3172 (re-search-backward "\\([^a-zA-Z0-9_\\.]\\)\\([a-zA-Z0-9_\\.]+\\)") | |
3173 (setq sofar (buffer-substring (match-beginning 2) | |
3174 (match-end 2))) | |
3175 ;; | |
3176 ;; delete it | |
3177 ;; | |
3178 (delete-region (setq insertpos (match-beginning 2)) | |
3179 (match-end 2)) | |
3180 ;; | |
3181 ;; find all possible completions by searching for definitions of | |
3182 ;; this kind of symbol | |
3183 ;; | |
3184 (while (re-search-backward symboldef nil t) | |
3185 ;; | |
3186 ;; build an alist of these possible completions | |
3187 ;; | |
3188 (setq symalist (cons (cons (buffer-substring (match-beginning position) | |
3189 (match-end position)) | |
3190 nil) | |
3191 symalist))) | |
3192 | |
3193 (or | |
3194 ;; | |
3195 ;; symbol gets completed as far as possible | |
3196 ;; | |
3197 (stringp (setq completed (try-completion sofar symalist))) | |
3198 ;; | |
3199 ;; or is already complete | |
3200 ;; | |
3201 (setq completed sofar))) | |
3202 ;; | |
3203 ;; insert the completed symbol | |
3204 ;; | |
3205 (goto-char insertpos) | |
3206 (insert completed))) | |
3207 | |
3208 | |
3209 (defun ada-complete-use () | |
3210 "Tries to complete the package name in an 'use' statement in the buffer. | |
3211 Searches through former 'with' statements for possible completions." | |
3212 (interactive) | |
3213 (ada-complete-symbol | |
3214 "\\(\\<with\\s-+\\)\\([a-zA-Z0-9_.]+\\)\\(\\s-*;\\)" 2 nil) | |
3215 (insert ";")) | |
3216 | |
3217 | |
3218 (defun ada-complete-procedure () | |
3219 "Tries to complete a procedure/function name in the buffer." | |
3220 (interactive) | |
3221 (ada-complete-symbol ada-procedure-start-regexp 2 nil)) | |
3222 | |
3223 | |
3224 (defun ada-complete-variable () | |
3225 "Tries to complete a variable name in the buffer." | |
3226 (interactive) | |
3227 (ada-complete-symbol | |
3228 "\\([^a-zA-Z0-9_]\\)\\([a-zA-Z0-9_]+\\)[ \t\n]+\\(:\\)" 2 nil)) | |
3229 | |
3230 | |
3231 (defun ada-complete-type () | |
3232 "Tries to complete a type name in the buffer." | |
3233 (interactive) | |
3234 (ada-complete-symbol "\\(type\\)[ \t\n]+\\([a-zA-Z0-9_\\.]+\\)" | |
3235 2 | |
3236 '(("Integer" nil) | |
3237 ("Long_Integer" nil) | |
3238 ("Natural" nil) | |
3239 ("Positive" nil) | |
3240 ("Short_Integer" nil)))) | |
3241 | |
3242 | |
3243 ;;;----------------------;;; | |
3244 ;;; Behaviour Of TAB Key ;;; | |
3245 ;;;----------------------;;; | |
3246 | |
3247 (defun ada-tab () | |
3248 "Do indenting or tabbing according to `ada-tab-policy'." | |
3249 (interactive) | |
3250 (cond ((eq ada-tab-policy 'indent-and-tab) (error "not implemented")) | |
3251 ;; ada-indent-and-tab | |
3252 ((eq ada-tab-policy 'indent-rigidly) (ada-tab-hard)) | |
3253 ((eq ada-tab-policy 'indent-auto) (ada-indent-current)) | |
3254 ((eq ada-tab-policy 'gei) (ada-tab-gei)) | |
3255 ((eq ada-tab-policy 'indent-af) (af-indent-line)) ; GEB | |
3256 ((eq ada-tab-policy 'always-tab) (error "not implemented")) | |
3257 )) | |
3258 | |
3259 | |
3260 (defun ada-untab (arg) | |
3261 "Delete leading indenting according to `ada-tab-policy'." | |
3262 (interactive "P") | |
3263 (cond ((eq ada-tab-policy 'indent-rigidly) (ada-untab-hard)) | |
3264 ((eq ada-tab-policy 'indent-af) (backward-delete-char-untabify ; GEB | |
3265 (prefix-numeric-value arg) ; GEB | |
3266 arg)) ; GEB | |
3267 ((eq ada-tab-policy 'indent-auto) (error "not implemented")) | |
3268 ((eq ada-tab-policy 'always-tab) (error "not implemented")) | |
3269 )) | |
3270 | |
3271 | |
3272 (defun ada-indent-current-function () | |
3273 "ada-mode version of the indent-line-function." | |
3274 (interactive "*") | |
3275 (let ((starting-point (point-marker))) | |
3276 (ada-beginning-of-line) | |
3277 (ada-tab) | |
3278 (if (< (point) starting-point) | |
3279 (goto-char starting-point)) | |
3280 (set-marker starting-point nil) | |
3281 )) | |
3282 | |
3283 | |
3284 | |
3285 | |
3286 (defun ada-tab-hard () | |
3287 "Indent current line to next tab stop." | |
3288 (interactive) | |
3289 (save-excursion | |
3290 (beginning-of-line) | |
3291 (insert-char ? ada-indent)) | |
3292 (if (save-excursion (= (point) (progn (beginning-of-line) (point)))) | |
3293 (forward-char ada-indent))) | |
3294 | |
3295 | |
3296 (defun ada-untab-hard () | |
3297 "indent current line to previous tab stop." | |
3298 (interactive) | |
3299 (let ((bol (save-excursion (progn (beginning-of-line) (point)))) | |
3300 (eol (save-excursion (progn (end-of-line) (point))))) | |
3301 (indent-rigidly bol eol (- 0 ada-indent)))) | |
3302 | |
3303 | |
3304 (defun ada-tabsize (s) | |
3305 "changes spacing used for indentation. Reads spacing from minibuffer." | |
3306 (interactive "nnew indentation spacing: ") | |
3307 (setq ada-indent s)) | |
3308 | |
3309 | |
3310 ;;;---------------;;; | |
3311 ;;; Miscellaneous ;;; | |
3312 ;;;---------------;;; | |
3313 | |
3314 (defun ada-remove-trailing-spaces () | |
3315 ;; remove all trailing spaces at the end of lines. | |
3316 "remove trailing spaces in the whole buffer." | |
3317 (interactive) | |
3318 (save-excursion | |
3319 (goto-char (point-min)) | |
3320 (while (re-search-forward "[ \t]+$" nil t) | |
3321 (replace-match "" nil nil)))) | |
3322 | |
3323 | |
3324 (defun ada-untabify-buffer () | |
3325 ;; change all tabs to spaces | |
3326 (save-excursion | |
3327 (untabify (point-min) (point-max)))) | |
3328 | |
3329 | |
3330 (defun ada-uncomment-region (beg end) | |
3331 "delete comment-start at the beginning of a line in the region." | |
3332 (interactive "r") | |
3333 (comment-region beg end -1)) | |
3334 | |
3335 | |
3336 ;; define a function to support find-file.el if loaded | |
3337 (defun ada-ff-other-window () | |
3338 "Find other file in other window using ff-find-other-file." | |
3339 (interactive) | |
3340 (and (fboundp 'ff-find-other-file) | |
3341 (ff-find-other-file t))) | |
3342 | |
3343 | |
3344 ;;;-------------------------------;;; | |
3345 ;;; Moving To Procedures/Packages ;;; | |
3346 ;;;-------------------------------;;; | |
3347 | |
3348 (defun ada-next-procedure () | |
3349 "Moves point to next procedure." | |
3350 (interactive) | |
3351 (end-of-line) | |
3352 (if (re-search-forward ada-procedure-start-regexp nil t) | |
3353 (goto-char (match-beginning 1)) | |
3354 (error "No more functions/procedures/tasks"))) | |
3355 | |
3356 (defun ada-previous-procedure () | |
3357 "Moves point to previous procedure." | |
3358 (interactive) | |
3359 (beginning-of-line) | |
3360 (if (re-search-backward ada-procedure-start-regexp nil t) | |
3361 (goto-char (match-beginning 1)) | |
3362 (error "No more functions/procedures/tasks"))) | |
3363 | |
3364 (defun ada-next-package () | |
3365 "Moves point to next package." | |
3366 (interactive) | |
3367 (end-of-line) | |
3368 (if (re-search-forward ada-package-start-regexp nil t) | |
3369 (goto-char (match-beginning 1)) | |
3370 (error "No more packages"))) | |
3371 | |
3372 (defun ada-previous-package () | |
3373 "Moves point to previous package." | |
3374 (interactive) | |
3375 (beginning-of-line) | |
3376 (if (re-search-backward ada-package-start-regexp nil t) | |
3377 (goto-char (match-beginning 1)) | |
3378 (error "No more packages"))) | |
3379 | |
3380 | |
3381 ;;;----------------------- | |
3382 ;;; define keymap for Ada | |
3383 ;;;----------------------- | |
3384 | |
3385 (if (not ada-mode-map) | |
3386 (progn | |
3387 (setq ada-mode-map (make-sparse-keymap)) | |
3388 | |
3389 ;; Indentation and Formatting | |
3390 (define-key ada-mode-map "\C-j" 'ada-indent-newline-indent) | |
3391 (define-key ada-mode-map "\t" 'ada-tab) | |
3392 (define-key ada-mode-map "\C-c\C-l" 'ada-indent-region) | |
3393 ;; How do I write this for working with Lucid Emacs? | |
3394 (define-key ada-mode-map [S-tab] 'ada-untab) | |
3395 (define-key ada-mode-map "\C-c\C-f" 'ada-format-paramlist) | |
3396 (define-key ada-mode-map "\C-c\C-p" 'ada-call-pretty-printer) | |
10707 | 3397 ;;; We don't want to make meta-characters case-specific. |
3398 ;;; (define-key ada-mode-map "\M-Q" 'ada-fill-comment-paragraph-justify) | |
10705 | 3399 (define-key ada-mode-map "\M-\C-q" 'ada-fill-comment-paragraph-postfix) |
3400 | |
3401 ;; Movement | |
10707 | 3402 ;;; It isn't good to redefine these. What should be done instead? -- rms. |
3403 ;;; (define-key ada-mode-map "\M-e" 'ada-next-procedure) | |
3404 ;;; (define-key ada-mode-map "\M-a" 'ada-previous-procedure) | |
10705 | 3405 (define-key ada-mode-map "\M-\C-e" 'ada-next-package) |
3406 (define-key ada-mode-map "\M-\C-a" 'ada-previous-package) | |
3407 (define-key ada-mode-map "\C-c\C-a" 'ada-move-to-start) | |
3408 (define-key ada-mode-map "\C-c\C-e" 'ada-move-to-end) | |
3409 | |
3410 ;; Compilation | |
3411 (define-key ada-mode-map "\C-c\C-c" 'compile) | |
3412 | |
3413 ;; Casing | |
3414 (define-key ada-mode-map "\C-c\C-r" 'ada-adjust-case-region) | |
3415 (define-key ada-mode-map "\C-c\C-b" 'ada-adjust-case-buffer) | |
3416 | |
3417 (define-key ada-mode-map "\177" 'backward-delete-char-untabify) | |
3418 | |
3419 ;; Use predefined function of emacs19 for comments (RE) | |
3420 (define-key ada-mode-map "\C-c;" 'comment-region) | |
3421 (define-key ada-mode-map "\C-c:" 'ada-uncomment-region) | |
3422 | |
3423 ;; Change basic functionality | |
3424 (mapcar (lambda (pair) | |
3425 (substitute-key-definition (car pair) (cdr pair) | |
3426 ada-mode-map global-map)) | |
3427 '((beginning-of-line . ada-beginning-of-line) | |
3428 (end-of-line . ada-end-of-line) | |
3429 (forward-to-indentation . ada-forward-to-indentation) | |
3430 )) | |
3431 )) | |
3432 | |
3433 | |
3434 ;;;------------------- | |
3435 ;;; define menu 'Ada' | |
3436 ;;;------------------- | |
3437 | |
3438 (defun ada-add-ada-menu () | |
3439 "Adds the menu 'Ada' to the menu-bar in Ada Mode." | |
3440 (easy-menu-define t ada-mode-map t | |
3441 '("Ada" | |
3442 ["next package" ada-next-package t] | |
3443 ["previous package" ada-previous-package t] | |
3444 ["next procedure" ada-next-procedure t] | |
3445 ["previous procedure" ada-previous-procedure t] | |
3446 ["goto start" ada-move-to-start t] | |
3447 ["goto end" ada-move-to-end t] | |
3448 ["------------------" nil nil] | |
3449 ["indent current line (TAB)" | |
3450 ada-indent-current-function t] | |
3451 ["indent lines in region" ada-indent-region t] | |
3452 ["format parameter list" ada-format-paramlist t] | |
3453 ["pretty print buffer" ada-call-pretty-printer t] | |
3454 ["------------" nil nil] | |
3455 ["fill comment paragraph" | |
3456 ada-fill-comment-paragraph t] | |
3457 ["justify comment paragraph" | |
3458 ada-fill-comment-paragraph-justify t] | |
3459 ["postfix comment paragraph" | |
3460 ada-fill-comment-paragraph-postfix t] | |
3461 ["------------" nil nil] | |
3462 ["adjust case region" ada-adjust-case-region t] | |
3463 ["adjust case buffer" ada-adjust-case-buffer t] | |
3464 ["----------" nil nil] | |
3465 ["comment region" comment-region t] | |
3466 ["uncomment region" ada-uncomment-region t] | |
3467 ["----------------" nil nil] | |
3468 ["compile" compile (fboundp 'compile)] | |
3469 ["next error" next-error (fboundp 'next-error)] | |
3470 ["---------------" nil nil] | |
3471 ["Index" imenu (fboundp 'imenu)] | |
3472 ["--------------" nil nil] | |
3473 ["other file other window" ada-ff-other-window | |
3474 (fboundp 'ff-find-other-file)] | |
3475 ["other file" ff-find-other-file | |
3476 (fboundp 'ff-find-other-file)]))) | |
3477 | |
3478 | |
3479 ;;;------------------------------- | |
3480 ;;; Define Some Support Functions | |
3481 ;;;------------------------------- | |
3482 | |
3483 (defun ada-beginning-of-line (&optional arg) | |
3484 (interactive "P") | |
3485 (cond | |
3486 ((eq ada-tab-policy 'indent-af) (af-beginning-of-line arg)) | |
3487 (t (beginning-of-line arg)) | |
3488 )) | |
3489 | |
3490 (defun ada-end-of-line (&optional arg) | |
3491 (interactive "P") | |
3492 (cond | |
3493 ((eq ada-tab-policy 'indent-af) (af-end-of-line arg)) | |
3494 (t (end-of-line arg)) | |
3495 )) | |
3496 | |
3497 (defun ada-current-column () | |
3498 (cond | |
3499 ((eq ada-tab-policy 'indent-af) (af-current-column)) | |
3500 (t (current-column)) | |
3501 )) | |
3502 | |
3503 (defun ada-forward-to-indentation (&optional arg) | |
3504 (interactive "P") | |
3505 (cond | |
3506 ((eq ada-tab-policy 'indent-af) (af-forward-to-indentation arg)) | |
3507 (t (forward-to-indentation arg)) | |
3508 )) | |
3509 | |
3510 ;;;--------------------------------------------------- | |
3511 ;;; support for find-file | |
3512 ;;;--------------------------------------------------- | |
3513 | |
3514 (defvar ada-krunch-args "8" | |
3515 "*Argument of gnatk8, a string containing the max number of characters. | |
3516 Set to a big number, if you dont use crunched filenames.") | |
3517 | |
3518 (defun ada-make-filename-from-adaname (adaname) | |
3519 "determine the filename of a package/procedure from its own Ada name." | |
3520 ;; this is done simply by calling gkrunch, when we work with GNAT. It | |
3521 ;; must be a more complex function in other compiler environments. | |
3522 (interactive "s") | |
3523 | |
3524 ;; things that should really be done by the external process | |
3525 (let (krunch-buf) | |
3526 (setq krunch-buf (generate-new-buffer "*gkrunch*")) | |
3527 (save-excursion | |
3528 (set-buffer krunch-buf) | |
3529 (insert (downcase adaname)) | |
3530 (goto-char (point-min)) | |
3531 (while (search-forward "." nil t) | |
3532 (replace-match "-" nil t)) | |
3533 (setq adaname (buffer-substring (point-min) | |
3534 (progn | |
3535 (goto-char (point-min)) | |
3536 (end-of-line) | |
3537 (point)))) | |
3538 ;; clean the buffer | |
3539 (delete-region (point-min) (point-max)) | |
3540 ;; send adaname to external process "gnatk8" | |
3541 (call-process "gnatk8" nil krunch-buf nil | |
3542 adaname ada-krunch-args) | |
3543 ;; fetch output of that process | |
3544 (setq adaname (buffer-substring | |
3545 (point-min) | |
3546 (progn | |
3547 (goto-char (point-min)) | |
3548 (end-of-line) | |
3549 (point)))) | |
3550 (kill-buffer krunch-buf))) | |
3551 (setq adaname adaname) ;; can I avoid this statement? | |
3552 ) | |
3553 | |
3554 ;;;--------------------------------------------------- | |
3555 ;;; support for imenu | |
3556 ;;;--------------------------------------------------- | |
3557 | |
3558 (defun imenu-create-ada-index (&optional regexp) | |
3559 "create index alist for Ada files." | |
3560 (let ((index-alist '()) | |
3561 prev-pos char) | |
3562 (goto-char (point-min)) | |
3563 ;(imenu-progress-message prev-pos 0) | |
3564 ;; Search for functions/procedures | |
3565 (save-match-data | |
3566 (while (re-search-forward | |
3567 (or regexp ada-procedure-start-regexp) | |
3568 nil t) | |
3569 ;(imenu-progress-message prev-pos) | |
3570 ;;(backward-up-list 1) ;; needed in Ada ???? | |
3571 ;; do not store forward definitions | |
3572 (save-match-data | |
3573 (if (not (looking-at (concat | |
3574 "[ \t\n]*" ; WS | |
3575 "\([^)]+\)" ; parameterlist | |
3576 "\\([ \n\t]+return[ \n\t]+"; potential return | |
3577 "[a-zA-Z0-9_\\.]+\\)?" | |
3578 "[ \t]*" ; WS | |
3579 ";" ;; THIS is what we really look for | |
3580 ))) | |
3581 ; (push (imenu-example--name-and-position) index-alist) | |
3582 (setq index-alist (cons (imenu-example--name-and-position) | |
3583 index-alist)) | |
3584 )) | |
3585 ;(imenu-progress-message 100) | |
3586 )) | |
3587 (nreverse index-alist))) | |
3588 | |
3589 ;;;--------------------------------------------------- | |
3590 ;;; support for font-lock | |
3591 ;;;--------------------------------------------------- | |
3592 | |
3593 ;; Strings are a real pain in Ada because both ' and " can appear in a | |
3594 ;; non-string quote context (the former as an operator, the latter as | |
3595 ;; a character string). We follow the least losing solution, in which | |
3596 ;; only " is a string quote. Therefore a character string of the form | |
3597 ;; '"' will throw fontification off on the wrong track. | |
3598 | |
3599 (defconst ada-font-lock-keywords-1 | |
3600 (list | |
3601 ;; | |
3602 ;; Function, package (body), pragma, procedure, task (body) plus name. | |
3603 (list (concat "\\<\\(" | |
3604 "function\\|" | |
3605 "p\\(ackage\\(\\|[ \t]+body\\)\\|r\\(agma\\|ocedure\\)\\)\\|" | |
3606 "task\\(\\|[ \t]+body\\)" | |
3607 "\\)\\>[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?") | |
3608 '(1 font-lock-keyword-face) '(6 font-lock-function-name-face nil t))) | |
3609 "For consideration as a value of `ada-font-lock-keywords'. | |
3610 This does fairly subdued highlighting.") | |
3611 | |
3612 (defconst ada-font-lock-keywords-2 | |
3613 (append ada-font-lock-keywords-1 | |
3614 (list | |
3615 ;; | |
3616 ;; Main keywords, except those treated specially below. | |
3617 (concat "\\<\\(" | |
3618 ; ("abort" "abs" "abstract" "accept" "access" "aliased" "all" | |
3619 ; "and" "array" "at" "begin" "case" "declare" "delay" "delta" | |
3620 ; "digits" "do" "else" "elsif" "entry" "exception" "exit" "for" | |
3621 ; "generic" "if" "in" "is" "limited" "loop" "mod" "not" | |
3622 ; "null" "or" "others" "private" "protected" | |
3623 ; "range" "record" "rem" "renames" "requeue" "return" "reverse" | |
3624 ; "select" "separate" "tagged" "task" "terminate" "then" "until" | |
3625 ; "while" "xor") | |
3626 "a\\(b\\(ort\\|s\\(\\|tract\\)\\)\\|cce\\(pt\\|ss\\)\\|" | |
3627 "l\\(iased\\|l\\)\\|nd\\|rray\\|t\\)\\|begin\\|case\\|" | |
3628 "d\\(e\\(clare\\|l\\(ay\\|ta\\)\\)\\|igits\\|o\\)\\|" | |
3629 "e\\(ls\\(e\\|if\\)\\|ntry\\|x\\(ception\\|it\\)\\)\\|for\\|" | |
3630 "generic\\|i[fns]\\|l\\(imited\\|oop\\)\\|mod\\|n\\(ot\\|ull\\)\\|" | |
3631 "o\\(r\\|thers\\|ut\\)\\|pr\\(ivate\\|otected\\)\\|" | |
3632 "r\\(ange\\|e\\(cord\\|m\\|names\\|queue\\|turn\\|verse\\)\\)\\|" | |
3633 "se\\(lect\\|parate\\)\\|" | |
3634 "t\\(a\\(gged\\|sk\\)\\|erminate\\|hen\\)\\|until\\|while\\|xor" | |
3635 "\\)\\>") | |
3636 ;; | |
3637 ;; Anything following end and not already fontified is a body name. | |
3638 '("\\<\\(end\\)\\>[ \t]*\\(\\sw+\\)?" | |
3639 (1 font-lock-keyword-face) (2 font-lock-function-name-face nil t)) | |
3640 ;; | |
3641 ;; Variable name plus optional keywords followed by a type name. Slow. | |
3642 ; (list (concat "\\<\\(\\sw+\\)\\>[ \t]*:?[ \t]*" | |
3643 ; "\\(access\\|constant\\|in\\|in[ \t]+out\\|out\\)?[ \t]*" | |
3644 ; "\\(\\sw+\\)?") | |
3645 ; '(1 font-lock-variable-name-face) | |
3646 ; '(2 font-lock-keyword-face nil t) '(3 font-lock-type-face nil t)) | |
3647 ;; | |
3648 ;; Optional keywords followed by a type name. | |
3649 (list (concat ; ":[ \t]*" | |
3650 "\\<\\(access\\|constant\\|in\\|in[ \t]+out\\|out\\)\\>" | |
3651 "[ \t]*" | |
3652 "\\(\\sw+\\)?") | |
3653 '(1 font-lock-keyword-face nil t) '(2 font-lock-type-face nil t)) | |
3654 ;; | |
3655 ;; Keywords followed by a type or function name. | |
3656 (list (concat "\\<\\(" | |
3657 "new\\|of\\|subtype\\|type" | |
3658 "\\)\\>[ \t]*\\(\\sw+\\)?[ \t]*\\((\\)?") | |
3659 '(1 font-lock-keyword-face) | |
3660 '(2 (if (match-beginning 4) | |
3661 font-lock-function-name-face | |
3662 font-lock-type-face) nil t)) | |
3663 ;; | |
3664 ;; Keywords followed by a (comma separated list of) reference. | |
3665 (list (concat "\\<\\(goto\\|raise\\|use\\|when\\|with\\)\\>" | |
3666 ; "[ \t]*\\(\\sw+\\(\\.\\sw*\\)*\\)?") ; RE | |
3667 "[ \t]*\\([a-zA-Z0-9_\\.\\|, ]+\\)\\W") | |
3668 '(1 font-lock-keyword-face) '(2 font-lock-reference-face nil t)) | |
3669 ;; | |
3670 ;; Goto tags. | |
3671 '("<<\\(\\sw+\\)>>" 1 font-lock-reference-face) | |
3672 )) | |
3673 "For consideration as a value of `ada-font-lock-keywords'. | |
3674 This does a lot more highlighting.") | |
3675 | |
10880
7c5fe757600b
Use font-lock-maximum-decoration when setting ada-font-lock-keywords
Simon Marshall <simon@gnu.org>
parents:
10707
diff
changeset
|
3676 (defvar ada-font-lock-keywords (if font-lock-maximum-decoration |
7c5fe757600b
Use font-lock-maximum-decoration when setting ada-font-lock-keywords
Simon Marshall <simon@gnu.org>
parents:
10707
diff
changeset
|
3677 ada-font-lock-keywords-2 |
7c5fe757600b
Use font-lock-maximum-decoration when setting ada-font-lock-keywords
Simon Marshall <simon@gnu.org>
parents:
10707
diff
changeset
|
3678 ada-font-lock-keywords-1) |
10705 | 3679 "*Expressions to highlight in Ada mode.") |
3680 | |
3681 ;;; | |
3682 ;;; ???? | |
3683 ;;; | |
3684 (defun ada-gen-comment-until-proc () | |
3685 ;; comment until spec of a procedure or a function. | |
3686 (forward-line 1) | |
3687 (set-mark-command (point)) | |
3688 (if (re-search-forward ada-procedure-start-regexp nil t) | |
3689 (progn (goto-char (match-beginning 1)) | |
3690 (comment-region (mark) (point))) | |
3691 (error "No more functions/procedures"))) | |
3692 | |
3693 | |
3694 (defun ada-gen-treat-proc nil | |
3695 ;; make dummy body of a procedure/function specification. | |
3696 (goto-char (match-end 0)) | |
3697 (let ((wend (point)) | |
3698 (wstart (progn (re-search-backward "[ ][a-zA-Z0-9_\"]+" nil t) | |
3699 (+ (match-beginning 0) 1)))) ; delete leading WS | |
3700 (copy-region-as-kill wstart wend) ; store proc name in kill-buffer | |
3701 | |
3702 | |
3703 ;; if the next notWS char is '(' ==> parameterlist follows | |
3704 ;; if the next notWS char is ';' ==> no paramterlist | |
3705 ;; if the next notWS char is 'r' ==> paramterless function, search ';' | |
3706 | |
3707 ;; goto end of regex before last (= end of procname) | |
3708 (goto-char (match-end 0)) | |
3709 ;; look for next non WS | |
3710 (backward-char) | |
3711 (re-search-forward "[ ]*.") | |
10707 | 3712 (if (char-equal (char-after (match-end 0)) ?\;) |
10705 | 3713 (delete-char 1) ;; delete the ';' |
3714 ;; else | |
3715 ;; find ');' or 'return <id> ;' | |
3716 (re-search-forward | |
3717 "\\()[ \t]*;\\)\\|\\(return[ \t]+[a-zA-Z0-9_]+[ \t]*;\\)" nil t) | |
3718 (goto-char (match-end 0)) | |
3719 (delete-backward-char 1) ;; delete the ';' | |
3720 ) | |
3721 | |
3722 (insert " is") | |
3723 ;; if it is a function, we should generate a return variable and a | |
3724 ;; return statement. Sth. like "Result : <return-type>;" and a | |
3725 ;; "return Result;". | |
3726 (ada-indent-newline-indent) | |
3727 (insert "begin -- ") | |
3728 (yank) | |
3729 (newline) | |
3730 (insert "null;") | |
3731 (newline) | |
3732 (insert "end ") | |
3733 (yank) | |
3734 (insert ";") | |
3735 (ada-indent-newline-indent)) | |
3736 | |
3737 | |
3738 (defun ada-gen-make-bodyfile (spec-filename) | |
3739 "Create a new buffer containing the correspondig Ada body | |
3740 to the current specs." | |
3741 (interactive "b") | |
3742 ;;; (let* ( | |
3743 ;;; (file-name (ada-body-filename spec-filename)) | |
3744 ;;; (buf (get-buffer-create file-name))) | |
3745 ;;; (switch-to-buffer buf) | |
3746 ;;; (ada-mode) | |
3747 (ff-find-other-file t t) | |
3748 ;;; (if (= (buffer-size) 0) | |
3749 ;;; (make-header) | |
3750 ;;; ;; make nothing, autoinsert.el had put something in already | |
3751 ;;; ) | |
3752 (end-of-buffer) | |
3753 (let ((hlen (count-lines (point-min) (point-max)))) | |
3754 (insert-buffer spec-filename) | |
3755 ;; hlen lines have already been inserted automatically | |
3756 ) | |
3757 | |
3758 (if (re-search-forward ada-package-start-regexp nil t) | |
3759 (progn (goto-char (match-end 1)) | |
3760 (insert " body")) | |
3761 (error "No package")) | |
3762 ; (comment-until-proc) | |
3763 ; does not work correctly | |
3764 ; must be done by hand | |
3765 | |
3766 (while (re-search-forward ada-procedure-start-regexp nil t) | |
3767 (ada-gen-treat-proc)) | |
3768 | |
3769 ; don't overwrite an eventually | |
3770 ; existing file | |
3771 ; (if (file-exists-p file-name) | |
3772 ; (error "File with this name already exists!") | |
3773 ; (write-file file-name)) | |
3774 )) | |
3775 | |
3776 ;;; provide ourself | |
3777 | |
3778 (provide 'ada-mode) | |
3779 | |
10707 | 3780 ;;; ada-mode.el ends here |