-;;; ada-mode.el --- major-mode for editing Ada sources
+;;; ada-mode.el --- major-mode for editing Ada sources -*- lexical-binding:t -*-
;;
-;;; Copyright (C) 1994, 1995, 1997 - 2014 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 1995, 1997 - 2016 Free Software Foundation, Inc.
;;
;; Author: Stephen Leake <stephen_leake@member.fsf.org>
;; Maintainer: Stephen Leake <stephen_leake@member.fsf.org>
;; Keywords: languages
;; ada
-;; Version: 5.1.6
-;; package-requires: ((wisi "1.0.6") (cl-lib "0.4") (emacs "24.2"))
+;; Version: 5.1.9
+;; package-requires: ((wisi "1.1.2") (cl-lib "0.4") (emacs "24.2"))
;; url: http://stephe-leake.org/emacs/ada-mode/emacs-ada-mode.html
;;
;; (Gnu ELPA requires single digits between dots in versions)
(defun ada-mode-version ()
"Return Ada mode version."
(interactive)
- (let ((version-string "5.1.6"))
+ (let ((version-string "5.1.9"))
;; must match:
;; ada-mode.texi
- ;; README
+ ;; README-ada-mode
;; Version: above
(if (called-interactively-p 'interactive)
(message version-string)
Casing of Ada keywords is done according to `ada-case-keyword',
identifiers are Mixed_Case."
:type 'boolean
- :group 'ada
- :safe 'booleanp)
+ :safe #'booleanp)
(make-variable-buffer-local 'ada-auto-case)
(defcustom ada-case-exception-file nil
"Default list of special casing exceptions dictionaries for identifiers.
-Override with 'casing' project variable.
+Override with `casing' project variable.
New exceptions may be added interactively via `ada-case-create-exception'.
If an exception is defined in multiple files, the first occurence is used.
character. Characters after the first word are ignored, and not
preserved when the list is written back to the file."
:type '(repeat (file))
- :group 'ada
- :safe 'listp)
+ :safe #'listp)
-(defcustom ada-case-keyword 'downcase-word
+(defcustom ada-case-keyword 'lower-case
"Buffer-local value that may override project variable `case_keyword'.
Global value is default for project variable `case_keyword'.
Function to call to adjust the case of Ada keywords."
- :type '(choice (const downcase-word)
- (const upcase-word))
- :group 'ada
- :safe 'functionp)
+ :type '(choice (const lower-case)
+ (const upper-case))
+ ;; We'd like to specify that the value must be a function that takes
+ ;; one arg, but custom doesn't support that. ':safe' is supposed
+ ;; to be used to prevent user-provided functions from compromising
+ ;; security, so ":safe #'functionp" is not appropriate. So we
+ ;; use a symbol, and a cl-ecase in ada-case-keyword.
+ :safe (lambda (val) (memq val '(lower-case upper-case)))
+ )
(make-variable-buffer-local 'ada-case-keyword)
-(defcustom ada-case-identifier 'ada-mixed-case
+(defcustom ada-case-identifier 'mixed-case
"Buffer-local value that may override project variable `case_keyword'.
Global value is default for project variable `case_keyword'.
-Function to call to adjust the case of Ada keywords."
- :type '(choice (const ada-mixed-case)
- (const downcase-region)
- (const upcase-region))
- :group 'ada
- :safe 'functionp)
+Function to call to adjust the case of Ada keywords.
+Called with three args;
+start - buffer pos of start of identifier
+end - end of identifier
+force-case - if t, treat `ada-case-strict' as t"
+ :type '(choice (const mixed-case)
+ (const lower-case)
+ (const upper-case))
+ ;; see comment on :safe at ada-case-keyword
+ :safe (lambda (val) (memq val '(mixed-case lower-case upper-case)))
+ )
+;; we'd like to check that there are 3 args, since the previous
+;; release required 2 here. But there doesn't seem to be a way to
+;; access the arg count, which is only available for byte-compiled
+;; functions
(make-variable-buffer-local 'ada-case-identifier)
(defcustom ada-case-strict t
If non-nil, force Mixed_Case for identifiers.
Otherwise, allow UPPERCASE for identifiers."
:type 'boolean
- :group 'ada
- :safe 'booleanp)
+ :safe #'booleanp)
(make-variable-buffer-local 'ada-case-strict)
(defcustom ada-language-version 'ada2012
(const ada95)
(const ada2005)
(const ada2012))
- :group 'ada
- :safe 'symbolp)
+ :safe #'symbolp)
(make-variable-buffer-local 'ada-language-version)
(defcustom ada-fill-comment-prefix "-- "
"Comment fill prefix."
- :type 'string
- :group 'ada)
+ :type 'string)
(make-variable-buffer-local 'ada-language-version)
(defcustom ada-fill-comment-postfix " --"
"Comment fill postfix."
- :type 'string
- :group 'ada)
+ :type 'string)
(make-variable-buffer-local 'ada-language-version)
(defcustom ada-prj-file-extensions '("adp" "prj")
"List of Emacs Ada mode project file extensions.
Used when searching for a project file.
Any file with one of these extensions will be parsed by `ada-prj-parse-file-1'."
- :type 'list
- :group 'ada)
+ :type 'list)
(defcustom ada-prj-file-ext-extra nil
"List of secondary project file extensions.
Used when searching for a project file that can be a primary or
secondary project file (referenced from a primary). The user
must provide a parser for a file with one of these extensions."
- :type 'list
+ :type 'list)
+
+(defcustom ada-prj-parse-hook nil
+ "Hook run at start of `ada-parse-prj-file'.
+Useful for setting `ada-xref-tool' and similar vars."
+ :type 'function
:group 'ada)
;;;;; end of user variables
(define-key map "\C-c\C-x" 'ada-show-overriding)
(define-key map "\C-c\M-x" 'ada-show-overridden)
(define-key map "\C-c\C-y" 'ada-case-create-exception)
- (define-key map "\C-c\M-y" 'ada-case-create-partial-exception)
+ (define-key map "\C-c\C-\M-y" 'ada-case-create-partial-exception)
(define-key map [C-down-mouse-3] 'ada-popup-menu)
(ada-case-activate-keys map)
["Find and select project ..." ada-build-prompt-select-prj-file t]
["Select project ..." ada-prj-select t]
["Show project" ada-prj-show t]
- ["Show project search path" ada-prj-show-path t]
+ ["Show project file search path" ada-prj-show-prj-path t]
+ ["Show source file search path" ada-prj-show-src-path t]
)
("Build"
["Next compilation error" next-error t]
("Navigate"
["Other file" ada-find-other-file t]
["Other file don't find decl" ada-find-other-file-noset t]
+ ["Find file in project" ada-find-file t]
["Goto declaration/body" ada-goto-declaration t]
["Goto next statement keyword" ada-next-statement-keyword t]
["Goto declaration start" ada-goto-declaration-start t]
["Indent current statement" ada-indent-statement t]
["Goto next statement keyword" ada-next-statement-keyword t]
["Goto prev statement keyword" ada-next-statement-keyword t]
- ["Other File" ada-find-other-file t]
- ["Other file don't find decl" ada-find-other-file-noset t]))
+ ["Other File" ada-find-other-file t]))
-(defun ada-popup-menu (position)
- "Pops up a `ada-context-menu', with `ada-context-menu-on-identifer' set appropriately.
-POSITION is the location the mouse was clicked on.
-Sets `ada-context-menu-last-point' to the current position before
-displaying the menu. When a function from the menu is called,
-point is where the mouse button was clicked."
- (interactive "e")
+(defun ada-popup-menu ()
+ "Pops up `ada-context-menu'.
+When a function from the menu is called, point is where the mouse
+button was clicked."
+ (interactive)
(mouse-set-point last-input-event)
-
- (setq ada-context-menu-on-identifier
- (and (char-after)
- (or (= (char-syntax (char-after)) ?w)
- (= (char-after) ?_))
- (not (ada-in-string-or-comment-p))
- (save-excursion (skip-syntax-forward "w")
- (not (ada-after-keyword-p)))
- ))
- (popup-menu ada-context-menu)
- )
+ (popup-menu ada-context-menu)
+ )
(defun ada-indent-newline-indent ()
"insert a newline, indent the old and new lines."
(interactive "*")
;; point may be in the middle of a word, so insert newline first,
;; then go back and indent.
- (newline)
+ (insert "\n")
(forward-char -1)
(funcall indent-line-function)
(forward-char 1)
"return\\|"
"type\\|"
"when"
- "\\)\\>\\)"))
+ "\\)\\>[^_]\\)")) ;; in case "_" has punctuation syntax
"See the variable `align-region-separate' for more information.")
(defun ada-align ()
- "If region is active, apply 'align'. If not, attempt to align
+ "If region is active, apply `align'. If not, attempt to align
current construct."
(interactive)
(if (use-region-p)
(deactivate-mark))
;; else see if we are in a construct we know how to align
- (cond
- ((ada-in-paramlist-p)
+ (let ((parse-result (syntax-ppss)))
+ (cond
+ ((ada-in-paramlist-p parse-result)
(ada-format-paramlist))
- (t
- (align-current))
- )))
+ ((and
+ (ada-in-paren-p parse-result)
+ (ada-in-case-expression))
+ ;; align '=>'
+ (let ((begin (nth 1 parse-result))
+ (end (scan-lists (point) 1 1)))
+ (align begin end 'entire)))
+
+ (t
+ (align-current))
+ ))))
(defvar ada-in-paramlist-p nil
;; Supplied by indentation engine parser
"Function to return t if point is inside the parameter-list of a subprogram declaration.
-Function is called with no arguments.")
+Function is called with one optional argument; syntax-ppss result.")
-(defun ada-in-paramlist-p ()
+(defun ada-in-paramlist-p (&optional parse-result)
"Return t if point is inside the parameter-list of a subprogram declaration."
(when ada-in-paramlist-p
- (funcall ada-in-paramlist-p)))
+ (funcall ada-in-paramlist-p parse-result)))
(defun ada-format-paramlist ()
"Reformat the parameter list point is in."
(ada-goto-open-paren)
(funcall indent-line-function); so new list is indented properly
- (let* ((inhibit-modification-hooks t)
- (begin (point))
+ (let* ((begin (point))
(delend (progn (forward-sexp) (point))); just after matching closing paren
(end (progn (backward-char) (forward-comment (- (point))) (point))); end of last parameter-declaration
(multi-line (> end (save-excursion (goto-char begin) (line-end-position))))
"Function to scan a region, return a list of subprogram parameter declarations (in inverse declaration order).
Function is called with two args BEGIN END (the region).
Each parameter declaration is represented by a list
-'((identifier ...) aliased-p in-p out-p not-null-p access-p constant-p protected-p type default)."
+((identifier ...) aliased-p in-p out-p not-null-p access-p constant-p protected-p type default)."
;; Summary of Ada syntax for a parameter specification:
;; ... : [aliased] {[in] | out | in out | [null_exclusion] access [constant | protected]} ...
)
(defun ada-insert-paramlist-single-line (paramlist)
"Insert a single-line formatted PARAMLIST in the buffer."
+ ;; point is properly indented
(let ((i (length paramlist))
param)
;; clean up whitespace
- (skip-syntax-forward " ")
- (delete-char (- (skip-syntax-backward " ")))
- (insert " (")
+ (delete-char (- (skip-syntax-forward " ")))
+ (insert "(")
(setq i (length paramlist))
(while (not (zerop i))
(unless word
(if (use-region-p)
- (setq word (buffer-substring-no-properties (region-beginning) (region-end)))
+ (progn
+ (setq word (buffer-substring-no-properties (region-beginning) (region-end)))
+ (deactivate-mark))
(save-excursion
- (skip-syntax-backward "w_")
- (setq word
- (buffer-substring-no-properties
- (point)
- (progn (skip-syntax-forward "w_") (point))
- )))))
+ (let ((syntax (if partial "w" "w_")))
+ (skip-syntax-backward syntax)
+ (setq word
+ (buffer-substring-no-properties
+ (point)
+ (progn (skip-syntax-forward syntax) (point))
+ ))))))
(let* ((exceptions (ada-case-read-exceptions file-name))
(full-exceptions (car exceptions))
(interactive)
(ada-case-create-exception nil nil t))
-(defun ada-in-numeric-literal-p ()
- "Return t if point is after a prefix of a numeric literal."
- (looking-back "\\([0-9]+#[0-9a-fA-F_]+\\)"))
+(defun ada-in-based-numeric-literal-p ()
+ "Return t if point is after a prefix of a based numeric literal."
+ (looking-back "\\([0-9]+#[0-9a-fA-F_]+\\)" (line-beginning-position)))
(defvar ada-keywords nil
"List of Ada keywords for current `ada-language-version'.")
(point))))
(member (downcase word) ada-keywords)))
-(defun ada-mixed-case (start end)
+(defun ada-case-keyword (beg end)
+ (cl-ecase ada-case-keyword
+ (lower-case (downcase-region beg end))
+ (upper-case (upcase-region beg end))
+ ))
+
+(defun ada-case-identifier (start end force-case-strict)
+ (cl-ecase ada-case-identifier
+ (mixed-case (ada-mixed-case start end force-case-strict))
+ (lower-case (downcase-region start end))
+ (upper-case (upcase-region start end))
+ ))
+
+(defun ada-mixed-case (start end force-case-strict)
"Adjust case of region START END to Mixed_Case."
(let ((done nil)
next)
- (if ada-case-strict
+ (if (or force-case-strict ada-case-strict)
(downcase-region start end))
(goto-char start)
(while (not done)
(copy-marker (1+ end))))
;; upcase first char
- (insert-char (upcase (following-char)) 1)
- (delete-char 1)
+ (upcase-region (point) (1+ (point)))
(goto-char next)
(if (< (point) end)
(setq done t))
)))
-(defun ada-case-adjust-identifier ()
+(defun ada-case-adjust-identifier (&optional force-case)
"Adjust case of the previous word as an identifier.
Uses `ada-case-identifier', with exceptions defined in
`ada-case-full-exceptions', `ada-case-partial-exceptions'."
(delete-region (point) end))
;; else apply ada-case-identifier
- (funcall ada-case-identifier start end)
+ (ada-case-identifier start end force-case)
;; apply partial-exceptions
(goto-char start)
(if (< (point) end)
(setq start (point))
(setq done t))
- )))))
+ )))))
+
+(defun ada-case-adjust-keyword ()
+ "Adjust the case of the previous word as a keyword.
+`word' here is allowed to be underscore-separated (GPR external_as_list)."
+ (save-excursion
+ (let ((end (point-marker))
+ (start (progn (skip-syntax-backward "w_") (point))))
+ (ada-case-keyword start end)
+ )))
(defun ada-case-adjust (&optional typed-char in-comment)
"Adjust the case of the word before point.
When invoked interactively, TYPED-CHAR must be
`last-command-event', and it must not have been inserted yet.
-If IN-COMMENT is non-nil, adjust case of words in comments."
+If IN-COMMENT is non-nil, adjust case of words in comments and strings as code,
+and treat `ada-case-strict' as t in code.."
(when (not (bobp))
(when (save-excursion
(forward-char -1); back to last character in word
;; referenced in a comment, via
;; ada-case-adjust-at-point.
- (not (ada-in-numeric-literal-p))
+ (not (ada-in-based-numeric-literal-p))
+ ;; don't adjust case on hex digits
))
;; The indentation engine may trigger a reparse on
(save-excursion
(skip-syntax-backward "w_")
(eq (char-before) ?')))
- (ada-case-adjust-identifier))
+ (ada-case-adjust-identifier in-comment))
((and
(not in-comment)
(not (eq typed-char ?_))
(ada-after-keyword-p))
- (funcall ada-case-keyword -1))
+ (ada-case-adjust-keyword))
- (t (ada-case-adjust-identifier))
+ (t (ada-case-adjust-identifier in-comment))
))
)))
(defun ada-case-adjust-at-point (&optional in-comment)
"Adjust case of word at point, move to end of word.
-With prefix arg, adjust case even if in comment."
+With prefix arg, adjust case as code even if in comment;
+otherwise, capitalize words in comments."
(interactive "P")
- (when
- (and (not (eobp))
- ;; we use '(syntax-after (point))' here, not '(char-syntax
- ;; (char-after))', because the latter does not respect
- ;; ada-syntax-propertize.
- (memq (syntax-class (syntax-after (point))) '(2 3)))
- (skip-syntax-forward "w_"))
- (ada-case-adjust nil in-comment))
+ (cond
+ ((and (not in-comment)
+ (ada-in-string-or-comment-p))
+ (skip-syntax-backward "w_")
+ (capitalize-word 1))
+
+ (t
+ (when
+ (and (not (eobp))
+ ;; we use '(syntax-after (point))' here, not '(char-syntax
+ ;; (char-after))', because the latter does not respect
+ ;; ada-syntax-propertize.
+ (memq (syntax-class (syntax-after (point))) '(2 3)))
+ (skip-syntax-forward "w_"))
+ (ada-case-adjust nil in-comment))
+ ))
(defun ada-case-adjust-region (begin end)
"Adjust case of all words in region BEGIN END."
(plist-get prj prop)
;; no project, just use default vars
- ;; must match code in ada-prj-default
+ ;; must match code in ada-prj-default, except for src_dir.
(cl-case prop
(ada_compiler ada-compiler)
(auto_case ada-auto-case)
(list ada-case-exception-file)))
(path_sep path-separator)
(proc_env process-environment)
- (src_dir (list "."))
+ (src_dir (list (directory-file-name default-directory)))
(xref_tool ada-xref-tool)
))))
project properties list. Function should add to the properties
list and return it.")
-(defun ada-prj-default ()
+(defun ada-prj-default (&optional src-dir)
"Return the default project properties list.
+If SRC-DIR is non-nil, use it as the default for src_dir.
Include properties set via `ada-prj-default-compiler-alist',
`ada-prj-default-xref-alist'."
(list ada-case-exception-file))
'path_sep path-separator;; prj variable so users can override it for their compiler
'proc_env process-environment
- 'src_dir (list ".")
+ 'src_dir (if src-dir (list src-dir) nil)
'xref_tool ada-xref-tool
))
(defun ada-parse-prj-file (prj-file)
"Read Emacs Ada or compiler-specific project file PRJ-FILE, set project properties in `ada-prj-alist'."
;; Not called ada-prj-parse-file for Ada mode 4.01 compatibility
+ ;; FIXME: need to kill gpr-query session if .gpr file has changed (like from non-agg to agg!)
+ (run-hooks `ada-prj-parse-hook)
(let ((project (ada-prj-default))
(parser (cdr (assoc (file-name-extension prj-file) ada-prj-parser-alist))))
;; return 't', for decent display in message buffer when called interactively
t)
+(defun ada-create-select-default-prj (&optional directory)
+ "Create a default project with src_dir set to DIRECTORY (default current directory), select it."
+ (let* ((dir (or directory default-directory))
+ (prj-file (expand-file-name "default_.adp" dir))
+ (project (ada-prj-default dir)))
+
+ (if (assoc prj-file ada-prj-alist)
+ (setcdr (assoc prj-file ada-prj-alist) project)
+ (add-to-list 'ada-prj-alist (cons prj-file project)))
+
+ (ada-select-prj-file prj-file)
+ ))
+
(defun ada-prj-select ()
"Select the current project file from the list of currently available project files."
(interactive)
(interactive)
(message "current Emacs Ada mode project file: %s" ada-prj-current-file))
-(defvar ada-prj-show-path nil
+(defvar ada-prj-show-prj-path nil
;; Supplied by compiler
- "Function to show project search path used by compiler (and possibly xref tool)."
+ "Function to show project file search path used by compiler (and possibly xref tool)."
)
-(defun ada-prj-show-path ()
+(defun ada-prj-show-prj-path ()
+ (interactive)
+ (when ada-prj-show-prj-path
+ (funcall ada-prj-show-prj-path)))
+
+(defun ada-prj-show-src-path ()
+ "Show the project source file search path."
(interactive)
- (when ada-prj-show-path
- (funcall ada-prj-show-path)))
+ (if compilation-search-path
+ (progn
+ (pop-to-buffer (get-buffer-create "*Ada project source file search path*"))
+ (erase-buffer)
+ (dolist (file compilation-search-path)
+ (insert (format "%s\n" file))))
+ (message "no project source file search path set")
+ ))
(defvar ada-show-xref-tool-buffer nil
;; Supplied by xref tool
(modify-syntax-entry ?\" "\"" table)
;; punctuation; operators etc
- (modify-syntax-entry ?# "w" table); based number - word syntax, since we don't need the number
+ (modify-syntax-entry ?# "." table); based number - ada-wisi-number-literal-p requires this syntax
(modify-syntax-entry ?& "." table)
(modify-syntax-entry ?* "." table)
(modify-syntax-entry ?+ "." table)
ada-spec-suffixes)
(error "parent '%s' not found; set project file?" ff-function-name))))
-(defun ada-ff-special-extract-separate ()
- ;; match-string contains "separate (parent_name)"
- (let ((package-name (match-string 1)))
- (save-excursion
- (goto-char (match-end 0))
- (when (eolp) (forward-char 1))
- (skip-syntax-forward " ")
- (looking-at
- (concat "\\(function\\|package body\\|procedure\\|protected body\\|task body\\)\\s +"
- ada-name-regexp))
- (setq ff-function-name (match-string 0))
- )
- (file-name-nondirectory
- (or
- (ff-get-file-name
- compilation-search-path
- (ada-file-name-from-ada-name package-name)
- ada-body-suffixes)
- (error "package '%s' not found; set project file?" package-name)))))
-
(defun ada-ff-special-with ()
(let ((package-name (match-string 1)))
(setq ff-function-name (concat "^package\\s-+" package-name "\\([^_]\\|$\\)"))
ada-parent-name-regexp "\\(?:;\\|[ \t]+\\|$\\)")
'ada-ff-special-extract-parent)
- ;; A "separate" clause.
- (cons (concat "^separate[ \t\n]*(" ada-name-regexp ")")
- 'ada-ff-special-extract-separate)
-
;; A "with" clause. Note that it may refer to a procedure body, as well as a spec
(cons (concat "^\\(?:limited[ \t]+\\)?\\(?:private[ \t]+\\)?with[ \t]+" ada-name-regexp)
'ada-ff-special-with)
(when ada-on-context-clause
(funcall ada-on-context-clause)))
+(defvar ada-in-case-expression nil
+ ;; supplied by indentation engine
+ "Function called with no parameters; it should return non-nil
+ if point is in a case expression.")
+
+(defun ada-in-case-expression ()
+ "See `ada-in-case-expression' variable."
+ (interactive)
+ (when ada-in-case-expression
+ (funcall ada-in-case-expression)))
+
(defvar ada-goto-subunit-name nil
;; supplied by indentation engine
"Function called with no parameters; if the current buffer
(error "%s (opened) and %s (found in project) are two different files"
file-name found-file)))))
-(defun ada-find-other-file-noset (other-window)
- "Same as `ada-find-other-file', but preserve point in the other file,
-don't move to corresponding declaration."
- (interactive "P")
- (ada-find-other-file other-window t))
-
-(defun ada-find-other-file (other-window &optional no-set-point)
+(defun ada-find-other-file (other-window)
"Move to the corresponding declaration in another file.
- If region is active, assume it contains a package name;
subprogram declaration, position point on the corresponding
parent package specification.
-- If point is in the start line of a separate body,
- position point on the corresponding separate stub declaration.
-
- If point is in a context clause line, position point on the
first package declaration that is mentioned.
+- If point is in a separate body, position point on the
+ corresponding specification.
+
- If point is in a subprogram body or specification, position point
on the corresponding specification or body.
If OTHER-WINDOW (set by interactive prefix) is non-nil, show the
-buffer in another window.
-
-If NO-SET-POINT is nil, set point in the other file on the
-corresponding declaration. If non-nil, preserve existing point in
-the other file."
+buffer in another window."
;; ff-get-file, ff-find-other file first process
;; ff-special-constructs, then run the following hooks:
(interactive "P")
(ada-check-current-project (buffer-file-name))
+ ;; clear ff-function-name, so it either ff-special-constructs or
+ ;; ada-which-function will set it.
+ (setq ff-function-name nil)
+
(cond
(mark-active
(setq ff-function-name (buffer-substring-no-properties (point) (mark)))
(ff-find-other-file other-window)))
)
+(defun ada-find-file (filename)
+ ;; we assume compliation-search-path is set, either by an
+ ;; ada-mode project, or by some other means.
+ ;; FIXME: option to filter with ada-*-suffixes?
+ (interactive (list (completing-read "File: "
+ (apply-partially
+ 'locate-file-completion-table
+ compilation-search-path nil))))
+ (find-file (locate-file filename compilation-search-path))
+ )
+
(defvar ada-operator-re
"\\+\\|-\\|/\\|\\*\\*\\|\\*\\|=\\|&\\|abs\\|mod\\|rem\\|and\\|not\\|or\\|xor\\|<=\\|<\\|>=\\|>"
"Regexp matching Ada operator_symbol.")
(when (ada-in-comment-p)
(error "Inside comment"))
- (let (identifier)
-
- (skip-chars-backward "a-zA-Z0-9_<>=+\\-\\*/&")
+ (skip-chars-backward "a-zA-Z0-9_<>=+\\-\\*/&")
- ;; Just in front of, or inside, a string => we could have an
- ;; operator function declaration.
+ ;; Just in front of, or inside, a string => we could have an
+ ;; operator function declaration.
+ (cond
+ ((ada-in-string-p)
(cond
- ((ada-in-string-p)
- (cond
- ((and (= (char-before) ?\")
- (progn
- (forward-char -1)
- (looking-at (concat "\"\\(" ada-operator-re "\\)\""))))
- (setq identifier (concat "\"" (match-string-no-properties 1) "\"")))
+ ((and (= (char-before) ?\")
+ (progn
+ (forward-char -1)
+ (looking-at (concat "\"\\(" ada-operator-re "\\)\""))))
+ (concat "\"" (match-string-no-properties 1) "\""))
- (t
- (error "Inside string or character constant"))
- ))
+ (t
+ (error "Inside string or character constant"))
+ ))
- ((and (= (char-after) ?\")
- (looking-at (concat "\"\\(" ada-operator-re "\\)\"")))
- (setq identifier (concat "\"" (match-string-no-properties 1) "\"")))
+ ((and (= (char-after) ?\")
+ (looking-at (concat "\"\\(" ada-operator-re "\\)\"")))
+ (concat "\"" (match-string-no-properties 1) "\""))
- ((looking-at "[a-zA-Z0-9_]+\\|[+\\-*/&=<>]")
- (setq identifier (match-string-no-properties 0)))
+ ((looking-at "[a-zA-Z0-9_]+\\|[+\\-*/&=<>]")
+ (match-string-no-properties 0))
- (t
- (error "No identifier around"))
- )))
+ (t
+ (error "No identifier around"))
+ ))
+;; FIXME (for emacs 25): use find-tag-marker-ring, ring-insert, pop-tag-mark (see xref.el)
(defvar ada-goto-pos-ring '()
"List of positions selected by navigation functions. Used
to go back to these positions.")
(defun ada-goto-source (file line column other-window)
"Find and select FILE, at LINE and COLUMN.
FILE may be absolute, or on `compilation-search-path'.
+LINE, COLUMN are Emacs origin.
If OTHER-WINDOW is non-nil, show the buffer in another window."
(let ((file-1
- filename containing the identifier (full path)
- line number containing the identifier
- column of the start of the identifier
-Returns a list '(file line column) giving the corresponding location.
-'file' may be absolute, or on `compilation-search-path'. If point is
+Returns a list (FILE LINE COLUMN) giving the corresponding location.
+FILE may be absolute, or on `compilation-search-path'. If point is
at the specification, the corresponding location is the body, and vice
versa.")
- filename containing the identifier
- line number containing the identifier
- column of the start of the identifier
-Returns a list '(file line column) giving the corresponding location.
-'file' may be absolute, or on `compilation-search-path'.")
+Returns a list (FILE LINE COLUMN) giving the corresponding location.
+FILE may be absolute, or on `compilation-search-path'.")
(defun ada-show-overridden (other-window)
"Show the overridden declaration of identifier at point."
;; Supplied by indentation engine
"Function called with no parameters; it should move forward to
the next keyword in the statement following the one point is
-in (ie from 'if' to 'then'). If not in a keyword, move forward
-to the next keyword in the current statement. If at the last keyword,
-move forward to the first keyword in the next statement or next
-keyword in the containing statement.")
+in (ie from `if' to `then'). If not in a keyword, move forward to
+the next keyword in the current statement. If at the last
+keyword, move forward to the first keyword in the next statement
+or next keyword in the containing statement.")
(defvar ada-goto-end nil
;; Supplied by indentation engine
(defun ada-next-statement-keyword ()
;; Supplied by indentation engine
- "See `ada-next-statement-keyword' variable."
+ "See `ada-next-statement-keyword' variable. In addition,
+if on open parenthesis move to matching closing parenthesis."
(interactive)
- (when ada-next-statement-keyword
- (funcall ada-next-statement-keyword)))
+ (if (= (syntax-class (syntax-after (point))) 4)
+ ;; on open paren
+ (forward-sexp)
+
+ ;; else move by keyword
+ (when ada-next-statement-keyword
+ (unless (region-active-p)
+ (push-mark))
+ (funcall ada-next-statement-keyword))))
(defvar ada-prev-statement-keyword nil
;; Supplied by indentation engine
"Function called with no parameters; it should move to the previous
keyword in the statement following the one point is in (ie from
-'then' to 'if'). If at the first keyword, move to the previous
+`then' to `if'). If at the first keyword, move to the previous
keyword in the previous statement or containing statement.")
(defun ada-prev-statement-keyword ()
- "See `ada-prev-statement-keyword' variable."
+ "See `ada-prev-statement-keyword' variable. In addition,
+if on close parenthesis move to matching open parenthesis."
(interactive)
- (when ada-prev-statement-keyword
- (funcall ada-prev-statement-keyword)))
+ (if (= (syntax-class (syntax-after (1- (point)))) 5)
+ ;; on close paren
+ (backward-sexp)
+
+ ;; else move by keyword
+ (when ada-prev-statement-keyword
+ (unless (region-active-p)
+ (push-mark))
+ (funcall ada-prev-statement-keyword))))
;;;; code creation
(defun ada-ff-create-body ()
;; no error if not set; let ada-skel do its thing.
(when ada-make-package-body
- ;; ff-find-other-file calls us with point in an empty buffer for the
- ;; body file; ada-make-package-body expects to be in the spec. So go
- ;; back.
- (let ((body-file-name (buffer-file-name)))
- (ff-find-the-other-file)
+ ;; ff-find-other-file calls us with point in an empty buffer for
+ ;; the body file; ada-make-package-body expects to be in the
+ ;; spec. So go back to the spec, and delete the body buffer so it
+ ;; does not get written to disk.
+ (let ((body-buffer (current-buffer))
+ (body-file-name (buffer-file-name)))
+
+ (set-buffer-modified-p nil);; may have a skeleton; allow silent delete
+
+ (ff-find-the-other-file);; back to spec
+
+ (kill-buffer body-buffer)
(ada-make-package-body body-file-name)
- ;; FIXME (later): if 'ada-make-package-body' fails, delete the body buffer
- ;; so it doesn't get written to disk, and we can try again.
- ;; back to the body, read in from the disk.
+ ;; back to the new body file, read in from the disk.
(ff-find-the-other-file)
(revert-buffer t t))
))
to each line filled and justified.
The paragraph is indented on the first line."
(interactive "P")
- (if (and (not (ada-in-comment-p))
- (not (looking-at "[ \t]*--")))
+ (if (not (or (ada-in-comment-p)
+ (looking-at "[ \t]*--")))
(error "Not inside comment"))
- (let* ((inhibit-modification-hooks t) ;; don't run parser for font-lock; comment text is exposed
+ ;; fill-region-as-paragraph leaves comment text exposed (without
+ ;; comment prefix) when inserting a newline; don't trigger a parse
+ ;; because of that (in particular, jit-lock requires a parse; other
+ ;; hooks may as well). In general, we don't need to trigger a parse
+ ;; for comment changes.
+ ;;
+ ;; FIXME: add ada-inibit-parse instead; let other change hooks run.
+ ;; FIXME: wisi-after-change still needs to adjust wisi-cache-max
+ ;; FIXME: even better, consider patch suggested by Stefan Monnier to
+ ;; move almost all code out of the change hooks (see email).
+ (let* ((inhibit-modification-hooks t)
indent from to
(opos (point-marker))
;; we bind `fill-prefix' here rather than in ada-mode because
(fill-prefix ada-fill-comment-prefix)
(fill-column (current-fill-column)))
+ ;; We should run before-change-functions here, but we don't know from/to yet.
+
;; Find end of comment paragraph
(back-to-indentation)
(while (and (not (eobp)) (looking-at ".*--[ \t]*[^ \t\n]"))
(forward-line))
))
- (goto-char opos)))
+ (goto-char opos)
+
+ ;; we disabled modification hooks, so font-lock will not run to
+ ;; re-fontify the comment prefix; do that here.
+ ;; FIXME: Use actual original size instead of 0!
+ (run-hook-with-args 'after-change-functions from to 0)))
;;;; support for font-lock.el
-;; casing keywords defined here to keep the two lists together
(defconst ada-83-keywords
'("abort" "abs" "accept" "access" "all" "and" "array" "at" "begin"
"body" "case" "constant" "declare" "delay" "delta" "digits" "do"
(defun ada-font-lock-keywords ()
"Return Ada mode value for `font-lock-keywords', depending on `ada-language-version'."
+ ;; Grammar actions set `font-lock-face' property for all
+ ;; non-keyword tokens that need it.
(list
-
- ;; keywords followed by a name that should be in function-name-face.
- (list
- (apply
- 'concat
- (append
- '("\\<\\("
- "accept\\|"
- "entry\\|"
- "function\\|"
- "package[ \t]+body\\|"
- "package\\|"
- "pragma\\|"
- "procedure\\|"
- "task[ \t]+body\\|"
- "task[ \t]+type\\|"
- "task\\|"
- )
- (when (member ada-language-version '(ada95 ada2005 ada2012))
- '("\\|"
- "protected[ \t]+body\\|"
- "protected[ \t]+function\\|"
- "protected[ \t]+procedure\\|"
- "protected[ \t]+type\\|"
- "protected"
- ))
- (list
- "\\)\\>[ \t]*"
- ada-name-regexp "?")))
- '(1 font-lock-keyword-face) '(2 font-lock-function-name-face nil t))
-
- ;; keywords followed by a name that should be in type-face.
- (list (concat
- "\\<\\("
- "access[ \t]+all\\|"
- "access[ \t]+constant\\|"
- "access\\|"
- "constant\\|"
- "in[ \t]+reverse\\|"; loop iterator
- "in[ \t]+not[ \t]+null[ \t]+access\\|"
- "in[ \t]+not[ \t]+null\\|"
- "in[ \t]+out[ \t]+not[ \t]+null[ \t]+access\\|"
- "in[ \t]+out[ \t]+not[ \t]+null\\|"
- "in[ \t]+out\\|"
- "in\\|"
- ;; "return" can't distinguish between 'function ... return <type>;' and 'return ...;'
- ;; "new" can't distinguish between generic instantiation
- ;; package foo is new bar (...)
- ;; and allocation
- ;; a := new baz (...)
- ;; A parsing indentation engine can, so rules for these are added there
- "not[ \t]+null[ \t]access[ \t]all\\|"
- "not[ \t]+null[ \t]access[ \t]constant\\|"
- "not[ \t]+null[ \t]access\\|"
- "not[ \t]+null\\|"
- ;; "of" can't distinguish between array and iterable_name
- "out\\|"
- "subtype\\|"
- "type"
- "\\)\\>[ \t]*"
- ada-name-regexp "?")
- '(1 font-lock-keyword-face nil t) '(2 font-lock-type-face nil t))
-
- ;; Keywords not treated elsewhere. After above so it doesn't
- ;; override fontication of second or third word in those patterns.
- (list (concat
- "\\<"
- (regexp-opt
- (append
- '("abort" "abs" "accept" "all"
- ;; "and" requires parser for types in interface_lists
- "array" "at" "begin" "case" "declare" "delay" "delta"
- "digits" "do" "else" "elsif" "entry" "exception" "exit" "for"
- "generic" "if" "in" "limited" "loop" "mod" "not"
- "null" "or" "others" "private" "raise"
- "range" "record" "rem" "reverse"
- "select" "separate" "task" "terminate"
- "then" "when" "while" "xor")
- (when (member ada-language-version '(ada95 ada2005 ada2012))
- ;; "aliased" can't distinguish between object declaration and paramlist
- '("abstract" "requeue" "tagged" "until"))
- (when (member ada-language-version '(ada2005 ada2012))
- '("interface" "overriding" "synchronized"))
- (when (member ada-language-version '(ada2012))
- '("some"))
- )
- t)
- "\\>")
- '(0 font-lock-keyword-face))
-
- ;; after the above to handle 'is begin' in blocks
- (list (concat
- "\\<\\(is\\)\\>[ \t]*"
- ada-name-regexp "?")
- '(1 font-lock-keyword-face) '(2 font-lock-type-face nil t))
-
- ;; object and parameter declarations; word after ":" should be in
- ;; type-face if not already fontified or an exception.
- (list (concat
- ":[ \t]*"
- ada-name-regexp
- "[ \t]*\\(=>\\)?")
- '(1 (if (match-beginning 2)
- 'default
- font-lock-type-face)
- nil t))
-
- ;; keywords followed by a name that should be in function-name-face if not already fontified
- (list (concat
- "\\<\\(end\\)\\>[ \t]*"
- ada-name-regexp "?")
- '(1 font-lock-keyword-face) '(2 font-lock-function-name-face nil t))
-
- ;; Keywords followed by a comma separated list of names which
- ;; should be in constant-face, unless already fontified. Ada mode 4.01 used this.
- (list (concat
- "\\<\\("
- "goto\\|"
- "use\\|"
- ;; don't need "limited" "private" here; they are matched separately
- "with"; context clause
- "\\)\\>[ \t]*"
- "\\(\\(?:\\sw\\|[_., \t]\\)+\\>\\)?"; ada-name-regexp, plus ", \t"
- )
- '(1 font-lock-keyword-face) '(2 font-lock-constant-face nil t))
-
- ;; statement labels
- '("<<\\(\\sw+\\)>>" 1 font-lock-constant-face)
-
- ;; based numberic literals
- (list "\\([0-9]+#[0-9a-fA-F_]+#\\)" '(1 font-lock-constant-face t))
-
- ;; numeric literals
- (list "\\W\\([-+]?[0-9._]+\\)\\>" '(1 font-lock-constant-face))
-
+ (list (concat "\\<" (regexp-opt ada-keywords t) "\\>") '(0 font-lock-keyword-face))
))
;;;; ada-mode
(setq local-abbrev-table ada-mode-abbrev-table)
(set (make-local-variable 'syntax-propertize-function) 'ada-syntax-propertize)
- (set (make-local-variable 'syntax-begin-function) nil)
+ (when (boundp 'syntax-begin-function)
+ ;; obsolete in emacs-25.1
+ (set (make-local-variable 'syntax-begin-function) nil))
(set (make-local-variable 'parse-sexp-ignore-comments) t)
(set (make-local-variable 'parse-sexp-lookup-properties) t)
(set 'case-fold-search t); Ada is case insensitive; the syntax parsing requires this setting
;; This means to fully set ada-mode interactively, user must
;; do M-x ada-mode M-; (hack-local-variables)
- (when global-font-lock-mode
- ;; This calls ada-font-lock-keywords, which depends on
- ;; ada-language-version
- (font-lock-refresh-defaults))
+ ;; fill-region-as-paragraph in ada-fill-comment-paragraph does not
+ ;; call syntax-propertize, so set comment syntax on
+ ;; ada-fill-comment-prefix. In post-local because user may want to
+ ;; set it per-file.
+ (put-text-property 0 2 'syntax-table '(11 . nil) ada-fill-comment-prefix)
(cl-case ada-language-version
(ada83
ada-2005-keywords
ada-2012-keywords))))
+ (when global-font-lock-mode
+ ;; This calls ada-font-lock-keywords, which depends on
+ ;; ada-keywords
+ (font-lock-refresh-defaults))
+
(when ada-goto-declaration-start
(set (make-local-variable 'beginning-of-defun-function) ada-goto-declaration-start))
(unless (featurep 'ada-xref-tool)
(cl-case ada-xref-tool
((nil gnat) (require 'ada-gnat-xref))
- (gnat_inspect (require 'gnat-inspect))
(gpr_query (require 'gpr-query))
))