-;;; 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 - 2013 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 1995, 1997 - 2015 Free Software Foundation, Inc.
;;
;; Author: Stephen Leake <stephen_leake@member.fsf.org>
;; Maintainer: Stephen Leake <stephen_leake@member.fsf.org>
-;; Keywords FIXME: languages, ada ELPA broken for multiple keywords
-;; Version: 5.0
-;; package-requires: ((wisi "1.0"))
+;; Keywords: languages
+;; ada
+;; Version: 5.1.8
+;; package-requires: ((wisi "1.1.1") (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)
;;
;; alist entries are set during load by the implementation elisp files.
;;
-;; `ada-prj-parse-file-ext' uses this style.
+;; `ada-prj-default-compiler-alist' uses this style.
;;; History:
;;
;; robin-reply@reagans.org
;; and others for their valuable hints.
-(require 'find-file)
(require 'align)
-(require 'which-func)
+(require 'cl-lib)
(require 'compile)
-
-(eval-when-compile (require 'cl-macs))
+(require 'find-file)
(defun ada-mode-version ()
"Return Ada mode version."
(interactive)
- (let ((version-string "5.0"))
+ (let ((version-string "5.1.8"))
;; must match:
;; ada-mode.texi
- ;; README
- ;; gpr-mode.el
+ ;; 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
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 ;FIXME: is '("~/.emacs" "~/.bashrc" "/etc/passwd") safe?
+ )
(defcustom ada-case-keyword 'downcase-word
"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 an Ada keywords."
+Function to call to adjust the case of Ada keywords."
:type '(choice (const downcase-word)
(const upcase-word))
- :group 'ada
- :safe 'functionp)
+ ;; :safe #'functionp ; FIXME: `functionp' CANNOT be safe!
+ )
(make-variable-buffer-local 'ada-case-keyword)
+(defcustom ada-case-identifier 'ada-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.
+Called with three args;
+start - buffer pos of start of identifier
+end - end of identifier
+force-case - if t, treat `ada-strict-case' as t"
+ :type '(choice (const ada-mixed-case)
+ (const ada-lower-case)
+ (const ada-upper-case))
+ ;; :safe #'functionp ; FIXME: `functionp' CANNOT be safe!
+ )
+;; 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
"Buffer-local value that may override project variable `case_strict'.
Global value is default for project variable `case_strict'.
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
- "Ada language version; one of `ada83', `ada95', `ada2005'.
-Only affects the keywords to highlight."
+ "Ada language version; one of `ada83', `ada95', `ada2005', `ada2012'.
+Only affects the keywords to highlight, not which version the
+indentation parser accepts."
:type '(choice (const ada83)
(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)
(defcustom ada-fill-comment-postfix " --"
"Comment fill postfix."
- :type 'string
- :group 'ada)
+ :type 'string)
(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
- :group 'ada)
+ :type 'list)
;;;;; end of user variables
;;;; keymap and menus
+(defvar ada-ret-binding 'ada-indent-newline-indent)
+(defvar ada-lfd-binding 'newline-and-indent)
+
+(defun ada-case-activate-keys (map)
+ "Modify the key bindings for all the keys that should adjust casing."
+ ;; we could just put these in the keymap below, but this is easier.
+ (mapc (function
+ (lambda(key)
+ (define-key
+ map
+ (char-to-string key)
+ 'ada-case-adjust-interactive)))
+ '( ?_ ?% ?& ?* ?( ?) ?- ?= ?+
+ ?| ?\; ?: ?' ?\" ?< ?, ?. ?> ?/ ?\n 32 ?\r ))
+ )
+
(defvar ada-mode-map
(let ((map (make-sparse-keymap)))
;; C-c <letter> are reserved for users
;; global-map has C-x ` 'next-error
- (define-key map [return] 'ada-indent-newline-indent)
+ (define-key map [return] 'ada-case-adjust-interactive)
(define-key map "\C-c`" 'ada-show-secondary-error)
+ (define-key map "\C-c;" (lambda () (error "use M-; instead"))) ; comment-dwim
+ (define-key map "\C-c<" 'ada-goto-declaration-start)
+ (define-key map "\C-c>" 'ada-goto-declaration-end)
(define-key map "\C-c\M-`" 'ada-fix-compiler-error)
(define-key map "\C-c\C-a" 'ada-align)
(define-key map "\C-c\C-b" 'ada-make-subprogram-body)
(define-key map "\C-c\C-i" 'ada-indent-statement)
(define-key map "\C-c\C-m" 'ada-build-set-make)
(define-key map "\C-c\C-n" 'ada-next-statement-keyword)
+ (define-key map "\C-c\M-n" 'ada-next-placeholder)
(define-key map "\C-c\C-o" 'ada-find-other-file)
(define-key map "\C-c\M-o" 'ada-find-other-file-noset)
(define-key map "\C-c\C-p" 'ada-prev-statement-keyword)
+ (define-key map "\C-c\M-p" 'ada-prev-placeholder)
(define-key map "\C-c\C-q" 'ada-xref-refresh)
(define-key map "\C-c\C-r" 'ada-show-references)
(define-key map "\C-c\M-r" 'ada-build-run)
+ (define-key map "\C-c\C-s" 'ada-goto-previous-pos)
(define-key map "\C-c\C-v" 'ada-build-check)
(define-key map "\C-c\C-w" 'ada-case-adjust-at-point)
(define-key map "\C-c\C-x" 'ada-show-overriding)
(define-key map "\C-c\M-y" 'ada-case-create-partial-exception)
(define-key map [C-down-mouse-3] 'ada-popup-menu)
+ (ada-case-activate-keys map)
+
map
) "Local keymap used for Ada mode.")
["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]
)
("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 prev statement keyword" ada-next-statement-keyword t]
+ ["Goto declaration start" ada-goto-declaration-start t]
+ ["Goto declaration end" ada-goto-declaration-end t]
["Show parent declarations" ada-show-declaration-parents t]
["Show references" ada-show-references t]
["Show overriding" ada-show-overriding t]
["Show overridden" ada-show-overridden t]
+ ["Goto prev position" ada-goto-previous-pos t]
+ ["Next placeholder" ada-next-placeholder t]
+ ["Previous placeholder" ada-prev-placeholder t]
)
("Edit"
["Expand skeleton" ada-expand t]
- ["Indent line" indent-for-tab-command t]
+ ["Indent line or selection" indent-for-tab-command t]
["Indent current statement" ada-indent-statement t]
["Indent lines in file" (indent-region (point-min) (point-max)) t]
["Align" ada-align t]
- ["Comment selection" comment-region t]
- ["Uncomment selection" (comment-region t) t]
+ ["Comment/uncomment selection" comment-dwim t]
["Fill comment paragraph" ada-fill-comment-paragraph t]
["Fill comment paragraph justify" (ada-fill-comment-paragraph 'full) t]
["Fill comment paragraph postfix" (ada-fill-comment-paragraph 'full t) t]
["Adjust case at point" ada-case-adjust-at-point t]
["Adjust case region" ada-case-adjust-region t]
["Adjust case buffer" ada-case-adjust-buffer t]
+ ["Show casing files list" ada-case-show-files t]
)
("Misc"
["Show last parse error" ada-show-parse-error t]
+ ["Show xref tool buffer" ada-show-xref-tool-buffer t]
["Refresh cross reference cache" ada-xref-refresh t]
+ ["Reset parser" ada-reset-parser t]
)))
;; This doesn't need to be buffer-local because there can be only one
(easy-menu-define ada-context-menu nil
"Context menu keymap for Ada mode"
'("Ada"
- ["Make body for subprogram" ada-make-subprogram-body t] ;; FIXME: include only if will succeed
+ ["Make body for subprogram" ada-make-subprogram-body t]
["Goto declaration/body" ada-goto-declaration :included ada-context-menu-on-identifier]
["Show parent declarations" ada-show-declaration-parents :included ada-context-menu-on-identifier]
["Show references" ada-show-references :included ada-context-menu-on-identifier]
["Show overriding" ada-show-overriding :included ada-context-menu-on-identifier]
["Show overridden" ada-show-overridden :included ada-context-menu-on-identifier]
- ["Expand skeleton" ada-expand t] ;; FIXME: only if skeleton
+ ["Expand skeleton" ada-expand t]
["Create full case exception" ada-case-create-exception t]
["Create partial case exception" ada-case-create-partial-exception t]
["Other File" ada-find-other-file t]
["Other file don't find decl" ada-find-other-file-noset t]))
-(defun ada-popup-menu (position)
+(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
(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)
(when ada-expand
(funcall ada-expand)))
+(defvar ada-next-placeholder nil
+ ;; skeleton function
+ "Function to call to goto next placeholder.")
+
+(defun ada-next-placeholder ()
+ "Goto next placeholder.
+Placeholders are defined by the skeleton backend."
+ (interactive)
+ (when ada-next-placeholder
+ (funcall ada-next-placeholder)))
+
+(defvar ada-prev-placeholder nil
+ ;; skeleton function
+ "Function to call to goto previous placeholder.")
+
+(defun ada-prev-placeholder ()
+ "Goto previous placeholder.
+Placeholders are defined by the skeleton backend."
+ (interactive)
+ (when ada-prev-placeholder
+ (funcall ada-prev-placeholder)))
+
;;;; abbrev, align
(defvar ada-mode-abbrev-table nil
(modes . '(ada-mode)))
(ada-comment
(regexp . "\\(\\s-*\\)--")
+ (valid . (lambda () (ada-align-valid)))
(modes . '(ada-mode)))
(ada-use
(regexp . "\\(\\s-*\\)\\<\\(use\\s-\\)")
(defun ada-align-valid ()
"See use in `ada-align-rules'."
(save-excursion
- ;; we don't put "when (match-beginning 2)" here; missing a match
+ ;; we don't put "when (match-beginning n)" here; missing a match
;; is a bug in the regexp.
- (goto-char (match-beginning 2))
+ (goto-char (or (match-beginning 2) (match-beginning 1)))
(not (ada-in-string-or-comment-p))))
(defconst ada-align-region-separate
"return\\|"
"type\\|"
"when"
- "\\)\\>\\)"))
+ "\\)\\>[^_]\\)")) ;; in case "_" has punctuation syntax
"See the variable `align-region-separate' for more information.")
(defun ada-align ()
(ada-goto-open-paren)
(funcall indent-line-function); so new list is indented properly
- (let* ((inibit-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 ...) in-p out-p not-null-p access-p constant-p protected-p type default)."
- ;; mode is 'in | out | in out | [not null] access [constant | protected]'
- ;; IMPROVEME: handle single-line trailing comments, or longer comments, in paramlist?
+'((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-scan-paramlist (begin end)
len
(ident-len 0)
(type-len 0)
+ (aliased-p nil)
(in-p nil)
(out-p nil)
(not-null-p nil)
(access-p nil)
ident-col
colon-col
+ in-col
out-col
type-col
default-col)
;; we align the defaults after the types that have defaults, not after all types.
;; "constant", "protected" are treated as part of 'type'
- (when (nth 8 param)
+ (when (nth 9 param)
(setq type-len
(max type-len
- (+ (length (nth 7 param))
- (if (nth 5 param) 10 0); "constant "
- (if (nth 6 param) 10 0); protected
+ (+ (length (nth 8 param))
+ (if (nth 6 param) 10 0); "constant "
+ (if (nth 7 param) 10 0); protected
))))
- (setq in-p (or in-p (nth 1 param)))
- (setq out-p (or out-p (nth 2 param)))
- (setq not-null-p (or not-null-p (nth 3 param)))
- (setq access-p (or access-p (nth 4 param)))
+ (setq aliased-p (or aliased-p (nth 1 param)))
+ (setq in-p (or in-p (nth 2 param)))
+ (setq out-p (or out-p (nth 3 param)))
+ (setq not-null-p (or not-null-p (nth 4 param)))
+ (setq access-p (or access-p (nth 5 param)))
)
- (unless (save-excursion (skip-chars-backward " \t") (bolp))
- ;; paramlist starts on same line as subprogram identifier; clean up whitespace
- (end-of-line)
- (delete-char (- (skip-syntax-backward " ")))
- (insert " "))
+ (let ((space-before-p (save-excursion (skip-chars-backward " \t") (not (bolp))))
+ (space-after-p (save-excursion (skip-chars-forward " \t") (not (or (= (char-after) ?\;) (eolp))))))
+ (when space-before-p
+ ;; paramlist starts on same line as subprogram identifier; clean
+ ;; up whitespace. Allow for code on same line as closing paren
+ ;; ('return' or ';').
+ (skip-syntax-forward " ")
+ (delete-char (- (skip-syntax-backward " ")))
+ (if space-after-p
+ (progn
+ (insert " ")
+ (forward-char -1))
+ (insert " "))
+ ))
(insert "(")
;; compute columns.
(setq ident-col (current-column))
(setq colon-col (+ ident-col ident-len 1))
- (setq out-col (+ colon-col (if in-p 5 0))); ": in "
+ (setq in-col
+ (+ colon-col (if aliased-p 10 2))); ": aliased ..."
+ (setq out-col (+ in-col (if in-p 3 0))); ": [aliased] in "
(setq type-col
- (+ colon-col
+ (+ in-col
(cond
- (not-null-p 18); ": not null access "
- (access-p 9); ": access"
- ((and in-p out-p) 9); ": in out "
- (out-p 6); ": out "
- (in-p 5); ": in "
- (t 2)))); ": "
+ ;; 'not null' without access is part of the type
+ ((and not-null-p access-p) 16); ": [aliased] not null access "
+ (access-p 7); ": [aliased] access "
+ ((and in-p out-p) 7); ": [aliased] in out "
+ (in-p 3); ": [aliased] in "
+ (out-p 4); ": [aliased] out "
+ (t 0)))); ": [aliased] "
(setq default-col (+ 1 type-col type-len))
(insert ": ")
(when (nth 1 param)
- (insert "in "))
+ (insert "aliased "))
+ (indent-to in-col)
(when (nth 2 param)
+ (insert "in "))
+
+ (when (nth 3 param)
(indent-to out-col)
(insert "out "))
- (when (nth 3 param)
- (insert "not null "))
+ (when (and (nth 4 param) ;; not null
+ (nth 5 param)) ;; access
+ (insert "not null access"))
- (when (nth 4 param)
- (insert "access "))
+ (when (and (not (nth 4 param)) ;; not null
+ (nth 5 param)) ;; access
+ (insert "access"))
(indent-to type-col)
- (when (nth 5 param)
- (insert "constant "))
+
+ (when (and (nth 4 param) ;; not null
+ (not (nth 5 param))) ;; access
+ (insert "not null "))
+
(when (nth 6 param)
+ (insert "constant "))
+
+ (when (nth 7 param)
(insert "protected "))
- (insert (nth 7 param)); type
- (when (nth 8 param); default
+ (insert (nth 8 param)); type
+
+ (when (nth 9 param); default
(indent-to default-col)
(insert ":= ")
- (insert (nth 8 param)))
+ (insert (nth 9 param)))
(if (zerop i)
(insert ")")
(insert " : ")
(when (nth 1 param)
- (insert "in "))
+ (insert "aliased "))
(when (nth 2 param)
- (insert "out "))
+ (insert "in "))
(when (nth 3 param)
- (insert "not null "))
+ (insert "out "))
(when (nth 4 param)
- (insert "access "))
+ (insert "not null "))
(when (nth 5 param)
- (insert "constant "))
+ (insert "access "))
+
(when (nth 6 param)
+ (insert "constant "))
+ (when (nth 7 param)
(insert "protected "))
- (insert (nth 7 param)); type
+ (insert (nth 8 param)); type
- (when (nth 8 param); default
+ (when (nth 9 param); default
(insert " := ")
- (insert (nth 8 param)))
+ (insert (nth 9 param)))
(if (zerop i)
(if (= (char-after) ?\;)
)
))
+(defvar ada-reset-parser nil
+ ;; Supplied by indentation engine parser
+ "Function to reset parser, to clear confused state."
+ )
+
+(defun ada-reset-parser ()
+ (interactive)
+ (when ada-reset-parser
+ (funcall ada-reset-parser)))
+
(defvar ada-show-parse-error nil
;; Supplied by indentation engine parser
"Function to show last error reported by indentation parser."
(defvar ada-case-full-exceptions '()
"Alist of words (entities) that have special casing, built from
-`ada-case-exception-file' full word exceptions. Indexed by
+project file casing file list full word exceptions. Indexed by
properly cased word; value is t.")
(defvar ada-case-partial-exceptions '()
"Alist of partial words that have special casing, built from
-`ada-case-exception-file' partial word exceptions. Indexed by
+project casing files list partial word exceptions. Indexed by
properly cased word; value is t.")
+(defun ada-case-show-files ()
+ "Show current casing files list."
+ (interactive)
+ (if (ada-prj-get 'casing)
+ (progn
+ (pop-to-buffer (get-buffer-create "*casing files*"))
+ (erase-buffer)
+ (dolist (file (ada-prj-get 'casing))
+ (insert (format "%s\n" file))))
+ (message "no casing files")
+ ))
+
(defun ada-case-save-exceptions (full-exceptions partial-exceptions file-name)
"Save FULL-EXCEPTIONS, PARTIAL-EXCEPTIONS to the file FILE-NAME."
(with-temp-file (expand-file-name file-name)
(progn
(setq word (substring word 1))
(unless (assoc-string word partial-exceptions t)
- (add-to-list 'partial-exceptions (cons word t))))
+ (push (cons word t) partial-exceptions)))
;; full word exception
(unless (assoc-string word full-exceptions t)
- (add-to-list 'full-exceptions (cons word t))))
+ (push (cons word t) full-exceptions)))
(forward-line 1))
)
(cons full-exceptions partial-exceptions))
;; else file not readable; might be a new project with no
- ;; exceptions yet, so just warn user, return empty pair
+ ;; exceptions yet, so just return empty pair
(message "'%s' is not a readable file." file-name)
'(nil . nil)
))
An item in both lists has the RESULT value."
(dolist (item new)
(unless (assoc-string (car item) result t)
- (add-to-list 'result item)))
+ (push item result)))
result)
(defun ada-case-merge-all-exceptions (exceptions)
(setq ada-case-partial-exceptions (ada-case-merge-exceptions ada-case-partial-exceptions (cdr exceptions))))
(defun ada-case-read-all-exceptions ()
- "Read case exceptions from all files in `ada-case-exception-file',
+ "Read case exceptions from all files in project casing files,
replacing current values of `ada-case-full-exceptions', `ada-case-partial-exceptions'."
(interactive)
(setq ada-case-full-exceptions '()
"Add case exception WORD to EXCEPTIONS, replacing current entry, if any."
(if (assoc-string word exceptions t)
(setcar (assoc-string word exceptions t) word)
- (add-to-list 'exceptions (cons word t)))
+ (push (cons word t) exceptions))
exceptions)
+(defvar ada-prj-current-file)
+
(defun ada-case-create-exception (&optional word file-name partial)
"Define WORD as an exception for the casing system, save it in FILE-NAME.
If PARTIAL is non-nil, create a partial word exception. WORD
(car casing))
(t
- (error
- "No exception file specified. See variable `ada-case-exception-file'")))
- ))
+ (if ada-prj-current-file
+ (error "No exception file specified; set `casing' in project file.")
+ ;; IMPROVEME: could prompt, but then need to write to actual project file
+ ;; (let ((temp
+ ;; (read-file-name
+ ;; "No exception file specified; adding to project. file: ")))
+ ;; (message "remember to add %s to project file" temp)
+ ;; (ada-prj-put 'casing temp)
+ ;; temp)
+ (error "No exception file specified, and no project active. See variable `ada-case-exception-file'.")))
+ )))
(unless word
(if (use-region-p)
(setq word (buffer-substring-no-properties (region-beginning) (region-end)))
(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))
(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_]+\\)"))
+ ;; FIXME: this is actually a based numeric literal; excludes 1234
+ (looking-back "\\([0-9]+#[0-9a-fA-F_]+\\)" (line-beginning-position)))
+
+(defvar ada-keywords nil
+ "List of Ada keywords for current `ada-language-version'.")
(defun ada-after-keyword-p ()
"Return non-nil if point is after an element of `ada-keywords'."
(point))))
(member (downcase word) ada-keywords)))
-(defun ada-case-adjust-identifier ()
+(defun ada-lower-case (start end _force-case-strict)
+ (downcase-region start end))
+
+(defun ada-upper-case (start end _force-case-strict)
+ (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 (or force-case-strict ada-case-strict)
+ (downcase-region start end))
+ (goto-char start)
+ (while (not done)
+ (setq next
+ (or
+ (save-excursion (when (search-forward "_" end t) (point-marker)))
+ (copy-marker (1+ end))))
+
+ ;; upcase first char
+ (upcase-region (point) (1+ (point)))
+
+ (goto-char next)
+ (if (< (point) end)
+ (setq start (point))
+ (setq done t))
+ )))
+
+(defun ada-case-adjust-identifier (&optional force-case)
"Adjust case of the previous word as an identifier.
-Uses Mixed_Case, with exceptions defined in
+Uses `ada-case-identifier', with exceptions defined in
`ada-case-full-exceptions', `ada-case-partial-exceptions'."
(interactive)
(save-excursion
(insert (car match))
(delete-region (point) end))
- ;; else apply Mixed_Case and partial-exceptions
- (if ada-case-strict
- (downcase-region start end))
+ ;; else apply ada-case-identifier
+ (funcall ada-case-identifier start end force-case)
+
+ ;; apply partial-exceptions
+ (goto-char start)
(while (not done)
(setq next
(or
(save-excursion (when (search-forward "_" end t) (point-marker)))
(copy-marker (1+ end))))
- (if (setq match (assoc-string (buffer-substring-no-properties start (1- next))
+ (when (setq match (assoc-string (buffer-substring-no-properties start (1- next))
ada-case-partial-exceptions t))
- (progn
- ;; see comment above at 'full word exception' for why
- ;; we do insert first.
- (insert (car match))
- (delete-region (point) (1- next)))
-
- ;; else upcase first char
- (insert-char (upcase (following-char)) 1)
- (delete-char 1))
+ ;; see comment above at 'full word exception' for why
+ ;; we do insert first.
+ (insert (car match))
+ (delete-region (point) (1- next)))
(goto-char next)
(if (< (point) end)
"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
(not (ada-in-numeric-literal-p))
))
- (cond
- ;; Some attributes are also keywords, but captialized as
- ;; attributes. So check for attribute first.
- ((and
- (not in-comment)
- (save-excursion
- (skip-syntax-backward "w_")
- (eq (char-before) ?')))
- (ada-case-adjust-identifier))
-
- ((and
- (not in-comment)
- (not (eq typed-char ?_))
- (ada-after-keyword-p))
- (funcall ada-case-keyword -1))
-
- (t (ada-case-adjust-identifier))
- ))
- ))
+ ;; The indentation engine may trigger a reparse on
+ ;; non-whitespace changes, but we know we don't need to reparse
+ ;; for this change (assuming the user has not abused case
+ ;; exceptions!).
+ (let ((inhibit-modification-hooks t))
+ (cond
+ ;; Some attributes are also keywords, but captialized as
+ ;; attributes. So check for attribute first.
+ ((and
+ (not in-comment)
+ (save-excursion
+ (skip-syntax-backward "w_")
+ (eq (char-before) ?')))
+ (ada-case-adjust-identifier in-comment))
+
+ ((and
+ (not in-comment)
+ (not (eq typed-char ?_))
+ (ada-after-keyword-p))
+ (funcall ada-case-keyword -1))
+
+ (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))
- (memq (char-syntax (char-after)) '(?w ?_)))
- (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."
(ada-case-adjust-region (point-min) (point-max)))
(defun ada-case-adjust-interactive (arg)
- "Adjust the case of the previous word, and process the character just typed.
+ "If `ada-auto-case' is non-nil, adjust the case of the previous word, and process the character just typed.
To be bound to keys that should cause auto-casing.
ARG is the prefix the user entered with \\[universal-argument]."
(interactive "P")
(cond
((eq lastk ?\n)
- (ada-case-adjust lastk)
- (funcall ada-lfd-binding))
+ (when ada-auto-case
+ (ada-case-adjust lastk))
+ (funcall ada-lfd-binding))
- ((eq lastk ?\r)
- (ada-case-adjust lastk)
+ ((memq lastk '(?\r return))
+ (when ada-auto-case
+ (ada-case-adjust lastk))
(funcall ada-ret-binding))
(t
- (ada-case-adjust lastk)
+ (when ada-auto-case
+ (ada-case-adjust lastk))
(self-insert-command (prefix-numeric-value arg)))
- )
- ))
-
-(defvar ada-ret-binding nil)
-(defvar ada-lfd-binding nil)
-
-(defun ada-case-activate-keys ()
- "Modify the key bindings for all the keys that should adjust casing."
- (interactive)
- ;; We can't use post-self-insert-hook for \n, \r, because they are
- ;; not self-insert. So we make ada-mode-map buffer local, and don't
- ;; call this function if ada-auto-case is off. That means
- ;; ada-auto-case cannot be changed after an Ada buffer is created.
-
- ;; The 'or ...' is there to be sure that the value will not be
- ;; changed again when Ada mode is called more than once, since we
- ;; are rebinding the keys.
- (or ada-ret-binding (setq ada-ret-binding (key-binding "\C-M")))
- (or ada-lfd-binding (setq ada-lfd-binding (key-binding "\C-j")))
-
- (mapcar (function
- (lambda(key)
- (define-key
- ada-mode-map
- (char-to-string key)
- 'ada-case-adjust-interactive)))
- '( ?_ ?% ?& ?* ?( ?) ?- ?= ?+
- ?| ?\; ?: ?' ?\" ?< ?, ?. ?> ?/ ?\n 32 ?\r ))
- )
+ )))
;;;; project files
(defun ada-prj-get (prop &optional plist)
"Return value of PROP in PLIST.
Optional PLIST defaults to `ada-prj-current-project'."
- (plist-get (or plist ada-prj-current-project) prop))
+ (let ((prj (or plist ada-prj-current-project)))
+ (if prj
+ (plist-get prj prop)
+
+ ;; no project, just use default vars
+ ;; must match code in ada-prj-default
+ (cl-case prop
+ (ada_compiler ada-compiler)
+ (auto_case ada-auto-case)
+ (case_keyword ada-case-keyword)
+ (case_identifier ada-case-identifier)
+ (case_strict ada-case-strict)
+ (casing (if (listp ada-case-exception-file)
+ ada-case-exception-file
+ (list ada-case-exception-file)))
+ (path_sep path-separator)
+ (proc_env process-environment)
+ (src_dir (list "."))
+ (xref_tool ada-xref-tool)
+ ))))
(defun ada-prj-put (prop val &optional plist)
"Set value of PROP in PLIST to VAL.
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
;; variable name alphabetical order
'ada_compiler ada-compiler
- 'ada_ref_tool ada-xref-tool
'auto_case ada-auto-case
'case_keyword ada-case-keyword
+ 'case_identifier ada-case-identifier
'case_strict ada-case-strict
'casing (if (listp ada-case-exception-file)
ada-case-exception-file
(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 (list (if src-dir src-dir "."))
'xref_tool ada-xref-tool
))
(lambda (ext) (cons ext 'ada-prj-parse-file-1))
ada-prj-file-extensions)
;; project file parse
- "Alist of parsers for project files.
+ "Alist of parsers for project files, indexed by file extension.
Default provides the minimal Ada mode parser; compiler support
code may add other parsers. Parser is called with two arguments;
the project file name and the current project property
(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: use the right name, add an alias
(let ((project (ada-prj-default))
(parser (cdr (assoc (file-name-extension prj-file) ada-prj-parser-alist))))
(setq prj-file (expand-file-name prj-file))
+ (unless (file-readable-p prj-file)
+ (error "Project file '%s' is not readable" prj-file))
+
(if parser
;; parser may reference the "current project", so bind that now.
(let ((ada-prj-current-project project)
((string= (match-string 1) "case_keyword")
(setq project (plist-put project 'case_keyword (intern (match-string 2)))))
+ ((string= (match-string 1) "case_identifier")
+ (setq project (plist-put project 'case_identifier (intern (match-string 2)))))
+
((string= (match-string 1) "case_strict")
(setq project (plist-put project 'case_strict (intern (match-string 2)))))
((string= (match-string 1) "casing")
- (add-to-list 'casing
- (expand-file-name
- (substitute-in-file-name (match-string 2)))))
+ (cl-pushnew (expand-file-name
+ (substitute-in-file-name (match-string 2)))
+ casing :test #'equal))
((string= (match-string 1) "el_file")
(let ((file (expand-file-name (substitute-in-file-name (match-string 2)))))
(load-file file)))
((string= (match-string 1) "src_dir")
- (add-to-list 'src_dir
- (file-name-as-directory
- (expand-file-name (match-string 2)))))
+ (cl-pushnew (file-name-as-directory
+ (expand-file-name (match-string 2)))
+ src_dir :test #'equal))
((string= (match-string 1) "xref_tool")
(let ((xref (intern (match-string 2))))
);; done reading file
;; process accumulated lists
- (if casing (set 'project (plist-put project 'casing (reverse casing))))
- (if src_dir (set 'project (plist-put project 'src_dir (reverse src_dir))))
+ (if casing (setq project (plist-put project 'casing (reverse casing))))
+ (if src_dir (setq project (plist-put project 'src_dir (reverse src_dir))))
(when parse-final-compiler
;; parse-final-compiler may reference the "current project", so
project
))
-(defvar ada-project-search-path nil
- "Search path for finding Ada project files")
-
(defvar ada-select-prj-compiler nil
"Alist of functions to call for compiler specific project file selection.
Indexed by project variable ada_compiler.")
(ada-case-read-all-exceptions)
(setq compilation-search-path (ada-prj-get 'src_dir))
- (setq ada-project-search-path (ada-prj-get 'prj_dir))
(let ((func (cdr (assq (ada-prj-get 'ada_compiler) ada-select-prj-compiler))))
(when func (funcall func)))
;; 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
+ ;; Supplied by compiler
+ "Function to show project search path used by compiler (and possibly xref tool)."
+ )
+
+(defun ada-prj-show-path ()
+ (interactive)
+ (when ada-prj-show-path
+ (funcall ada-prj-show-path)))
+
+(defvar ada-show-xref-tool-buffer nil
+ ;; Supplied by xref tool
+ "Function to show process buffer used by xref tool."
+ )
+
+(defun ada-show-xref-tool-buffer ()
+ (interactive)
+ (when ada-show-xref-tool-buffer
+ (funcall ada-show-xref-tool-buffer)))
+
;;;; syntax properties
(defvar ada-mode-syntax-table
(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)
"Assign `syntax-table' properties in accessible part of buffer.
In particular, character constants are set to have string syntax."
;; (info "(elisp)Syntax Properties")
- (let ((modified (buffer-modified-p))
- (buffer-undo-list t)
- (inhibit-read-only t)
- (inhibit-point-motion-hooks t)
- (inhibit-modification-hooks t))
+ ;;
+ ;; called from `syntax-propertize', inside save-excursion with-silent-modifications
+ (let ((inhibit-read-only t)
+ (inhibit-point-motion-hooks t))
(goto-char start)
- (while (re-search-forward
- (concat
- "[^a-zA-Z0-9)]\\('\\)[^'\n]\\('\\)"; 1, 2: character constants, not attributes
- "\\|[^a-zA-Z0-9)]\\('''\\)"; 3: character constant '''
- "\\|\\(--\\)"; 4: comment start
- )
- end t)
- ;; The help for syntax-propertize-extend-region-functions
- ;; implies that 'start end' will always include whole lines, in
- ;; which case we don't need
- ;; syntax-propertize-extend-region-functions
- (cond
- ((match-beginning 1)
- (put-text-property
- (match-beginning 1) (match-end 1) 'syntax-table '(7 . ?'))
- (put-text-property
- (match-beginning 2) (match-end 2) 'syntax-table '(7 . ?')))
- ((match-beginning 3)
- (put-text-property
- (match-beginning 3) (1+ (match-beginning 3)) 'syntax-table '(7 . ?'))
- (put-text-property
- (1- (match-end 3)) (match-end 3) 'syntax-table '(7 . ?')))
- ((match-beginning 4)
- (put-text-property
- (match-beginning 4) (match-end 4) 'syntax-table '(11 . nil)))
- ))
- (run-hook-with-args 'ada-syntax-propertize-hook start end)
- (unless modified
- (restore-buffer-modified-p nil))))
+ (save-match-data
+ (while (re-search-forward
+ (concat
+ "[^a-zA-Z0-9)]\\('\\)[^'\n]\\('\\)"; 1, 2: character literal, not attribute
+ "\\|[^a-zA-Z0-9)]\\('''\\)"; 3: character literal '''
+ "\\|\\(--\\)"; 4: comment start
+ )
+ end t)
+ ;; syntax-propertize-extend-region-functions is set to
+ ;; syntax-propertize-wholelines by default. We assume no
+ ;; coding standard will permit a character literal at the
+ ;; start of a line (not preceded by whitespace).
+ (cond
+ ((match-beginning 1)
+ (put-text-property
+ (match-beginning 1) (match-end 1) 'syntax-table '(7 . ?'))
+ (put-text-property
+ (match-beginning 2) (match-end 2) 'syntax-table '(7 . ?')))
+ ((match-beginning 3)
+ (put-text-property
+ (match-beginning 3) (1+ (match-beginning 3)) 'syntax-table '(7 . ?'))
+ (put-text-property
+ (1- (match-end 3)) (match-end 3) 'syntax-table '(7 . ?')))
+ ((match-beginning 4)
+ (put-text-property
+ (match-beginning 4) (match-end 4) 'syntax-table '(11 . nil)))
+ )))
+ (run-hook-with-args 'ada-syntax-propertize-hook start end))
+ )
(defun ada-in-comment-p (&optional parse-result)
"Return t if inside a comment.
"Regexp for extracting the parent name from fully-qualified name.")
(defvar ada-file-name-from-ada-name nil
- ;; depends on ada-compiler, per-project
+ ;; determined by ada-xref-tool, set by *-select-prj
"Function called with one parameter ADA-NAME, which is a library
unit name; it should return the filename in which ADA-NAME is
found.")
(defun ada-file-name-from-ada-name (ada-name)
"Return the filename in which ADA-NAME is found."
+ (ada-require-project-file)
(funcall ada-file-name-from-ada-name ada-name))
(defvar ada-ada-name-from-file-name nil
- ;; depends on ada-compiler, per-project
+ ;; supplied by compiler
"Function called with one parameter FILE-NAME, which is a library
unit name; it should return the Ada name that should be found in FILE-NAME.")
(defun ada-ada-name-from-file-name (file-name)
"Return the ada-name that should be found in FILE-NAME."
+ (ada-require-project-file)
(funcall ada-ada-name-from-file-name file-name))
(defun ada-ff-special-extract-parent ()
ada-spec-suffixes)
(error "parent '%s' not found; set project file?" ff-function-name))))
-(defun ada-ff-special-extract-separate ()
- (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-which-function
(funcall ada-which-function)))
+(defvar ada-on-context-clause nil
+ ;; supplied by indentation engine
+ "Function called with no parameters; it should return non-nil
+ if point is on a context clause.")
+
+(defun ada-on-context-clause ()
+ "See `ada-on-context-clause' variable."
+ (interactive)
+ (when ada-on-context-clause
+ (funcall ada-on-context-clause)))
+
+(defvar ada-goto-subunit-name nil
+ ;; supplied by indentation engine
+ "Function called with no parameters; if the current buffer
+ contains a subunit, move point to the subunit name (for
+ `ada-goto-declaration'), return t; otherwise leave point alone,
+ return nil.")
+
+(defun ada-goto-subunit-name ()
+ "See `ada-goto-subunit-name' variable."
+ (interactive)
+ (when ada-goto-subunit-name
+ (funcall ada-goto-subunit-name)))
+
(defun ada-add-log-current-function ()
"For `add-log-current-defun-function'; uses `ada-which-function'."
;; add-log-current-defun is typically called with point at the start
;; This will still be confused by multiple references; we need
;; to use compiler cross reference info for more precision.
(while (not done)
- (when (search-forward-regexp ff-function-name nil t)
- (setq found (match-beginning 0)))
+ (if (search-forward-regexp ff-function-name nil t)
+ (setq found (match-beginning 0))
+ ;; not in remainder of buffer
+ (setq done t))
(if (ada-in-string-or-comment-p)
(setq found nil)
(setq done t)))
(back-to-indentation))
(setq ff-function-name nil))))
+(defun ada-check-current-project (file-name)
+ "Throw error if FILE-NAME (must be absolute) is not found in
+the current project source directories, or if no project has been
+set."
+ (when (null (car compilation-search-path))
+ (error "no file search path defined; set project file?"))
+
+ ;; file-truename handles symbolic links
+ (let* ((visited-file (file-truename file-name))
+ (found-file (locate-file (file-name-nondirectory visited-file)
+ compilation-search-path)))
+ (unless found-file
+ (error "current file not part of current project; wrong project?"))
+
+ (setq found-file (file-truename found-file))
+
+ ;; (nth 10 (file-attributes ...)) is the inode; required when hard
+ ;; links are present.
+ (let* ((visited-file-inode (nth 10 (file-attributes visited-file)))
+ (found-file-inode (nth 10 (file-attributes found-file))))
+ (unless (equal visited-file-inode found-file-inode)
+ (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 &optional _no-set-point)
"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.
;; information
(interactive "P")
- (when (null (car compilation-search-path))
- (error "no file search path defined; set project file?"))
+ (ada-check-current-project (buffer-file-name))
- (if mark-active
- (progn
- (setq ff-function-name (buffer-substring-no-properties (point) (mark)))
- (ff-get-file
- compilation-search-path
- (ada-file-name-from-ada-name ff-function-name)
- ada-spec-suffixes
- other-window)
- (deactivate-mark))
-
- ;; else use name at point
+ (cond
+ (mark-active
+ (setq ff-function-name (buffer-substring-no-properties (point) (mark)))
+ (ff-get-file
+ compilation-search-path
+ (ada-file-name-from-ada-name ff-function-name)
+ ada-spec-suffixes
+ other-window)
+ (deactivate-mark))
+
+ ((and (not (ada-on-context-clause))
+ (ada-goto-subunit-name))
+ (ada-goto-declaration other-window))
+
+ (t
(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\\|<=\\|<\\|>=\\|>"
(defun ada-identifier-at-point ()
"Return the identifier around point, move point to start of
-identifier. May be an Ada identifier or operator function name."
+identifier. May be an Ada identifier or operator."
(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
+ ;; 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: 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.")
+
+(defconst ada-goto-pos-ring-max 16
+ "Number of positions kept in the list `ada-goto-pos-ring'.")
+
+(defun ada-goto-push-pos ()
+ "Push current filename, position on `ada-goto-pos-ring'. See `ada-goto-previous-pos'."
+ (setq ada-goto-pos-ring (cons (list (point) (buffer-file-name)) ada-goto-pos-ring))
+ (if (> (length ada-goto-pos-ring) ada-goto-pos-ring-max)
+ (setcdr (nthcdr (1- ada-goto-pos-ring-max) ada-goto-pos-ring) nil)))
+
+(defun ada-goto-previous-pos ()
+ "Go to the first position in `ada-goto-pos-ring', pop `ada-goto-pos-ring'."
+ (interactive)
+ (when ada-goto-pos-ring
+ (let ((pos (pop ada-goto-pos-ring)))
+ (find-file (cadr pos))
+ (goto-char (car pos)))))
(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'.
If OTHER-WINDOW is non-nil, show the buffer in another window."
- (setq file (ff-get-file-name compilation-search-path file))
+ (let ((file-1
+ (if (file-name-absolute-p file) file
+ (ff-get-file-name compilation-search-path file))))
+ (if file-1
+ (setq file file-1)
+ (error "File %s not found; installed library, or set project?" file))
+ )
+
+ (ada-goto-push-pos)
+
(let ((buffer (get-file-buffer file)))
(cond
((bufferp buffer)
"Function that returns cross reference information.
Function is called with four arguments:
- an Ada identifier or operator_symbol
-- filename containing the identifier
+- 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.
If OTHER-WINDOW (set by interactive prefix) is non-nil, show the
buffer in another window."
(interactive "P")
+ (ada-check-current-project (buffer-file-name))
(when (null ada-xref-other-function)
(error "no cross reference information available"))
- (let ((target
- (funcall ada-xref-other-function
- (ada-identifier-at-point)
- (file-name-nondirectory (buffer-file-name))
- (line-number-at-pos)
- (1+ (current-column))
- )))
-
- (ada-goto-source (nth 0 target)
- (nth 1 target)
- (nth 2 target)
- other-window)
+ (let ((target
+ (funcall ada-xref-other-function
+ (ada-identifier-at-point)
+ (buffer-file-name)
+ (line-number-at-pos)
+ (1+ (current-column))
+ )))
+
+ (ada-goto-source (nth 0 target)
+ (nth 1 target)
+ (nth 2 target)
+ other-window)
))
(defvar ada-xref-parent-function nil
(defun ada-show-declaration-parents ()
"Display the locations of the parent type declarations of the type identifier around point."
(interactive)
+ (ada-check-current-project (buffer-file-name))
+
(when (null ada-xref-parent-function)
(error "no cross reference information available"))
(defun ada-show-references ()
"Show all references of identifier at point."
(interactive)
+ (ada-check-current-project (buffer-file-name))
(when (null ada-xref-all-function)
(error "no cross reference information available"))
(ada-identifier-at-point)
(file-name-nondirectory (buffer-file-name))
(line-number-at-pos)
- (cl-case (char-after)
- (?\" (+ 2 (current-column))) ;; FIXME: work around bug in gnat find
- (t (1+ (current-column)))))
+ (1+ (current-column)))
)
(defvar ada-xref-overriding-function nil
(defun ada-show-overriding ()
"Show all overridings of identifier at point."
(interactive)
+ (ada-check-current-project (buffer-file-name))
(when (null ada-xref-overriding-function)
(error "no cross reference information available"))
(defun ada-show-overridden (other-window)
"Show the overridden declaration of identifier at point."
(interactive "P")
+ (ada-check-current-project (buffer-file-name))
(when (null ada-xref-overridden-function)
(error "'show overridden' not supported, or no cross reference information available"))
;;
;; This is run from ff-pre-load-hook, so ff-function-name may have
;; been set by ff-treat-special; don't reset it.
- "Function to move point to start of the generic, package,
-protected, subprogram, or task declaration point is currently in
-or just after. Called with no parameters.")
+ "For `beginning-of-defun-function'. Function to move point to
+start of the generic, package, protected, subprogram, or task
+declaration point is currently in or just after. Called with no
+parameters.")
(defun ada-goto-declaration-start ()
"Call `ada-goto-declaration-start'."
+ (interactive)
(when ada-goto-declaration-start
(funcall ada-goto-declaration-start)))
+(defvar ada-goto-declaration-end nil
+ ;; supplied by indentation engine
+ "For `end-of-defun-function'. Function to move point to end of
+current declaration.")
+
+(defun ada-goto-declaration-end ()
+ "See `ada-goto-declaration-end' variable."
+ (interactive)
+ (when ada-goto-declaration-end
+ (funcall ada-goto-declaration-end)))
+
(defvar ada-goto-declarative-region-start nil
;; Supplied by indentation engine
"Function to move point to start of the declarative region of
"See `ada-next-statement-keyword' variable."
(interactive)
(when ada-next-statement-keyword
+ (unless (region-active-p)
+ (push-mark))
(funcall ada-next-statement-keyword)))
(defvar ada-prev-statement-keyword nil
"See `ada-prev-statement-keyword' variable."
(interactive)
(when ada-prev-statement-keyword
+ (unless (region-active-p)
+ (push-mark))
(funcall ada-prev-statement-keyword)))
;;;; code creation
(error "`ada-make-subprogram-body' not set")))
(defvar ada-make-package-body nil
- ;; Supplied by compiler
+ ;; Supplied by xref tool
"Function to create a package body from a package spec.
Called with one argument; the absolute path to the body
file. Current buffer is the package spec. Should create the
package body file, containing skeleton code that will compile.")
(defun ada-make-package-body (body-file-name)
- (if ada-make-package-body
- (funcall ada-make-package-body body-file-name)
- (error "`ada-make-package-body' not set")))
+ ;; no error if not set; let ada-skel do its thing.
+ (when ada-make-package-body
+ (funcall ada-make-package-body body-file-name)))
(defun ada-ff-create-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)
- (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.
- (ff-find-the-other-file)
- (revert-buffer t t)
+ ;; 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)
+
+ (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.
+ (ff-find-the-other-file)
+ (revert-buffer t t))
))
;;;; fill-comment
(not (looking-at "[ \t]*--")))
(error "Not inside comment"))
- (let* (indent from to
+ (let* ((inhibit-modification-hooks t) ;; don't run parser for font-lock; comment text is exposed
+ indent from to
(opos (point-marker))
;; we bind `fill-prefix' here rather than in ada-mode because
;; setting it in ada-mode causes indent-region to use it for
(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.
+ (when (memq 'jit-lock-after-change after-change-functions)
+ (jit-lock-after-change from to 0))
+ ))
;;;; support for font-lock.el
'("some")
"List of keywords new in Ada 2012.")
-(defvar ada-keywords nil
- "List of Ada keywords for current `ada-language-version'.")
-
(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\\|"
- "in[ \t]+out[ \t]+not[ \t]+null\\|"
- "in[ \t]+out\\|"
- "in\\|"
- ;; "return\\|" can't distinguish between 'function ... return <type>;' and 'return ...;'
- ;; An indentation engine can, so a rule for this is added there
- "of[ \t]+reverse\\|"
- "of\\|"
- "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" "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" "renames" "reverse"
- "select" "separate" "task" "terminate"
- "then" "when" "while" "xor")
- (when (member ada-language-version '(ada95 ada2005 ada2012))
- '("abstract" "aliased" "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))
-
- ;; 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 name that could be a type or a function (generic instantiation).
- (list (concat
- "\\<\\("
- "new"
- "\\)\\>[ \t]*"
- ada-name-regexp "?[ \t]*\\((\\)?")
- '(1 font-lock-keyword-face)
- '(2 (if (match-beginning 3)
- font-lock-function-name-face
- font-lock-type-face)
- nil t))
-
- ;; keywords followed by a name that should be in type-face if not already fontified (for subtypes)
- ;; after "new" to handle "is new"
- (list (concat
- "\\<\\("
- "is"
- "\\)\\>[ \t]*"
- ada-name-regexp "?")
- '(1 font-lock-keyword-face) '(2 font-lock-type-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
+;; ada-mode does not derive from prog-mode, because we need to call
+;; ada-mode-post-local-vars, and prog-mode does not provide a way to
+;; do that.
+;;
;; autoload required by automatic mode setting
;;;###autoload
(defun ada-mode ()
(set (make-local-variable 'require-final-newline) t)
+ ;; 'font-lock-defaults' is a confusing name; it's buffer local
(setq font-lock-defaults
'(ada-font-lock-keywords
nil t
'ada-other-file-alist)
(setq ff-post-load-hook 'ada-set-point-accordingly
ff-file-created-hook 'ada-ff-create-body)
+ (add-hook 'ff-pre-load-hook 'ada-goto-push-pos)
(add-hook 'ff-pre-load-hook 'ada-which-function)
(setq ff-search-directories 'compilation-search-path)
+ (when (null (car compilation-search-path))
+ ;; find-file doesn't handle nil in search path
+ (setq compilation-search-path (list (file-name-directory (buffer-file-name)))))
(ada-set-ff-special-constructs)
(set (make-local-variable 'add-log-current-defun-function)
'ada-add-log-current-function)
- (add-hook 'which-func-functions 'ada-which-function nil t)
+ (when (boundp 'which-func-functions)
+ (add-hook 'which-func-functions 'ada-which-function nil t))
;; Support for align
(add-to-list 'align-dq-string-modes 'ada-mode)
(easy-menu-add ada-mode-menu ada-mode-map)
+ (setq ada-case-strict (ada-prj-get 'case_strict))
+
(run-mode-hooks 'ada-mode-hook)
;; If global-font-lock is not enabled, ada-syntax-propertize is
;; This means to fully set ada-mode interactively, user must
;; do M-x ada-mode M-; (hack-local-variables)
- (when ada-auto-case (ada-case-activate-keys))
-
- (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-95-keywords
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))
+
+ (when ada-goto-declaration-end
+ (set (make-local-variable 'end-of-defun-function) ada-goto-declaration-end))
)
(put 'ada-mode 'custom-mode-group 'ada)
(unless (featurep 'ada-indent-engine)
(require 'ada-wisi))
+(unless (featurep 'ada-xref-tool)
+ (cl-case ada-xref-tool
+ ((nil gnat) (require 'ada-gnat-xref))
+ (gpr_query (require 'gpr-query))
+ ))
+
(unless (featurep 'ada-compiler)
(require 'ada-gnat-compile))
-(unless (featurep 'ada-xref-tool)
- (require 'ada-gnat-xref))
-
(unless (featurep 'ada-skeletons)
(require 'ada-skel))
+(when (featurep 'imenu)
+ (require 'ada-imenu))
+
;;; end of file