1 ;;; ada-mode.el --- major-mode for editing Ada sources
3 ;;; Copyright (C) 1994, 1995, 1997 - 2014 Free Software Foundation, Inc.
5 ;; Author: Stephen Leake <stephen_leake@member.fsf.org>
6 ;; Maintainer: Stephen Leake <stephen_leake@member.fsf.org>
7 ;; Keywords FIXME: languages, ada ELPA broken for multiple keywords
9 ;; package-requires: ((wisi "1.0"))
10 ;; url: http://stephe-leake.org/emacs/ada-mode/emacs-ada-mode.html
12 ;; (Gnu ELPA requires single digits between dots in versions)
14 ;; This file is part of GNU Emacs.
16 ;; GNU Emacs is free software: you can redistribute it and/or modify
17 ;; it under the terms of the GNU General Public License as published by
18 ;; the Free Software Foundation, either version 3 of the License, or
19 ;; (at your option) any later version.
21 ;; GNU Emacs is distributed in the hope that it will be useful,
22 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
23 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 ;; GNU General Public License for more details.
26 ;; You should have received a copy of the GNU General Public License
27 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
31 ;; Emacs should enter Ada mode automatically when you load an Ada
32 ;; file, based on the file extension. The default extensions for Ada
33 ;; files are .ads, .adb; use ada-add-extensions to add other
36 ;; By default, ada-mode is configured to take full advantage of the
37 ;; GNAT compiler. If you are using another compiler, you
38 ;; should load that compiler's ada-* file first; that will define
39 ;; ada-compiler as a feature, so ada-gnat.el will not be loaded.
41 ;; See the user guide (info "ada-mode"), built from ada-mode.texi.
45 ;; In order to support multiple compilers, we use indirect function
46 ;; calls for all operations that depend on the compiler.
48 ;; We also support a cross reference tool (also called xref tool) that
49 ;; is different from the compiler. For example, you can use a local
50 ;; GNAT compiler to generate and access cross-reference information,
51 ;; while using a cross-compiler for compiling the final executable.
53 ;; Other functions are lumped with the choice of xref tool; mapping
54 ;; Ada names to file names, creating package bodies; any tool function
55 ;; that does not create executable code.
57 ;; The indentation engine and skeleton tools are also called
58 ;; indirectly, to allow parallel development of new versions of these
59 ;; tools (inspired by experience with ada-smie and ada-wisi).
61 ;; We also support using different compilers for different projects;
62 ;; `ada-compiler' can be set in Ada mode project files. Note that
63 ;; there is only one project active at a time; the most recently
64 ;; selected one. All Ada files are assumed to belong to this project
65 ;; (which is not correct, but works well in practice; the user is
66 ;; typically only concerned about files that belong to the current
69 ;; There are several styles of indirect calls:
71 ;; - scalar global variable set during load
73 ;; Appropriate when the choice of implementation is fixed at load
74 ;; time; it does not depend on the current Ada project. Used for
75 ;; indentation and skeleton functions.
77 ;; - scalar global variable set during project select
79 ;; Appropriate when the choice of implementation is determined by
80 ;; the choice of compiler or xref tool, which is per-project. The
81 ;; user sets the compiler choice in the project file, but not the
82 ;; lower-level redirect choice.
84 ;; For example, `ada-file-name-from-ada-name' depends on the naming
85 ;; convention used by the compiler. If the project file sets
86 ;; ada_compiler to 'gnat (either directly or by default),
87 ;; ada-gnat-select-prj sets `ada-file-name-from-ada-name' to
88 ;; `ada-gnat-file-name-from-ada-name'.
90 ;; - scalar buffer-local variable set during project select or file open
92 ;; Appropriate when choice of implementation is normally
93 ;; per-project, but can be per-buffer.
95 ;; For example, `ada-case-strict' will normally be set by the
96 ;; project, but some files may deviate from the project standard (if
97 ;; they are generated by -fdumpspec, for example). Those files set
98 ;; `ada-case-strict' in a file local variable comment.
100 ;; - scalar buffer-local variable set by ada-mode or ada-mode-hook
103 ;; Appropriate when the variable is a non-Ada mode variable, also
104 ;; used by other modes, and choice should not affect those modes.
106 ;; `indent-line-function', `comment-indent-function' use this style
108 ;; - alist global variable indexed by ada-compiler
110 ;; Appropriate when the choice of implementation is determined by
111 ;; the compiler, but the function is invoked during project parse,
112 ;; so we can't depend on a value set by project select.
114 ;; alist entries are set during load by the implementation elisp files.
116 ;; `ada-prj-default-compiler-alist' uses this style.
120 ;; The first Ada mode for GNU Emacs was written by V. Broman in
121 ;; 1985. He based his work on the already existing Modula-2 mode.
122 ;; This was distributed as ada.el in versions of Emacs prior to 19.29.
124 ;; Lynn Slater wrote an extensive Ada mode in 1989. It consisted of
125 ;; several files with support for dired commands and other nice
128 ;; The probably very first Ada mode (called electric-ada.el) was
129 ;; written by Steven D. Litvintchouk and Steven M. Rosen for the
130 ;; Gosling Emacs. L. Slater based his development on ada.el and
133 ;; A complete rewrite by Rolf Ebert <ebert@inf.enst.fr> and Markus
134 ;; Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de> was done at
135 ;; some point. Some ideas from the Ada mode mailing list have been
136 ;; added. Some of the functionality of L. Slater's mode has not (yet)
137 ;; been recoded in this new mode.
139 ;; A complete rewrite for Emacs-20 / GNAT-3.11 was done by Emmanuel
140 ;; Briot <briot@gnat.com> at Ada Core Technologies.
142 ;; A complete rewrite, to restructure the code more orthogonally, and
143 ;; to use wisi for the indentation engine, was done in 2012 - 2013 by
144 ;; Stephen Leake <stephen_leake@stephe-leake.org>.
148 ;; Many thanks to John McCabe <john@assen.demon.co.uk> for sending so
149 ;; many patches included in this package.
150 ;; Christian Egli <Christian.Egli@hcsd.hac.com>:
151 ;; ada-imenu-generic-expression
152 ;; Many thanks also to the following persons that have contributed
154 ;; Philippe Waroquiers (PW) <philippe@cfmu.eurocontrol.be> in particular,
155 ;; woodruff@stc.llnl.gov (John Woodruff)
156 ;; jj@ddci.dk (Jesper Joergensen)
157 ;; gse@ocsystems.com (Scott Evans)
158 ;; comar@gnat.com (Cyrille Comar)
159 ;; robin-reply@reagans.org
160 ;; and others for their valuable hints.
166 (eval-when-compile (require 'cl-macs))
168 (defun ada-mode-version ()
169 "Return Ada mode version."
171 (let ((version-string "5.0.1"))
177 (if (called-interactively-p 'interactive)
178 (message version-string)
183 (defvar ada-mode-hook nil
184 "List of functions to call when Ada mode is invoked.
185 This hook is executed after `ada-mode' is fully loaded, but
186 before file local variables are processed.")
189 "Major mode for editing Ada source code in Emacs."
192 (defcustom ada-auto-case t
194 "Buffer-local value that may override project variable `auto_case'.
195 Global value is default for project variable `auto_case'.
196 Non-nil means automatically change case of preceding word while typing.
197 Casing of Ada keywords is done according to `ada-case-keyword',
198 identifiers are Mixed_Case."
202 (make-variable-buffer-local 'ada-auto-case)
204 (defcustom ada-case-exception-file nil
205 "Default list of special casing exceptions dictionaries for identifiers.
206 Override with 'casing' project variable.
208 New exceptions may be added interactively via `ada-case-create-exception'.
209 If an exception is defined in multiple files, the first occurence is used.
211 The file format is one word per line, that gives the casing to be
212 used for that word in Ada source code. If the line starts with
213 the character *, then the exception will be used for partial
214 words that either start at the beginning of a word or after a _
215 character, and end either at the end of the word or at a _
216 character. Characters after the first word are ignored, and not
217 preserved when the list is written back to the file."
218 :type '(repeat (file))
222 (defcustom ada-case-keyword 'downcase-word
223 "Buffer-local value that may override project variable `case_keyword'.
224 Global value is default for project variable `case_keyword'.
225 Function to call to adjust the case of an Ada keywords."
226 :type '(choice (const downcase-word)
230 (make-variable-buffer-local 'ada-case-keyword)
232 (defcustom ada-case-strict t
233 "Buffer-local value that may override project variable `case_strict'.
234 Global value is default for project variable `case_strict'.
235 If non-nil, force Mixed_Case for identifiers.
236 Otherwise, allow UPPERCASE for identifiers."
240 (make-variable-buffer-local 'ada-case-strict)
242 (defcustom ada-language-version 'ada2012
243 "Ada language version; one of `ada83', `ada95', `ada2005'.
244 Only affects the keywords to highlight."
245 :type '(choice (const ada83)
251 (make-variable-buffer-local 'ada-language-version)
253 (defcustom ada-fill-comment-prefix "-- "
254 "Comment fill prefix."
258 (defcustom ada-fill-comment-postfix " --"
259 "Comment fill postfix."
263 (defcustom ada-prj-file-extensions '("adp" "prj")
264 "List of Emacs Ada mode project file extensions.
265 Used when searching for a project file.
266 Any file with one of these extensions will be parsed by `ada-prj-parse-file-1'."
270 (defcustom ada-prj-file-ext-extra nil
271 "List of secondary project file extensions.
272 Used when searching for a project file that can be a primary or
273 secondary project file (referenced from a primary). The user
274 must provide a parser for a file with one of these extensions."
278 ;;;;; end of user variables
280 (defconst ada-symbol-end
281 ;; we can't just add \> here; that might match _ in a user modified ada-mode-syntax-table
283 "Regexp to add to symbol name in `ada-which-function'.")
285 (defvar ada-compiler nil
286 "Default Ada compiler; can be overridden in project files.
287 Values defined by compiler packages.")
289 (defvar ada-xref-tool nil
290 "Default Ada cross reference tool; can be overridden in project files.
291 Values defined by cross reference packages.")
293 ;;;; keymap and menus
296 (let ((map (make-sparse-keymap)))
297 ;; C-c <letter> are reserved for users
299 ;; global-map has C-x ` 'next-error
300 (define-key map [return] 'ada-indent-newline-indent)
301 (define-key map "\C-c`" 'ada-show-secondary-error)
302 (define-key map "\C-c;" 'comment-dwim)
303 (define-key map "\C-c\M-`" 'ada-fix-compiler-error)
304 (define-key map "\C-c\C-a" 'ada-align)
305 (define-key map "\C-c\C-b" 'ada-make-subprogram-body)
306 (define-key map "\C-c\C-c" 'ada-build-make)
307 (define-key map "\C-c\C-d" 'ada-goto-declaration)
308 (define-key map "\C-c\M-d" 'ada-show-declaration-parents)
309 (define-key map "\C-c\C-e" 'ada-expand)
310 (define-key map "\C-c\C-f" 'ada-show-parse-error)
311 (define-key map "\C-c\C-i" 'ada-indent-statement)
312 (define-key map "\C-c\C-m" 'ada-build-set-make)
313 (define-key map "\C-c\C-n" 'ada-next-statement-keyword)
314 (define-key map "\C-c\C-o" 'ada-find-other-file)
315 (define-key map "\C-c\M-o" 'ada-find-other-file-noset)
316 (define-key map "\C-c\C-p" 'ada-prev-statement-keyword)
317 (define-key map "\C-c\C-q" 'ada-xref-refresh)
318 (define-key map "\C-c\C-r" 'ada-show-references)
319 (define-key map "\C-c\M-r" 'ada-build-run)
320 (define-key map "\C-c\C-v" 'ada-build-check)
321 (define-key map "\C-c\C-w" 'ada-case-adjust-at-point)
322 (define-key map "\C-c\C-x" 'ada-show-overriding)
323 (define-key map "\C-c\M-x" 'ada-show-overridden)
324 (define-key map "\C-c\C-y" 'ada-case-create-exception)
325 (define-key map "\C-c\M-y" 'ada-case-create-partial-exception)
326 (define-key map [C-down-mouse-3] 'ada-popup-menu)
329 ) "Local keymap used for Ada mode.")
331 (defvar ada-mode-menu (make-sparse-keymap "Ada"))
332 (easy-menu-define ada-mode-menu ada-mode-map "Menu keymap for Ada mode"
335 ["Ada Mode" (info "ada-mode") t]
336 ["Ada Reference Manual" (info "arm2012") t]
337 ["Key bindings" describe-bindings t]
339 ["Customize" (customize-group 'ada) t]
341 ["Find and select project ..." ada-build-prompt-select-prj-file t]
342 ["Select project ..." ada-prj-select t]
343 ["Show project" ada-prj-show t]
346 ["Next compilation error" next-error t]
347 ["Show secondary error" ada-show-secondary-error t]
348 ["Fix compilation error" ada-fix-compiler-error t]
349 ["Show last parse error" ada-show-parse-error t]
350 ["Check syntax" ada-build-check t]
351 ["Show main" ada-build-show-main t]
352 ["Build" ada-build-make t]
353 ["Set main and Build" ada-build-set-make t]
354 ["Run" ada-build-run t]
357 ["Other file" ada-find-other-file t]
358 ["Other file don't find decl" ada-find-other-file-noset t]
359 ["Goto declaration/body" ada-goto-declaration t]
360 ["Goto next statement keyword" ada-next-statement-keyword t]
361 ["Goto prev statement keyword" ada-next-statement-keyword t]
362 ["Show parent declarations" ada-show-declaration-parents t]
363 ["Show references" ada-show-references t]
364 ["Show overriding" ada-show-overriding t]
365 ["Show overridden" ada-show-overridden t]
368 ["Expand skeleton" ada-expand t]
369 ["Indent line or selection" indent-for-tab-command t]
370 ["Indent current statement" ada-indent-statement t]
371 ["Indent lines in file" (indent-region (point-min) (point-max)) t]
372 ["Align" ada-align t]
373 ["Comment/uncomment selection" comment-dwim t]
374 ["Fill comment paragraph" ada-fill-comment-paragraph t]
375 ["Fill comment paragraph justify" (ada-fill-comment-paragraph 'full) t]
376 ["Fill comment paragraph postfix" (ada-fill-comment-paragraph 'full t) t]
377 ["Make body for subprogram" ada-make-subprogram-body t]
380 ["Create full exception" ada-case-create-exception t]
381 ["Create partial exception" ada-case-create-partial-exception t]
382 ["Adjust case at point" ada-case-adjust-at-point t]
383 ["Adjust case region" ada-case-adjust-region t]
384 ["Adjust case buffer" ada-case-adjust-buffer t]
387 ["Show last parse error" ada-show-parse-error t]
388 ["Refresh cross reference cache" ada-xref-refresh t]
389 ["Reset parser" ada-reset-parser t]
392 ;; This doesn't need to be buffer-local because there can be only one
393 ;; popup menu at a time.
394 (defvar ada-context-menu-on-identifier nil)
396 (easy-menu-define ada-context-menu nil
397 "Context menu keymap for Ada mode"
399 ["Make body for subprogram" ada-make-subprogram-body t] ;; FIXME: include only if will succeed
400 ["Goto declaration/body" ada-goto-declaration :included ada-context-menu-on-identifier]
401 ["Show parent declarations" ada-show-declaration-parents :included ada-context-menu-on-identifier]
402 ["Show references" ada-show-references :included ada-context-menu-on-identifier]
403 ["Show overriding" ada-show-overriding :included ada-context-menu-on-identifier]
404 ["Show overridden" ada-show-overridden :included ada-context-menu-on-identifier]
405 ["Expand skeleton" ada-expand t] ;; FIXME: only if skeleton
406 ["Create full case exception" ada-case-create-exception t]
407 ["Create partial case exception" ada-case-create-partial-exception t]
410 ["Align" ada-align t]
411 ["Adjust case at point" ada-case-adjust-at-point (not (use-region-p))]
412 ["Adjust case region" ada-case-adjust-region (use-region-p)]
413 ["Indent current statement" ada-indent-statement t]
414 ["Goto next statement keyword" ada-next-statement-keyword t]
415 ["Goto prev statement keyword" ada-next-statement-keyword t]
416 ["Other File" ada-find-other-file t]
417 ["Other file don't find decl" ada-find-other-file-noset t]))
419 (defun ada-popup-menu (position)
420 "Pops up a `ada-context-menu', with `ada-context-menu-on-identifer' set appropriately.
421 POSITION is the location the mouse was clicked on.
422 Sets `ada-context-menu-last-point' to the current position before
423 displaying the menu. When a function from the menu is called,
424 point is where the mouse button was clicked."
427 (mouse-set-point last-input-event)
429 (setq ada-context-menu-on-identifier
431 (or (= (char-syntax (char-after)) ?w)
433 (not (ada-in-string-or-comment-p))
434 (save-excursion (skip-syntax-forward "w")
435 (not (ada-after-keyword-p)))
437 (popup-menu ada-context-menu)
440 (defun ada-indent-newline-indent ()
441 "insert a newline, indent the old and new lines."
443 ;; point may be in the middle of a word, so insert newline first,
444 ;; then go back and indent.
447 (funcall indent-line-function)
449 (funcall indent-line-function))
451 (defvar ada-indent-statement nil
452 ;; indentation function
453 "Function to indent the statement/declaration point is in or after.
454 Function is called with no arguments.")
456 (defun ada-indent-statement ()
457 "Indent current statement."
459 (when ada-indent-statement
460 (funcall ada-indent-statement)))
462 (defvar ada-expand nil
464 "Function to call to expand tokens (ie insert skeletons).")
467 "Expand previous word into a statement skeleton."
470 (funcall ada-expand)))
474 (defvar ada-mode-abbrev-table nil
475 "Local abbrev table for Ada mode.")
477 (defvar ada-align-rules
478 '((ada-declaration-assign
479 (regexp . "[^:]\\(\\s-*\\)\\(:\\)[^:]")
480 (valid . (lambda () (ada-align-valid)))
482 (modes . '(ada-mode)))
484 (regexp . "[^=]\\(\\s-*\\)\\(=>\\)")
485 (valid . (lambda () (ada-align-valid)))
486 (modes . '(ada-mode)))
488 (regexp . "\\(\\s-*\\)--")
489 (modes . '(ada-mode)))
491 (regexp . "\\(\\s-*\\)\\<\\(use\\s-\\)")
492 (valid . (lambda () (ada-align-valid)))
493 (modes . '(ada-mode)))
495 (regexp . "\\(\\s-+\\)\\(at\\)\\>")
496 (valid . (lambda () (ada-align-valid)))
497 (modes . '(ada-mode))))
498 "Rules to use to align different lines.")
500 (defun ada-align-valid ()
501 "See use in `ada-align-rules'."
503 ;; we don't put "when (match-beginning 2)" here; missing a match
504 ;; is a bug in the regexp.
505 (goto-char (match-beginning 2))
506 (not (ada-in-string-or-comment-p))))
508 (defconst ada-align-region-separate
529 "See the variable `align-region-separate' for more information.")
532 "If region is active, apply 'align'. If not, attempt to align
537 (align (region-beginning) (region-end))
540 ;; else see if we are in a construct we know how to align
542 ((ada-in-paramlist-p)
543 (ada-format-paramlist))
549 (defvar ada-in-paramlist-p nil
550 ;; Supplied by indentation engine parser
551 "Function to return t if point is inside the parameter-list of a subprogram declaration.
552 Function is called with no arguments.")
554 (defun ada-in-paramlist-p ()
555 "Return t if point is inside the parameter-list of a subprogram declaration."
556 (when ada-in-paramlist-p
557 (funcall ada-in-paramlist-p)))
559 (defun ada-format-paramlist ()
560 "Reformat the parameter list point is in."
562 (ada-goto-open-paren)
563 (funcall indent-line-function); so new list is indented properly
565 (let* ((inibit-modification-hooks t)
567 (delend (progn (forward-sexp) (point))); just after matching closing paren
568 (end (progn (backward-char) (forward-comment (- (point))) (point))); end of last parameter-declaration
569 (multi-line (> end (save-excursion (goto-char begin) (line-end-position))))
570 (paramlist (ada-scan-paramlist (1+ begin) end)))
573 ;; delete the original parameter-list
574 (delete-region begin delend)
576 ;; insert the new parameter-list
579 (ada-insert-paramlist-multi-line paramlist)
580 (ada-insert-paramlist-single-line paramlist)))
583 (defvar ada-scan-paramlist nil
584 ;; Supplied by indentation engine parser
585 "Function to scan a region, return a list of subprogram parameter declarations (in inverse declaration order).
586 Function is called with two args BEGIN END (the region).
587 Each parameter declaration is represented by a list
588 '((identifier ...) in-p out-p not-null-p access-p constant-p protected-p type default)."
589 ;; mode is 'in | out | in out | [not null] access [constant | protected]'
590 ;; IMPROVEME: handle single-line trailing comments, or longer comments, in paramlist?
593 (defun ada-scan-paramlist (begin end)
594 (when ada-scan-paramlist
595 (funcall ada-scan-paramlist begin end)))
597 (defun ada-insert-paramlist-multi-line (paramlist)
598 "Insert a multi-line formatted PARAMLIST in the buffer."
599 (let ((i (length paramlist))
615 ;; accumulate info across all params
616 (while (not (zerop i))
618 (setq param (nth i paramlist))
623 (mapc (lambda (ident)
625 (setq len (+ len (length ident))))
627 (setq len (+ len (* 2 (1- j)))); space for commas
628 (setq ident-len (max ident-len len))
630 ;; we align the defaults after the types that have defaults, not after all types.
631 ;; "constant", "protected" are treated as part of 'type'
635 (+ (length (nth 7 param))
636 (if (nth 5 param) 10 0); "constant "
637 (if (nth 6 param) 10 0); protected
640 (setq in-p (or in-p (nth 1 param)))
641 (setq out-p (or out-p (nth 2 param)))
642 (setq not-null-p (or not-null-p (nth 3 param)))
643 (setq access-p (or access-p (nth 4 param)))
646 (unless (save-excursion (skip-chars-backward " \t") (bolp))
647 ;; paramlist starts on same line as subprogram identifier; clean up whitespace
649 (delete-char (- (skip-syntax-backward " ")))
655 (setq ident-col (current-column))
656 (setq colon-col (+ ident-col ident-len 1))
657 (setq out-col (+ colon-col (if in-p 5 0))); ": in "
661 (not-null-p 18); ": not null access "
662 (access-p 9); ": access"
663 ((and in-p out-p) 9); ": in out "
668 (setq default-col (+ 1 type-col type-len))
670 (setq i (length paramlist))
671 (while (not (zerop i))
673 (setq param (nth i paramlist))
675 ;; insert identifiers, space and colon
676 (mapc (lambda (ident)
680 (delete-char -2); last ", "
681 (indent-to colon-col)
692 (insert "not null "))
699 (insert "constant "))
701 (insert "protected "))
702 (insert (nth 7 param)); type
704 (when (nth 8 param); default
705 (indent-to default-col)
707 (insert (nth 8 param)))
713 (indent-to ident-col))
717 (defun ada-insert-paramlist-single-line (paramlist)
718 "Insert a single-line formatted PARAMLIST in the buffer."
719 (let ((i (length paramlist))
722 ;; clean up whitespace
723 (skip-syntax-forward " ")
724 (delete-char (- (skip-syntax-backward " ")))
727 (setq i (length paramlist))
728 (while (not (zerop i))
730 (setq param (nth i paramlist))
732 ;; insert identifiers, space and colon
733 (mapc (lambda (ident)
737 (delete-char -2); last ", "
748 (insert "not null "))
754 (insert "constant "))
756 (insert "protected "))
757 (insert (nth 7 param)); type
759 (when (nth 8 param); default
761 (insert (nth 8 param)))
764 (if (= (char-after) ?\;)
771 (defvar ada-reset-parser nil
772 ;; Supplied by indentation engine parser
773 "Function to reset parser, to clear confused state."
776 (defun ada-reset-parser ()
778 (when ada-reset-parser
779 (funcall ada-reset-parser)))
781 (defvar ada-show-parse-error nil
782 ;; Supplied by indentation engine parser
783 "Function to show last error reported by indentation parser."
786 (defun ada-show-parse-error ()
788 (when ada-show-parse-error
789 (funcall ada-show-parse-error)))
793 (defvar ada-case-full-exceptions '()
794 "Alist of words (entities) that have special casing, built from
795 `ada-case-exception-file' full word exceptions. Indexed by
796 properly cased word; value is t.")
798 (defvar ada-case-partial-exceptions '()
799 "Alist of partial words that have special casing, built from
800 `ada-case-exception-file' partial word exceptions. Indexed by
801 properly cased word; value is t.")
803 (defun ada-case-save-exceptions (full-exceptions partial-exceptions file-name)
804 "Save FULL-EXCEPTIONS, PARTIAL-EXCEPTIONS to the file FILE-NAME."
805 (with-temp-file (expand-file-name file-name)
806 (mapc (lambda (x) (insert (car x) "\n"))
807 (sort (copy-sequence full-exceptions)
808 (lambda(a b) (string< (car a) (car b)))))
809 (mapc (lambda (x) (insert "*" (car x) "\n"))
810 (sort (copy-sequence partial-exceptions)
811 (lambda(a b) (string< (car a) (car b)))))
814 (defun ada-case-read-exceptions (file-name)
815 "Read the content of the casing exception file FILE-NAME.
816 Return (cons full-exceptions partial-exceptions)."
817 (setq file-name (expand-file-name (substitute-in-file-name file-name)))
818 (if (file-readable-p file-name)
819 (let (full-exceptions partial-exceptions word)
821 (insert-file-contents file-name)
824 (setq word (buffer-substring-no-properties
825 (point) (save-excursion (skip-syntax-forward "w_") (point))))
827 (if (char-equal (string-to-char word) ?*)
828 ;; partial word exception
830 (setq word (substring word 1))
831 (unless (assoc-string word partial-exceptions t)
832 (add-to-list 'partial-exceptions (cons word t))))
834 ;; full word exception
835 (unless (assoc-string word full-exceptions t)
836 (add-to-list 'full-exceptions (cons word t))))
840 (cons full-exceptions partial-exceptions))
842 ;; else file not readable; might be a new project with no
843 ;; exceptions yet, so just warn user, return empty pair
844 (message "'%s' is not a readable file." file-name)
848 (defun ada-case-merge-exceptions (result new)
849 "Merge NEW exeptions into RESULT.
850 An item in both lists has the RESULT value."
852 (unless (assoc-string (car item) result t)
853 (add-to-list 'result item)))
856 (defun ada-case-merge-all-exceptions (exceptions)
857 "Merge EXCEPTIONS into `ada-case-full-exceptions', `ada-case-partial-exceptions'."
858 (setq ada-case-full-exceptions (ada-case-merge-exceptions ada-case-full-exceptions (car exceptions)))
859 (setq ada-case-partial-exceptions (ada-case-merge-exceptions ada-case-partial-exceptions (cdr exceptions))))
861 (defun ada-case-read-all-exceptions ()
862 "Read case exceptions from all files in `ada-case-exception-file',
863 replacing current values of `ada-case-full-exceptions', `ada-case-partial-exceptions'."
865 (setq ada-case-full-exceptions '()
866 ada-case-partial-exceptions '())
868 (when (ada-prj-get 'casing)
869 (dolist (file (ada-prj-get 'casing))
870 (ada-case-merge-all-exceptions (ada-case-read-exceptions file))))
873 (defun ada-case-add-exception (word exceptions)
874 "Add case exception WORD to EXCEPTIONS, replacing current entry, if any."
875 (if (assoc-string word exceptions t)
876 (setcar (assoc-string word exceptions t) word)
877 (add-to-list 'exceptions (cons word t)))
880 (defun ada-case-create-exception (&optional word file-name partial)
881 "Define WORD as an exception for the casing system, save it in FILE-NAME.
882 If PARTIAL is non-nil, create a partial word exception. WORD
883 defaults to the active region, or the word at point. User is
884 prompted to choose a file from project variable casing if it is a
887 (let ((casing (ada-prj-get 'casing)))
890 (file-name file-name)
892 ((< 1 (length casing))
893 (completing-read "case exception file: " casing
898 (car casing) ;; default
900 ((= 1 (length casing))
905 "No exception file specified. See variable `ada-case-exception-file'")))
910 (setq word (buffer-substring-no-properties (region-beginning) (region-end)))
912 (skip-syntax-backward "w_")
914 (buffer-substring-no-properties
916 (progn (skip-syntax-forward "w_") (point))
919 (let* ((exceptions (ada-case-read-exceptions file-name))
920 (full-exceptions (car exceptions))
921 (partial-exceptions (cdr exceptions)))
925 (setq ada-case-full-exceptions (ada-case-add-exception word ada-case-full-exceptions))
926 (setq full-exceptions (ada-case-add-exception word full-exceptions)))
929 (setq ada-case-partial-exceptions (ada-case-add-exception word ada-case-partial-exceptions))
930 (setq partial-exceptions (ada-case-add-exception word partial-exceptions)))
932 (ada-case-save-exceptions full-exceptions partial-exceptions file-name)
933 (message "created %s case exception '%s' in file '%s'"
934 (if partial "partial" "full")
939 (defun ada-case-create-partial-exception ()
940 "Define active region or word at point as a partial word exception.
941 User is prompted to choose a file from project variable casing if it is a list."
943 (ada-case-create-exception nil nil t))
945 (defun ada-in-numeric-literal-p ()
946 "Return t if point is after a prefix of a numeric literal."
947 (looking-back "\\([0-9]+#[0-9a-fA-F_]+\\)"))
949 (defun ada-after-keyword-p ()
950 "Return non-nil if point is after an element of `ada-keywords'."
951 (let ((word (buffer-substring-no-properties
952 (save-excursion (skip-syntax-backward "w_") (point))
954 (member (downcase word) ada-keywords)))
956 (defun ada-case-adjust-identifier ()
957 "Adjust case of the previous word as an identifier.
958 Uses Mixed_Case, with exceptions defined in
959 `ada-case-full-exceptions', `ada-case-partial-exceptions'."
962 (let ((end (point-marker))
963 (start (progn (skip-syntax-backward "w_") (point)))
968 (if (setq match (assoc-string (buffer-substring-no-properties start end) ada-case-full-exceptions t))
969 ;; full word exception
971 ;; 'save-excursion' puts a marker at 'end'; if we do
972 ;; 'delete-region' first, it moves that marker to 'start',
973 ;; then 'insert' inserts replacement text after the
974 ;; marker, defeating 'save-excursion'. So we do 'insert' first.
976 (delete-region (point) end))
978 ;; else apply Mixed_Case and partial-exceptions
980 (downcase-region start end))
984 (save-excursion (when (search-forward "_" end t) (point-marker)))
985 (copy-marker (1+ end))))
987 (if (setq match (assoc-string (buffer-substring-no-properties start (1- next))
988 ada-case-partial-exceptions t))
990 ;; see comment above at 'full word exception' for why
991 ;; we do insert first.
993 (delete-region (point) (1- next)))
995 ;; else upcase first char
996 (insert-char (upcase (following-char)) 1)
1001 (setq start (point))
1005 (defun ada-case-adjust (&optional typed-char in-comment)
1006 "Adjust the case of the word before point.
1007 When invoked interactively, TYPED-CHAR must be
1008 `last-command-event', and it must not have been inserted yet.
1009 If IN-COMMENT is non-nil, adjust case of words in comments."
1011 (when (save-excursion
1012 (forward-char -1); back to last character in word
1014 (eq (char-syntax (char-after)) ?w); it can be capitalized
1016 (not (and (eq typed-char ?')
1017 (eq (char-before (point)) ?'))); character literal
1020 (not (ada-in-string-or-comment-p)))
1021 ;; we sometimes want to capitialize an Ada identifier
1022 ;; referenced in a comment, via
1023 ;; ada-case-adjust-at-point.
1025 (not (ada-in-numeric-literal-p))
1029 ;; Some attributes are also keywords, but captialized as
1030 ;; attributes. So check for attribute first.
1034 (skip-syntax-backward "w_")
1035 (eq (char-before) ?')))
1036 (ada-case-adjust-identifier))
1040 (not (eq typed-char ?_))
1041 (ada-after-keyword-p))
1042 (funcall ada-case-keyword -1))
1044 (t (ada-case-adjust-identifier))
1048 (defun ada-case-adjust-at-point (&optional in-comment)
1049 "Adjust case of word at point, move to end of word.
1050 With prefix arg, adjust case even if in comment."
1054 (memq (char-syntax (char-after)) '(?w ?_)))
1055 (skip-syntax-forward "w_"))
1056 (ada-case-adjust nil in-comment))
1058 (defun ada-case-adjust-region (begin end)
1059 "Adjust case of all words in region BEGIN END."
1061 (narrow-to-region begin end)
1065 (forward-comment (point-max))
1066 (skip-syntax-forward "^w_")
1067 (skip-syntax-forward "w_")
1071 (defun ada-case-adjust-buffer ()
1072 "Adjust case of current buffer."
1074 (ada-case-adjust-region (point-min) (point-max)))
1076 (defun ada-case-adjust-interactive (arg)
1077 "Adjust the case of the previous word, and process the character just typed.
1078 To be bound to keys that should cause auto-casing.
1079 ARG is the prefix the user entered with \\[universal-argument]."
1082 ;; character typed has not been inserted yet
1083 (let ((lastk last-command-event))
1087 (ada-case-adjust lastk)
1088 (funcall ada-lfd-binding))
1091 (ada-case-adjust lastk)
1092 (funcall ada-ret-binding))
1095 (ada-case-adjust lastk)
1096 (self-insert-command (prefix-numeric-value arg)))
1100 (defvar ada-ret-binding nil)
1101 (defvar ada-lfd-binding nil)
1103 (defun ada-case-activate-keys ()
1104 "Modify the key bindings for all the keys that should adjust casing."
1106 ;; We can't use post-self-insert-hook for \n, \r, because they are
1107 ;; not self-insert. So we make ada-mode-map buffer local, and don't
1108 ;; call this function if ada-auto-case is off. That means
1109 ;; ada-auto-case cannot be changed after an Ada buffer is created.
1111 ;; The 'or ...' is there to be sure that the value will not be
1112 ;; changed again when Ada mode is called more than once, since we
1113 ;; are rebinding the keys.
1114 (or ada-ret-binding (setq ada-ret-binding (key-binding "\C-M")))
1115 (or ada-lfd-binding (setq ada-lfd-binding (key-binding "\C-j")))
1121 (char-to-string key)
1122 'ada-case-adjust-interactive)))
1123 '( ?_ ?% ?& ?* ?( ?) ?- ?= ?+
1124 ?| ?\; ?: ?' ?\" ?< ?, ?. ?> ?/ ?\n 32 ?\r ))
1129 ;; An Emacs Ada mode project file can specify several things:
1131 ;; - a compiler-specific project file
1133 ;; - compiler-specific environment variables
1135 ;; - other compiler-specific things (see the compiler support elisp code)
1137 ;; - a list of source directories (in addition to those specified in the compiler project file)
1139 ;; - a casing exception file
1141 ;; All of the data used by Emacs Ada mode functions specified in a
1142 ;; project file is stored in a property list. The property list is
1143 ;; stored in an alist indexed by the project file name, so multiple
1144 ;; project files can be selected without re-parsing them (some
1145 ;; compiler project files can take a long time to parse).
1147 (defvar ada-prj-alist nil
1148 "Alist holding currently parsed Emacs Ada project files. Indexed by absolute project file name.")
1150 (defvar ada-prj-current-file nil
1151 "Current Emacs Ada project file.")
1153 (defvar ada-prj-current-project nil
1154 "Current Emacs Ada mode project; a plist.")
1156 (defun ada-prj-get (prop &optional plist)
1157 "Return value of PROP in PLIST.
1158 Optional PLIST defaults to `ada-prj-current-project'."
1159 (plist-get (or plist ada-prj-current-project) prop))
1161 (defun ada-prj-put (prop val &optional plist)
1162 "Set value of PROP in PLIST to VAL.
1163 Optional PLIST defaults to `ada-prj-current-project'."
1164 (plist-put (or plist ada-prj-current-project) prop val))
1166 (defun ada-require-project-file ()
1167 (unless ada-prj-current-file
1168 (error "no Emacs Ada project file specified")))
1170 (defvar ada-prj-default-list nil
1171 ;; project file parse
1172 "List of functions to add default project variables. Called
1173 with one argument; the default project properties list. Function
1174 should add to the properties list and return it.")
1176 (defvar ada-prj-default-compiler-alist nil
1177 ;; project file parse
1178 "Compiler-specific function to set default project variables.
1179 Indexed by ada-compiler. Called with one argument; the default
1180 project properties list. Function should add to the properties
1181 list and return it.")
1183 (defvar ada-prj-default-xref-alist nil
1184 ;; project file parse
1185 "Xref-tool-specific function to set default project variables.
1186 Indexed by ada-xref-tool. Called with one argument; the default
1187 project properties list. Function should add to the properties
1188 list and return it.")
1190 (defun ada-prj-default ()
1191 "Return the default project properties list.
1192 Include properties set via `ada-prj-default-compiler-alist',
1193 `ada-prj-default-xref-alist'."
1199 ;; variable name alphabetical order
1200 'ada_compiler ada-compiler
1201 'auto_case ada-auto-case
1202 'case_keyword ada-case-keyword
1203 'case_strict ada-case-strict
1204 'casing (if (listp ada-case-exception-file)
1205 ada-case-exception-file
1206 (list ada-case-exception-file))
1207 'path_sep path-separator;; prj variable so users can override it for their compiler
1208 'proc_env process-environment
1210 'xref_tool ada-xref-tool
1213 (cl-dolist (func ada-prj-default-list)
1214 (setq project (funcall func project)))
1216 (setq func (cdr (assq ada-compiler ada-prj-default-compiler-alist)))
1217 (when func (setq project (funcall func project)))
1218 (setq func (cdr (assq ada-xref-tool ada-prj-default-xref-alist)))
1219 (when func (setq project (funcall func project)))
1222 (defvar ada-prj-parser-alist
1224 (lambda (ext) (cons ext 'ada-prj-parse-file-1))
1225 ada-prj-file-extensions)
1226 ;; project file parse
1227 "Alist of parsers for project files, indexed by file extension.
1228 Default provides the minimal Ada mode parser; compiler support
1229 code may add other parsers. Parser is called with two arguments;
1230 the project file name and the current project property
1231 list. Parser must modify or add to the property list and return it.")
1233 ;; This autoloaded because it is often used in Makefiles, and thus
1234 ;; will be the first ada-mode function executed.
1236 (defun ada-parse-prj-file (prj-file)
1237 "Read Emacs Ada or compiler-specific project file PRJ-FILE, set project properties in `ada-prj-alist'."
1238 ;; Not called ada-prj-parse-file for Ada mode 4.01 compatibility
1239 (let ((project (ada-prj-default))
1240 (parser (cdr (assoc (file-name-extension prj-file) ada-prj-parser-alist))))
1242 (setq prj-file (expand-file-name prj-file))
1245 ;; parser may reference the "current project", so bind that now.
1246 (let ((ada-prj-current-project project)
1247 (ada-prj-current-file prj-file))
1248 (setq project (funcall parser prj-file project)))
1249 (error "no project file parser defined for '%s'" prj-file))
1251 ;; Store the project properties
1252 (if (assoc prj-file ada-prj-alist)
1253 (setcdr (assoc prj-file ada-prj-alist) project)
1254 (add-to-list 'ada-prj-alist (cons prj-file project)))
1256 ;; return t for interactive use
1259 (defun ada-prj-reparse-select-current ()
1260 "Reparse the current project file, re-select it.
1261 Useful when the project file has been edited."
1262 (ada-parse-prj-file ada-prj-current-file)
1263 (ada-select-prj-file ada-prj-current-file))
1265 (defvar ada-prj-parse-one-compiler nil
1266 ;; project file parse
1267 "Compiler-specific function to process one Ada project property.
1268 Indexed by project variable ada_compiler.
1269 Called with three arguments; the property name, property value,
1270 and project properties list. Function should add to or modify the
1271 properties list and return it, or return nil if the name is not
1274 (defvar ada-prj-parse-one-xref nil
1275 ;; project file parse
1276 "Xref-tool-specific function to process one Ada project property.
1277 Indexed by project variable xref_tool.
1278 Called with three arguments; the property name, property value,
1279 and project properties list. Function should add to or modify the
1280 properties list and return it, or return nil if the name is not
1283 (defvar ada-prj-parse-final-compiler nil
1284 ;; project file parse
1285 "Alist of compiler-specific functions to finish processing Ada project properties.
1286 Indexed by project variable ada_compiler.
1287 Called with one argument; the project properties list. Function
1288 should add to or modify the list and return it.")
1290 (defvar ada-prj-parse-final-xref nil
1291 ;; project file parse
1292 "Alist of xref-tool-specific functions to finish processing Ada project properties.
1293 Indexed by project variable xref_tool.
1294 Called with one argument; the project properties list. Function
1295 should add to or modify the list and return it.")
1297 (defun ada-prj-parse-file-1 (prj-file project)
1298 "Parse the Ada mode project file PRJ-FILE, set project properties in PROJECT.
1299 Return new value of PROJECT."
1300 (let (;; fields that are lists or that otherwise require special processing
1303 (parse-one-compiler (cdr (assoc ada-compiler ada-prj-parse-one-compiler)))
1304 (parse-final-compiler (cdr (assoc ada-compiler ada-prj-parse-final-compiler)))
1305 (parse-one-xref (cdr (assoc ada-xref-tool ada-prj-parse-one-xref)))
1306 (parse-final-xref (cdr (assoc ada-xref-tool ada-prj-parse-final-xref))))
1308 (with-current-buffer (find-file-noselect prj-file)
1309 (goto-char (point-min))
1311 ;; process each line
1314 ;; ignore lines that don't have the format "name=value", put
1315 ;; 'name', 'value' in match-string.
1316 (when (looking-at "^\\([^=\n]+\\)=\\(.*\\)")
1318 ;; variable name alphabetical order
1320 ((string= (match-string 1) "ada_compiler")
1321 (let ((comp (intern (match-string 2))))
1322 (setq project (plist-put project 'ada_compiler comp))
1323 (setq parse-one-compiler (cdr (assq comp ada-prj-parse-one-compiler)))
1324 (setq parse-final-compiler (cdr (assq comp ada-prj-parse-final-compiler)))))
1326 ((string= (match-string 1) "auto_case")
1327 (setq project (plist-put project 'auto_case (intern (match-string 2)))))
1329 ((string= (match-string 1) "case_keyword")
1330 (setq project (plist-put project 'case_keyword (intern (match-string 2)))))
1332 ((string= (match-string 1) "case_strict")
1333 (setq project (plist-put project 'case_strict (intern (match-string 2)))))
1335 ((string= (match-string 1) "casing")
1336 (add-to-list 'casing
1338 (substitute-in-file-name (match-string 2)))))
1340 ((string= (match-string 1) "el_file")
1341 (let ((file (expand-file-name (substitute-in-file-name (match-string 2)))))
1342 (setq project (plist-put project 'el_file file))
1343 ;; eval now as well as in select, since it might affect parsing
1346 ((string= (match-string 1) "src_dir")
1347 (add-to-list 'src_dir
1348 (file-name-as-directory
1349 (expand-file-name (match-string 2)))))
1351 ((string= (match-string 1) "xref_tool")
1352 (let ((xref (intern (match-string 2))))
1353 (setq project (plist-put project 'xref_tool xref))
1354 (setq parse-one-xref (cdr (assq xref ada-prj-parse-one-xref)))
1355 (setq parse-final-xref (cdr (assq xref ada-prj-parse-final-xref)))))
1359 (and parse-one-compiler
1360 (setq tmp-prj (funcall parse-one-compiler (match-string 1) (match-string 2) project)))
1362 (setq tmp-prj (funcall parse-one-xref (match-string 1) (match-string 2) project))))
1364 (setq project tmp-prj)
1366 ;; Any other field in the file is set as an environment
1367 ;; variable or a project file.
1368 (if (= ?$ (elt (match-string 1) 0))
1369 ;; process env var. We don't do expand-file-name
1370 ;; here because the application may be expecting a
1372 (let ((process-environment (plist-get project 'proc_env)))
1373 (setenv (substring (match-string 1) 1)
1374 (substitute-in-file-name (match-string 2)))
1376 (plist-put project 'proc_env process-environment)))
1378 ;; not recognized; assume it is a user-defined variable like "comp_opt"
1379 (setq project (plist-put project (intern (match-string 1)) (match-string 2)))
1385 );; done reading file
1387 ;; process accumulated lists
1388 (if casing (set 'project (plist-put project 'casing (reverse casing))))
1389 (if src_dir (set 'project (plist-put project 'src_dir (reverse src_dir))))
1391 (when parse-final-compiler
1392 ;; parse-final-compiler may reference the "current project", so
1393 ;; bind that now, to include the properties set above.
1394 (let ((ada-prj-current-project project)
1395 (ada-prj-current-file prj-file))
1396 (setq project (funcall parse-final-compiler project))))
1398 (when parse-final-xref
1399 (let ((ada-prj-current-project project)
1400 (ada-prj-current-file prj-file))
1401 (setq project (funcall parse-final-xref project))))
1406 (defvar ada-project-search-path nil
1407 "Search path for finding Ada project files")
1409 (defvar ada-select-prj-compiler nil
1410 "Alist of functions to call for compiler specific project file selection.
1411 Indexed by project variable ada_compiler.")
1413 (defvar ada-deselect-prj-compiler nil
1414 "Alist of functions to call for compiler specific project file deselection.
1415 Indexed by project variable ada_compiler.")
1417 (defvar ada-select-prj-xref-tool nil
1418 "Alist of functions to call for xref-tool specific project file selection.
1419 Indexed by project variable xref_tool.")
1421 (defvar ada-deselect-prj-xref-tool nil
1422 "Alist of functions to call for xref-tool specific project file deselection.
1423 Indexed by project variable xref_tool.")
1425 (defun ada-select-prj-file (prj-file)
1426 "Select PRJ-FILE as the current project file."
1428 (setq prj-file (expand-file-name prj-file))
1430 (setq ada-prj-current-project (cdr (assoc prj-file ada-prj-alist)))
1432 (when (null ada-prj-current-project)
1433 (setq ada-prj-current-file nil)
1434 (error "Project file '%s' was not previously parsed." prj-file))
1436 (let ((func (cdr (assq (ada-prj-get 'ada_compiler) ada-deselect-prj-compiler))))
1437 (when func (funcall func)))
1439 (let ((func (cdr (assq (ada-prj-get 'xref_tool) ada-deselect-prj-xref-tool))))
1440 (when func (funcall func)))
1442 (setq ada-prj-current-file prj-file)
1444 ;; Project file should fully specify what compilers are used,
1445 ;; including what compilation filters they need. There may be more
1446 ;; than just an Ada compiler.
1447 (setq compilation-error-regexp-alist nil)
1448 (setq compilation-filter-hook nil)
1450 (when (ada-prj-get 'el_file)
1451 (load-file (ada-prj-get 'el_file)))
1453 (ada-case-read-all-exceptions)
1455 (setq compilation-search-path (ada-prj-get 'src_dir))
1456 (setq ada-project-search-path (ada-prj-get 'prj_dir))
1458 (let ((func (cdr (assq (ada-prj-get 'ada_compiler) ada-select-prj-compiler))))
1459 (when func (funcall func)))
1461 (let ((func (cdr (assq (ada-prj-get 'xref_tool) ada-select-prj-xref-tool))))
1462 (when func (funcall func)))
1464 ;; return 't', for decent display in message buffer when called interactively
1467 (defun ada-prj-select ()
1468 "Select the current project file from the list of currently available project files."
1470 (ada-select-prj-file (completing-read "project: " ada-prj-alist nil t))
1473 (defun ada-prj-show ()
1474 "Show current Emacs Ada mode project file."
1476 (message "current Emacs Ada mode project file: %s" ada-prj-current-file))
1478 ;;;; syntax properties
1480 (defvar ada-mode-syntax-table
1481 (let ((table (make-syntax-table)))
1482 ;; (info "(elisp)Syntax Class Table" "*info syntax class table*")
1483 ;; make-syntax-table sets all alphanumeric to w, etc; so we only
1484 ;; have to add ada-specific things.
1486 ;; string brackets. `%' is the obsolete alternative string
1487 ;; bracket (arm J.2); if we make it syntax class ", it throws
1488 ;; font-lock and indentation off the track, so we use syntax class
1490 (modify-syntax-entry ?% "$" table)
1491 (modify-syntax-entry ?\" "\"" table)
1493 ;; punctuation; operators etc
1494 (modify-syntax-entry ?# "w" table); based number - word syntax, since we don't need the number
1495 (modify-syntax-entry ?& "." table)
1496 (modify-syntax-entry ?* "." table)
1497 (modify-syntax-entry ?+ "." table)
1498 (modify-syntax-entry ?- ". 12" table); operator; see ada-syntax-propertize for double hyphen as comment
1499 (modify-syntax-entry ?. "." table)
1500 (modify-syntax-entry ?/ "." table)
1501 (modify-syntax-entry ?: "." table)
1502 (modify-syntax-entry ?< "." table)
1503 (modify-syntax-entry ?= "." table)
1504 (modify-syntax-entry ?> "." table)
1505 (modify-syntax-entry ?\' "." table); attribute; see ada-syntax-propertize for character literal
1506 (modify-syntax-entry ?\; "." table)
1507 (modify-syntax-entry ?\\ "." table); default is escape; not correct for Ada strings
1508 (modify-syntax-entry ?\| "." table)
1510 ;; and \f and \n end a comment
1511 (modify-syntax-entry ?\f ">" table)
1512 (modify-syntax-entry ?\n ">" table)
1514 (modify-syntax-entry ?_ "_" table); symbol constituents, not word.
1516 (modify-syntax-entry ?\( "()" table)
1517 (modify-syntax-entry ?\) ")(" table)
1519 ;; skeleton placeholder delimiters; see ada-skel.el. We use generic
1520 ;; comment delimiter class, not comment starter/comment ender, so
1521 ;; these can be distinguished from line end.
1522 (modify-syntax-entry ?{ "!" table)
1523 (modify-syntax-entry ?} "!" table)
1527 "Syntax table to be used for editing Ada source code.")
1529 (defvar ada-syntax-propertize-hook nil
1530 ;; provided by preprocessor, lumped with xref-tool
1531 "Hook run from `ada-syntax-propertize'.
1532 Called by `syntax-propertize', which is called by font-lock in
1533 `after-change-functions'. Therefore, care must be taken to avoid
1534 race conditions with the grammar parser.")
1536 (defun ada-syntax-propertize (start end)
1537 "Assign `syntax-table' properties in accessible part of buffer.
1538 In particular, character constants are set to have string syntax."
1539 ;; (info "(elisp)Syntax Properties")
1540 (let ((modified (buffer-modified-p))
1541 (buffer-undo-list t)
1542 (inhibit-read-only t)
1543 (inhibit-point-motion-hooks t)
1544 (inhibit-modification-hooks t))
1546 (while (re-search-forward
1548 "[^a-zA-Z0-9)]\\('\\)[^'\n]\\('\\)"; 1, 2: character constants, not attributes
1549 "\\|[^a-zA-Z0-9)]\\('''\\)"; 3: character constant '''
1550 "\\|\\(--\\)"; 4: comment start
1553 ;; The help for syntax-propertize-extend-region-functions
1554 ;; implies that 'start end' will always include whole lines, in
1555 ;; which case we don't need
1556 ;; syntax-propertize-extend-region-functions
1558 ((match-beginning 1)
1560 (match-beginning 1) (match-end 1) 'syntax-table '(7 . ?'))
1562 (match-beginning 2) (match-end 2) 'syntax-table '(7 . ?')))
1563 ((match-beginning 3)
1565 (match-beginning 3) (1+ (match-beginning 3)) 'syntax-table '(7 . ?'))
1567 (1- (match-end 3)) (match-end 3) 'syntax-table '(7 . ?')))
1568 ((match-beginning 4)
1570 (match-beginning 4) (match-end 4) 'syntax-table '(11 . nil)))
1572 (run-hook-with-args 'ada-syntax-propertize-hook start end)
1574 (restore-buffer-modified-p nil))))
1576 (defun ada-in-comment-p (&optional parse-result)
1577 "Return t if inside a comment.
1578 If PARSE-RESULT is non-nil, use it instead of calling `syntax-ppss'."
1579 (nth 4 (or parse-result (syntax-ppss))))
1581 (defun ada-in-string-p (&optional parse-result)
1582 "Return t if point is inside a string.
1583 If PARSE-RESULT is non-nil, use it instead of calling `syntax-ppss'."
1584 (nth 3 (or parse-result (syntax-ppss))))
1586 (defun ada-in-string-or-comment-p (&optional parse-result)
1587 "Return t if inside a comment or string.
1588 If PARSE-RESULT is non-nil, use it instead of calling `syntax-ppss'."
1589 (setq parse-result (or parse-result (syntax-ppss)))
1590 (or (ada-in-string-p parse-result) (ada-in-comment-p parse-result)))
1592 (defun ada-in-paren-p (&optional parse-result)
1593 "Return t if point is inside a pair of parentheses.
1594 If PARSE-RESULT is non-nil, use it instead of calling `syntax-ppss'."
1595 (> (nth 0 (or parse-result (syntax-ppss))) 0))
1597 (defun ada-goto-open-paren (&optional offset parse-result)
1598 "Move point to innermost opening paren surrounding current point, plus OFFSET.
1599 Throw error if not in paren. If PARSE-RESULT is non-nil, use it
1600 instead of calling `syntax-ppss'."
1601 (goto-char (+ (or offset 0) (nth 1 (or parse-result (syntax-ppss))))))
1603 ;;;; navigation within and between files
1605 (defvar ada-body-suffixes '(".adb")
1606 "List of possible suffixes for Ada body files.
1607 The extensions should include a `.' if needed.")
1609 (defvar ada-spec-suffixes '(".ads")
1610 "List of possible suffixes for Ada spec files.
1611 The extensions should include a `.' if needed.")
1613 (defvar ada-other-file-alist
1614 '(("\\.ads$" (".adb"))
1615 ("\\.adb$" (".ads")))
1616 "Alist used by `find-file' to find the name of the other package.
1617 See `ff-other-file-alist'.")
1619 (defconst ada-name-regexp
1620 "\\(\\(?:\\sw\\|[_.]\\)+\\)")
1622 (defconst ada-parent-name-regexp
1623 "\\([a-zA-Z0-9_\\.]+\\)\\.[a-zA-Z0-9_]+"
1624 "Regexp for extracting the parent name from fully-qualified name.")
1626 (defvar ada-file-name-from-ada-name nil
1627 ;; determined by ada-xref-tool, set by *-select-prj
1628 "Function called with one parameter ADA-NAME, which is a library
1629 unit name; it should return the filename in which ADA-NAME is
1632 (defun ada-file-name-from-ada-name (ada-name)
1633 "Return the filename in which ADA-NAME is found."
1634 (funcall ada-file-name-from-ada-name ada-name))
1636 (defvar ada-ada-name-from-file-name nil
1637 ;; depends on ada-compiler, per-project
1638 "Function called with one parameter FILE-NAME, which is a library
1639 unit name; it should return the Ada name that should be found in FILE-NAME.")
1641 (defun ada-ada-name-from-file-name (file-name)
1642 "Return the ada-name that should be found in FILE-NAME."
1643 (funcall ada-ada-name-from-file-name file-name))
1645 (defun ada-ff-special-extract-parent ()
1646 (setq ff-function-name (match-string 1))
1647 (file-name-nondirectory
1650 compilation-search-path
1651 (ada-file-name-from-ada-name ff-function-name)
1653 (error "parent '%s' not found; set project file?" ff-function-name))))
1655 (defun ada-ff-special-extract-separate ()
1656 (let ((package-name (match-string 1)))
1658 (goto-char (match-end 0))
1659 (when (eolp) (forward-char 1))
1660 (skip-syntax-forward " ")
1662 (concat "\\(function\\|package body\\|procedure\\|protected body\\|task body\\)\\s +"
1664 (setq ff-function-name (match-string 0))
1666 (file-name-nondirectory
1669 compilation-search-path
1670 (ada-file-name-from-ada-name package-name)
1672 (error "package '%s' not found; set project file?" package-name)))))
1674 (defun ada-ff-special-with ()
1675 (let ((package-name (match-string 1)))
1676 (setq ff-function-name (concat "^package\\s-+" package-name "\\([^_]\\|$\\)"))
1677 (file-name-nondirectory
1680 compilation-search-path
1681 (ada-file-name-from-ada-name package-name)
1682 (append ada-spec-suffixes ada-body-suffixes))
1683 (error "package '%s' not found; set project file?" package-name)))
1686 (defun ada-set-ff-special-constructs ()
1687 "Add Ada-specific pairs to `ff-special-constructs'."
1688 (set (make-local-variable 'ff-special-constructs) nil)
1689 (mapc (lambda (pair) (add-to-list 'ff-special-constructs pair))
1690 ;; Each car is a regexp; if it matches at point, the cdr is invoked.
1691 ;; Each cdr should set ff-function-name to a string or regexp
1692 ;; for ada-set-point-accordingly, and return the file name
1693 ;; (sans directory, must include suffix) to go to.
1695 ;; Top level child package declaration (not body), or child
1696 ;; subprogram declaration or body; go to the parent package.
1697 (cons (concat "^\\(?:private[ \t]+\\)?\\(?:package\\|procedure\\|function\\)[ \t]+"
1698 ada-parent-name-regexp "\\(?:;\\|[ \t]+\\|$\\)")
1699 'ada-ff-special-extract-parent)
1701 ;; A "separate" clause.
1702 (cons (concat "^separate[ \t\n]*(" ada-name-regexp ")")
1703 'ada-ff-special-extract-separate)
1705 ;; A "with" clause. Note that it may refer to a procedure body, as well as a spec
1706 (cons (concat "^\\(?:limited[ \t]+\\)?\\(?:private[ \t]+\\)?with[ \t]+" ada-name-regexp)
1707 'ada-ff-special-with)
1710 (defvar ada-which-function nil
1711 ;; supplied by indentation engine
1713 ;; This is run from ff-pre-load-hook, so ff-function-name may have
1714 ;; been set by ff-treat-special; don't reset it.
1715 "Function called with no parameters; it should return the name
1716 of the package, protected type, subprogram, or task type whose
1717 definition/declaration point is in or just after, or nil. In
1718 addition, if ff-function-name is non-nil, store in
1719 ff-function-name a regexp that will find the function in the
1722 (defun ada-which-function ()
1723 "See `ada-which-function' variable."
1725 (when ada-which-function
1726 (funcall ada-which-function)))
1728 (defun ada-add-log-current-function ()
1729 "For `add-log-current-defun-function'; uses `ada-which-function'."
1730 ;; add-log-current-defun is typically called with point at the start
1731 ;; of an ediff change section, which is before the start of the
1732 ;; declaration of a new item. So go to the end of the current line
1733 ;; first, then call `ada-which-function'
1736 (ada-which-function)))
1738 (defun ada-set-point-accordingly ()
1739 "Move to the string specified in `ff-function-name', which may be a regexp,
1740 previously set by a file navigation command."
1741 (when ff-function-name
1744 (goto-char (point-min))
1745 ;; We are looking for an Ada declaration, so don't stop for strings or comments
1747 ;; This will still be confused by multiple references; we need
1748 ;; to use compiler cross reference info for more precision.
1750 (when (search-forward-regexp ff-function-name nil t)
1751 (setq found (match-beginning 0)))
1752 (if (ada-in-string-or-comment-p)
1757 ;; different parsers find different points on the line; normalize here
1758 (back-to-indentation))
1759 (setq ff-function-name nil))))
1761 (defun ada-find-other-file-noset (other-window)
1762 "Same as `ada-find-other-file', but preserve point in the other file,
1763 don't move to corresponding declaration."
1765 (ada-find-other-file other-window t))
1767 (defun ada-find-other-file (other-window &optional no-set-point)
1768 "Move to the corresponding declaration in another file.
1770 - If region is active, assume it contains a package name;
1771 position point on that package declaration.
1773 - If point is in the start line of a non-nested child package or
1774 subprogram declaration, position point on the corresponding
1775 parent package specification.
1777 - If point is in the start line of a separate body,
1778 position point on the corresponding separate stub declaration.
1780 - If point is in a context clause line, position point on the
1781 first package declaration that is mentioned.
1783 - If point is in a subprogram body or specification, position point
1784 on the corresponding specification or body.
1786 If OTHER-WINDOW (set by interactive prefix) is non-nil, show the
1787 buffer in another window.
1789 If NO-SET-POINT is nil, set point in the other file on the
1790 corresponding declaration. If non-nil, preserve existing point in
1793 ;; ff-get-file, ff-find-other file first process
1794 ;; ff-special-constructs, then run the following hooks:
1796 ;; ff-pre-load-hook set to ada-which-function
1797 ;; ff-file-created-hook set to ada-ff-create-body
1798 ;; ff-post-load-hook set to ada-set-point-accordingly,
1799 ;; or to a compiler-specific function that
1800 ;; uses compiler-generated cross reference
1804 (when (null (car compilation-search-path))
1805 (error "no file search path defined; set project file?"))
1809 (setq ff-function-name (buffer-substring-no-properties (point) (mark)))
1811 compilation-search-path
1812 (ada-file-name-from-ada-name ff-function-name)
1817 ;; else use name at point
1818 (ff-find-other-file other-window)))
1820 (defvar ada-operator-re
1821 "\\+\\|-\\|/\\|\\*\\*\\|\\*\\|=\\|&\\|abs\\|mod\\|rem\\|and\\|not\\|or\\|xor\\|<=\\|<\\|>=\\|>"
1822 "Regexp matching Ada operator_symbol.")
1824 (defun ada-identifier-at-point ()
1825 "Return the identifier around point, move point to start of
1826 identifier. May be an Ada identifier or operator function name."
1828 (when (ada-in-comment-p)
1829 (error "Inside comment"))
1833 (skip-chars-backward "a-zA-Z0-9_<>=+\\-\\*/&")
1835 ;; Just in front of, or inside, a string => we could have an operator
1840 ((and (= (char-before) ?\")
1843 (looking-at (concat "\"\\(" ada-operator-re "\\)\""))))
1844 (setq identifier (concat "\"" (match-string-no-properties 1) "\"")))
1847 (error "Inside string or character constant"))
1850 ((and (= (char-after) ?\")
1851 (looking-at (concat "\"\\(" ada-operator-re "\\)\"")))
1852 (setq identifier (concat "\"" (match-string-no-properties 1) "\"")))
1854 ((looking-at "[a-zA-Z0-9_]+")
1855 (setq identifier (match-string-no-properties 0)))
1858 (error "No identifier around"))
1861 (defun ada-goto-source (file line column other-window)
1862 "Find and select FILE, at LINE and COLUMN.
1863 FILE may be absolute, or on `compilation-search-path'.
1865 If OTHER-WINDOW is non-nil, show the buffer in another window."
1866 (or (file-name-absolute-p file)
1867 (setq file (ff-get-file-name compilation-search-path file)))
1868 (let ((buffer (get-file-buffer file)))
1872 ((null other-window)
1873 (switch-to-buffer buffer))
1875 (t (switch-to-buffer-other-window buffer))
1878 ((file-exists-p file)
1880 ((null other-window)
1884 (find-file-other-window file))
1888 (error "'%s' not found" file))))
1891 ;; move the cursor to the correct position
1893 (goto-char (point-min))
1894 (forward-line (1- line))
1895 (forward-char column)
1898 (defvar ada-xref-refresh-function nil
1899 ;; determined by xref_tool, set by *-select-prj-xref
1900 "Function that refreshes cross reference information cache.")
1902 (defun ada-xref-refresh ()
1903 "Refresh cross reference information cache, if any."
1906 (when (null ada-xref-refresh-function)
1907 (error "no cross reference information available"))
1909 (funcall ada-xref-refresh-function)
1912 (defvar ada-xref-other-function nil
1913 ;; determined by xref_tool, set by *-select-prj-xref
1914 "Function that returns cross reference information.
1915 Function is called with four arguments:
1916 - an Ada identifier or operator_symbol
1917 - filename containing the identifier
1918 - line number containing the identifier
1919 - column of the start of the identifier
1920 Returns a list '(file line column) giving the corresponding location.
1921 'file' may be absolute, or on `compilation-search-path'. If point is
1922 at the specification, the corresponding location is the body, and vice
1925 (defun ada-goto-declaration (other-window)
1926 "Move to the declaration or body of the identifier around point.
1927 If at the declaration, go to the body, and vice versa.
1929 If OTHER-WINDOW (set by interactive prefix) is non-nil, show the
1930 buffer in another window."
1933 (when (null ada-xref-other-function)
1934 (error "no cross reference information available"))
1937 (funcall ada-xref-other-function
1938 (ada-identifier-at-point)
1939 (file-name-nondirectory (buffer-file-name))
1940 (line-number-at-pos)
1941 (1+ (current-column))
1944 (ada-goto-source (nth 0 target)
1950 (defvar ada-xref-parent-function nil
1951 ;; determined by xref_tool, set by *-select-prj-xref
1952 "Function that returns cross reference information.
1953 Function is called with four arguments:
1954 - an Ada identifier or operator_symbol
1955 - filename containing the identifier
1956 - line number containing the identifier
1957 - column of the start of the identifier
1958 Displays a buffer in compilation-mode giving locations of the parent type declarations.")
1960 (defun ada-show-declaration-parents ()
1961 "Display the locations of the parent type declarations of the type identifier around point."
1963 (when (null ada-xref-parent-function)
1964 (error "no cross reference information available"))
1966 (funcall ada-xref-parent-function
1967 (ada-identifier-at-point)
1968 (file-name-nondirectory (buffer-file-name))
1969 (line-number-at-pos)
1970 (1+ (current-column)))
1973 (defvar ada-xref-all-function nil
1974 ;; determined by xref_tool, set by *-select-prj-xref
1975 "Function that displays cross reference information.
1976 Called with four arguments:
1977 - an Ada identifier or operator_symbol
1978 - filename containing the identifier
1979 - line number containing the identifier
1980 - column of the start of the identifier
1981 Displays a buffer in compilation-mode giving locations where the
1982 identifier is declared or referenced.")
1984 (defun ada-show-references ()
1985 "Show all references of identifier at point."
1988 (when (null ada-xref-all-function)
1989 (error "no cross reference information available"))
1991 (funcall ada-xref-all-function
1992 (ada-identifier-at-point)
1993 (file-name-nondirectory (buffer-file-name))
1994 (line-number-at-pos)
1995 (cl-case (char-after)
1996 (?\" (+ 2 (current-column))) ;; FIXME: work around bug in gnat find
1997 (t (1+ (current-column)))))
2000 (defvar ada-xref-overriding-function nil
2001 ;; determined by ada-xref-tool, set by *-select-prj
2002 "Function that displays cross reference information for overriding subprograms.
2003 Called with four arguments:
2004 - an Ada identifier or operator_symbol
2005 - filename containing the identifier
2006 - line number containing the identifier
2007 - column of the start of the identifier
2008 Displays a buffer in compilation-mode giving locations of the overriding declarations.")
2010 (defun ada-show-overriding ()
2011 "Show all overridings of identifier at point."
2014 (when (null ada-xref-overriding-function)
2015 (error "no cross reference information available"))
2017 (funcall ada-xref-overriding-function
2018 (ada-identifier-at-point)
2019 (file-name-nondirectory (buffer-file-name))
2020 (line-number-at-pos)
2021 (1+ (current-column)))
2024 (defvar ada-xref-overridden-function nil
2025 ;; determined by ada-xref-tool, set by *-select-prj
2026 "Function that displays cross reference information for overridden subprogram.
2027 Called with four arguments:
2028 - an Ada identifier or operator_symbol
2029 - filename containing the identifier
2030 - line number containing the identifier
2031 - column of the start of the identifier
2032 Returns a list '(file line column) giving the corresponding location.
2033 'file' may be absolute, or on `compilation-search-path'.")
2035 (defun ada-show-overridden (other-window)
2036 "Show the overridden declaration of identifier at point."
2039 (when (null ada-xref-overridden-function)
2040 (error "'show overridden' not supported, or no cross reference information available"))
2043 (funcall ada-xref-overridden-function
2044 (ada-identifier-at-point)
2045 (file-name-nondirectory (buffer-file-name))
2046 (line-number-at-pos)
2047 (1+ (current-column)))))
2049 (ada-goto-source (nth 0 target)
2056 ;; This is autoloaded because it may be used in ~/.emacs
2058 (defun ada-add-extensions (spec body)
2059 "Define SPEC and BODY as being valid extensions for Ada files.
2060 SPEC and BODY are two regular expressions that must match against
2062 (let* ((reg (concat (regexp-quote body) "$"))
2063 (tmp (assoc reg ada-other-file-alist)))
2065 (setcdr tmp (list (cons spec (cadr tmp))))
2066 (add-to-list 'ada-other-file-alist (list reg (list spec)))))
2068 (let* ((reg (concat (regexp-quote spec) "$"))
2069 (tmp (assoc reg ada-other-file-alist)))
2071 (setcdr tmp (list (cons body (cadr tmp))))
2072 (add-to-list 'ada-other-file-alist (list reg (list body)))))
2074 (add-to-list 'auto-mode-alist
2075 (cons (concat (regexp-quote spec) "\\'") 'ada-mode))
2076 (add-to-list 'auto-mode-alist
2077 (cons (concat (regexp-quote body) "\\'") 'ada-mode))
2079 (add-to-list 'ada-spec-suffixes spec)
2080 (add-to-list 'ada-body-suffixes body)
2082 (when (fboundp 'speedbar-add-supported-extension)
2083 (speedbar-add-supported-extension spec)
2084 (speedbar-add-supported-extension body))
2087 (defun ada-show-secondary-error (other-window)
2088 "Show the next secondary file reference in the compilation buffer.
2089 A secondary file reference is defined by text having text
2090 property `ada-secondary-error'. These can be set by
2091 compiler-specific compilation filters.
2093 If OTHER-WINDOW (set by interactive prefix) is non-nil, show the
2094 buffer in another window."
2097 ;; preserving the current window works only if the frame
2098 ;; doesn't change, at least on Windows.
2099 (let ((start-buffer (current-buffer))
2100 (start-window (selected-window))
2102 (set-buffer compilation-last-buffer)
2103 (setq pos (next-single-property-change (point) 'ada-secondary-error))
2105 (setq item (get-text-property pos 'ada-secondary-error))
2106 ;; file-relative-name handles absolute Windows paths from
2107 ;; g++. Do this in compilation buffer to get correct
2108 ;; default-directory.
2109 (setq file (file-relative-name (nth 0 item)))
2111 ;; Set point in compilation buffer past this secondary error, so
2112 ;; user can easily go to the next one. For some reason, this
2113 ;; doesn't change the visible point!?
2116 (set-buffer start-buffer);; for windowing history
2121 (nth 2 item); column
2123 (select-window start-window)
2127 (defvar ada-goto-declaration-start nil
2128 ;; Supplied by indentation engine.
2130 ;; This is run from ff-pre-load-hook, so ff-function-name may have
2131 ;; been set by ff-treat-special; don't reset it.
2132 "Function to move point to start of the generic, package,
2133 protected, subprogram, or task declaration point is currently in
2134 or just after. Called with no parameters.")
2136 (defun ada-goto-declaration-start ()
2137 "Call `ada-goto-declaration-start'."
2138 (when ada-goto-declaration-start
2139 (funcall ada-goto-declaration-start)))
2141 (defvar ada-goto-declarative-region-start nil
2142 ;; Supplied by indentation engine
2143 "Function to move point to start of the declarative region of
2144 the subprogram, package, task, or declare block point
2145 is currently in. Called with no parameters.")
2147 (defun ada-goto-declarative-region-start ()
2148 "Call `ada-goto-declarative-region-start'."
2149 (when ada-goto-declarative-region-start
2150 (funcall ada-goto-declarative-region-start)))
2152 (defvar ada-next-statement-keyword nil
2153 ;; Supplied by indentation engine
2154 "Function called with no parameters; it should move forward to
2155 the next keyword in the statement following the one point is
2156 in (ie from 'if' to 'then'). If not in a keyword, move forward
2157 to the next keyword in the current statement. If at the last keyword,
2158 move forward to the first keyword in the next statement or next
2159 keyword in the containing statement.")
2161 (defvar ada-goto-end nil
2162 ;; Supplied by indentation engine
2163 "Function to move point to end of the declaration or statement point is in or before.
2164 Called with no parameters.")
2166 (defun ada-goto-end ()
2167 "Call `ada-goto-end'."
2169 (funcall ada-goto-end)))
2171 (defun ada-next-statement-keyword ()
2172 ;; Supplied by indentation engine
2173 "See `ada-next-statement-keyword' variable."
2175 (when ada-next-statement-keyword
2176 (funcall ada-next-statement-keyword)))
2178 (defvar ada-prev-statement-keyword nil
2179 ;; Supplied by indentation engine
2180 "Function called with no parameters; it should move to the previous
2181 keyword in the statement following the one point is in (ie from
2182 'then' to 'if'). If at the first keyword, move to the previous
2183 keyword in the previous statement or containing statement.")
2185 (defun ada-prev-statement-keyword ()
2186 "See `ada-prev-statement-keyword' variable."
2188 (when ada-prev-statement-keyword
2189 (funcall ada-prev-statement-keyword)))
2193 (defvar ada-make-subprogram-body nil
2194 ;; Supplied by indentation engine
2195 "Function to convert subprogram specification after point into a subprogram body stub.
2196 Called with no args, point at declaration start. Leave point in
2197 subprogram body, for user to add code.")
2199 (defun ada-make-subprogram-body ()
2200 "If point is in or after a subprogram specification, convert it
2201 into a subprogram body stub, by calling `ada-make-subprogram-body'."
2203 (ada-goto-declaration-start)
2204 (if ada-make-subprogram-body
2205 (funcall ada-make-subprogram-body)
2206 (error "`ada-make-subprogram-body' not set")))
2208 (defvar ada-make-package-body nil
2209 ;; Supplied by compiler
2210 "Function to create a package body from a package spec.
2211 Called with one argument; the absolute path to the body
2212 file. Current buffer is the package spec. Should create the
2213 package body file, containing skeleton code that will compile.")
2215 (defun ada-make-package-body (body-file-name)
2216 (if ada-make-package-body
2217 (funcall ada-make-package-body body-file-name)
2218 (error "`ada-make-package-body' not set")))
2220 (defun ada-ff-create-body ()
2221 ;; ff-find-other-file calls us with point in an empty buffer for the
2222 ;; body file; ada-make-package-body expects to be in the spec. So go
2224 (let ((body-file-name (buffer-file-name)))
2225 (ff-find-the-other-file)
2226 (ada-make-package-body body-file-name)
2227 ;; FIXME (later): if 'ada-make-package-body' fails, delete the body buffer
2228 ;; so it doesn't get written to disk, and we can try again.
2230 ;; back to the body, read in from the disk.
2231 (ff-find-the-other-file)
2237 (defun ada-fill-comment-paragraph (&optional justify postfix)
2238 "Fill the current comment paragraph.
2239 If JUSTIFY is non-nil, each line is justified as well.
2240 If POSTFIX and JUSTIFY are non-nil, `ada-fill-comment-postfix' is appended
2241 to each line filled and justified.
2242 The paragraph is indented on the first line."
2244 (if (and (not (ada-in-comment-p))
2245 (not (looking-at "[ \t]*--")))
2246 (error "Not inside comment"))
2248 (let* (indent from to
2249 (opos (point-marker))
2250 ;; we bind `fill-prefix' here rather than in ada-mode because
2251 ;; setting it in ada-mode causes indent-region to use it for
2253 (fill-prefix ada-fill-comment-prefix)
2254 (fill-column (current-fill-column)))
2256 ;; Find end of comment paragraph
2257 (back-to-indentation)
2258 (while (and (not (eobp)) (looking-at ".*--[ \t]*[^ \t\n]"))
2261 ;; If we were at the last line in the buffer, create a dummy empty
2262 ;; line at the end of the buffer.
2265 (back-to-indentation)))
2267 (setq to (point-marker))
2270 ;; Find beginning of paragraph
2271 (back-to-indentation)
2272 (while (and (not (bobp)) (looking-at ".*--[ \t]*[^ \t\n]"))
2274 (back-to-indentation))
2279 (setq from (point-marker))
2281 ;; Calculate the indentation we will need for the paragraph
2282 (back-to-indentation)
2283 (setq indent (current-column))
2284 ;; unindent the first line of the paragraph
2285 (delete-region from (point))
2287 ;; Remove the old postfixes
2289 (while (re-search-forward (concat "\\(" ada-fill-comment-postfix "\\)" "\n") to t)
2290 (delete-region (match-beginning 1) (match-end 1)))
2293 (setq to (point-marker))
2295 ;; Indent and justify the paragraph
2296 (set-left-margin from to indent)
2298 (setq fill-column (- fill-column (length ada-fill-comment-postfix))))
2300 (fill-region-as-paragraph from to justify)
2302 ;; Add the postfixes if required
2306 (narrow-to-region from to)
2309 (insert-char ? (- fill-column (current-column)))
2310 (insert ada-fill-comment-postfix)
2316 ;;;; support for font-lock.el
2318 ;; casing keywords defined here to keep the two lists together
2319 (defconst ada-83-keywords
2320 '("abort" "abs" "accept" "access" "all" "and" "array" "at" "begin"
2321 "body" "case" "constant" "declare" "delay" "delta" "digits" "do"
2322 "else" "elsif" "end" "entry" "exception" "exit" "for" "function"
2323 "generic" "goto" "if" "in" "is" "limited" "loop" "mod" "new"
2324 "not" "null" "of" "or" "others" "out" "package" "pragma" "private"
2325 "procedure" "raise" "range" "record" "rem" "renames" "return"
2326 "reverse" "select" "separate" "subtype" "task" "terminate" "then"
2327 "type" "use" "when" "while" "with" "xor")
2328 "List of Ada 83 keywords.")
2330 (defconst ada-95-keywords
2331 '("abstract" "aliased" "protected" "requeue" "tagged" "until")
2332 "List of keywords new in Ada 95.")
2334 (defconst ada-2005-keywords
2335 '("interface" "overriding" "synchronized")
2336 "List of keywords new in Ada 2005.")
2338 (defconst ada-2012-keywords
2340 "List of keywords new in Ada 2012.")
2342 (defvar ada-keywords nil
2343 "List of Ada keywords for current `ada-language-version'.")
2345 (defun ada-font-lock-keywords ()
2346 "Return Ada mode value for `font-lock-keywords', depending on `ada-language-version'."
2349 ;; keywords followed by a name that should be in function-name-face.
2358 "package[ \t]+body\\|"
2366 (when (member ada-language-version '(ada95 ada2005 ada2012))
2368 "protected[ \t]+body\\|"
2369 "protected[ \t]+function\\|"
2370 "protected[ \t]+procedure\\|"
2371 "protected[ \t]+type\\|"
2376 ada-name-regexp "?")))
2377 '(1 font-lock-keyword-face) '(2 font-lock-function-name-face nil t))
2379 ;; keywords followed by a name that should be in type-face.
2382 "access[ \t]+all\\|"
2383 "access[ \t]+constant\\|"
2386 "in[ \t]+reverse\\|"; loop iterator
2387 "in[ \t]+not[ \t]+null\\|"
2388 "in[ \t]+out[ \t]+not[ \t]+null\\|"
2391 ;; "return\\|" can't distinguish between 'function ... return <type>;' and 'return ...;'
2392 ;; An indentation engine can, so a rule for this is added there
2393 "of[ \t]+reverse\\|"
2399 ada-name-regexp "?")
2400 '(1 font-lock-keyword-face nil t) '(2 font-lock-type-face nil t))
2402 ;; Keywords not treated elsewhere. After above so it doesn't
2403 ;; override fontication of second or third word in those patterns.
2408 '("abort" "abs" "accept" "all"
2409 "and" "array" "at" "begin" "case" "declare" "delay" "delta"
2410 "digits" "do" "else" "elsif" "entry" "exception" "exit" "for"
2411 "generic" "if" "in" "limited" "loop" "mod" "not"
2412 "null" "or" "others" "private" "raise"
2413 "range" "record" "rem" "renames" "reverse"
2414 "select" "separate" "task" "terminate"
2415 "then" "when" "while" "xor")
2416 (when (member ada-language-version '(ada95 ada2005 ada2012))
2417 '("abstract" "aliased" "requeue" "tagged" "until"))
2418 (when (member ada-language-version '(ada2005 ada2012))
2419 '("interface" "overriding" "synchronized"))
2420 (when (member ada-language-version '(ada2012))
2425 '(0 font-lock-keyword-face))
2427 ;; object and parameter declarations; word after ":" should be in
2428 ;; type-face if not already fontified or an exception.
2433 '(1 (if (match-beginning 2)
2435 font-lock-type-face)
2438 ;; keywords followed by a name that should be in function-name-face if not already fontified
2443 ada-name-regexp "?")
2444 '(1 font-lock-keyword-face) '(2 font-lock-function-name-face nil t))
2446 ;; Keywords followed by a name that could be a type or a function (generic instantiation).
2451 ada-name-regexp "?[ \t]*\\((\\)?")
2452 '(1 font-lock-keyword-face)
2453 '(2 (if (match-beginning 3)
2454 font-lock-function-name-face
2455 font-lock-type-face)
2458 ;; keywords followed by a name that should be in type-face if not already fontified (for subtypes)
2459 ;; after "new" to handle "is new"
2464 ada-name-regexp "?")
2465 '(1 font-lock-keyword-face) '(2 font-lock-type-face nil t))
2467 ;; Keywords followed by a comma separated list of names which
2468 ;; should be in constant-face, unless already fontified. Ada mode 4.01 used this.
2473 ;; don't need "limited" "private" here; they are matched separately
2474 "with"; context clause
2476 "\\(\\(?:\\sw\\|[_., \t]\\)+\\>\\)?"; ada-name-regexp, plus ", \t"
2478 '(1 font-lock-keyword-face) '(2 font-lock-constant-face nil t))
2481 '("<<\\(\\sw+\\)>>" 1 font-lock-constant-face)
2483 ;; based numberic literals
2484 (list "\\([0-9]+#[0-9a-fA-F_]+#\\)" '(1 font-lock-constant-face t))
2487 (list "\\W\\([-+]?[0-9._]+\\)\\>" '(1 font-lock-constant-face))
2493 ;; autoload required by automatic mode setting
2496 "The major mode for editing Ada code."
2497 ;; the other ada-*.el files add to ada-mode-hook for their setup
2500 (kill-all-local-variables)
2501 (setq major-mode 'ada-mode)
2502 (setq mode-name "Ada")
2503 (use-local-map ada-mode-map)
2504 (set-syntax-table ada-mode-syntax-table)
2505 (define-abbrev-table 'ada-mode-abbrev-table ())
2506 (setq local-abbrev-table ada-mode-abbrev-table)
2508 (set (make-local-variable 'syntax-propertize-function) 'ada-syntax-propertize)
2509 (set (make-local-variable 'syntax-begin-function) nil)
2510 (set (make-local-variable 'parse-sexp-ignore-comments) t)
2511 (set (make-local-variable 'parse-sexp-lookup-properties) t)
2512 (set 'case-fold-search t); Ada is case insensitive; the syntax parsing requires this setting
2513 (set (make-local-variable 'comment-start) "--")
2514 (set (make-local-variable 'comment-end) "")
2515 (set (make-local-variable 'comment-start-skip) "---*[ \t]*")
2516 (set (make-local-variable 'comment-multi-line) nil)
2518 ;; we _don't_ set `fill-prefix' here because that causes
2519 ;; indent-region to use it for all indentation. See
2520 ;; ada-fill-comment-paragraph.
2522 ;; AdaCore standard style (enforced by -gnaty) requires two spaces
2523 ;; after '--' in comments; this makes it easier to distinguish
2524 ;; special comments that have something else after '--'
2525 (set (make-local-variable 'comment-padding) " ")
2527 (set (make-local-variable 'require-final-newline) t)
2529 (setq font-lock-defaults
2530 '(ada-font-lock-keywords
2532 ((?\_ . "w")))); treat underscore as a word component
2534 (set (make-local-variable 'ff-other-file-alist)
2535 'ada-other-file-alist)
2536 (setq ff-post-load-hook 'ada-set-point-accordingly
2537 ff-file-created-hook 'ada-ff-create-body)
2538 (add-hook 'ff-pre-load-hook 'ada-which-function)
2539 (setq ff-search-directories 'compilation-search-path)
2540 (ada-set-ff-special-constructs)
2542 (set (make-local-variable 'add-log-current-defun-function)
2543 'ada-add-log-current-function)
2545 (when (boundp 'which-func-functions)
2546 (add-hook 'which-func-functions 'ada-which-function nil t))
2548 ;; Support for align
2549 (add-to-list 'align-dq-string-modes 'ada-mode)
2550 (add-to-list 'align-open-comment-modes 'ada-mode)
2551 (set (make-local-variable 'align-region-separate) ada-align-region-separate)
2552 (set (make-local-variable 'align-indent-before-aligning) t)
2554 ;; Exclude comments alone on line from alignment.
2555 (add-to-list 'align-exclude-rules-list
2557 (regexp . "^\\(\\s-*\\)--")
2558 (modes . '(ada-mode))))
2559 (add-to-list 'align-exclude-rules-list
2561 (regexp . "^\\(\\s-*\\)\\<use\\>")
2562 (modes . '(ada-mode))))
2564 (setq align-mode-rules-list ada-align-rules)
2566 (easy-menu-add ada-mode-menu ada-mode-map)
2568 (run-mode-hooks 'ada-mode-hook)
2570 ;; If global-font-lock is not enabled, ada-syntax-propertize is
2571 ;; not run when the text is first loaded into the buffer. Recover
2573 (syntax-ppss-flush-cache (point-min))
2574 (syntax-propertize (point-max))
2576 (add-hook 'hack-local-variables-hook 'ada-mode-post-local-vars nil t)
2579 (defun ada-mode-post-local-vars ()
2580 ;; These are run after ada-mode-hook and file local variables
2581 ;; because users or other ada-* files might set the relevant
2582 ;; variable inside the hook or file local variables (file local
2583 ;; variables are processed after the mode is set, and thus after
2584 ;; ada-mode is run).
2586 ;; This means to fully set ada-mode interactively, user must
2587 ;; do M-x ada-mode M-; (hack-local-variables)
2589 (when ada-auto-case (ada-case-activate-keys))
2591 (when global-font-lock-mode
2592 ;; This calls ada-font-lock-keywords, which depends on
2593 ;; ada-language-version
2594 (font-lock-refresh-defaults))
2596 (cl-case ada-language-version
2598 (setq ada-keywords ada-83-keywords))
2602 (append ada-83-keywords
2607 (append ada-83-keywords
2609 ada-2005-keywords)))
2612 (append ada-83-keywords
2615 ada-2012-keywords))))
2618 (put 'ada-mode 'custom-mode-group 'ada)
2622 ;;;;; Global initializations
2624 (require 'ada-build)
2626 (unless (featurep 'ada-indent-engine)
2627 (require 'ada-wisi))
2629 (unless (featurep 'ada-compiler)
2630 (require 'ada-gnat-compile))
2632 (unless (featurep 'ada-xref-tool)
2633 (cl-case ada-xref-tool
2634 ((nil 'gnat) (require 'ada-gnat-xref))
2635 ('gnat_inspect (require 'gnat-inspect))
2638 (unless (featurep 'ada-skeletons)
2639 (require 'ada-skel))
2641 (when (featurep 'imenu)
2642 (require 'ada-imenu))