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