;;
;; 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.1.1
-;; package-requires: ((wisi "1.0.2") (cl-lib "0.4") (emacs "24.2"))
+;; Keywords: languages
+;; ada
+;; Version: 5.1.6
+;; package-requires: ((wisi "1.0.6") (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.1"))
+ (let ((version-string "5.1.6"))
;; must match:
;; ada-mode.texi
;; README
- ;; gpr-mode.el
;; Version: above
(if (called-interactively-p 'interactive)
(message version-string)
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-word)
- (const upcase-word))
+ (const downcase-region)
+ (const upcase-region))
:group 'ada
:safe 'functionp)
(make-variable-buffer-local 'ada-case-identifier)
;;;; keymap and menus
-(defvar ada-ret-binding nil)
-(defvar ada-lfd-binding nil)
+(defvar ada-ret-binding 'ada-indent-newline-indent)
+(defvar ada-lfd-binding 'newline-and-indent)
-(defun ada-case-activate-keys ()
+(defun ada-case-activate-keys (map)
"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.
-
- ;; The 'or ...' is there to be sure that the value will not be
- ;; changed again when this 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")))
-
+ ;; we could just put these in the keymap below, but this is easier.
(mapc (function
(lambda(key)
(define-key
- ada-mode-map
+ map
(char-to-string key)
'ada-case-adjust-interactive)))
'( ?_ ?% ?& ?* ?( ?) ?- ?= ?+
?| ?\; ?: ?' ?\" ?< ?, ?. ?> ?/ ?\n 32 ?\r ))
-
- (define-key ada-mode-map [return] 'ada-case-adjust-interactive)
)
(defvar ada-mode-map
;; 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]
["Other file don't find decl" ada-find-other-file-noset 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]
["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]
)))
-(ada-case-activate-keys)
;; This doesn't need to be buffer-local because there can be only one
;; popup menu at a time.
(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
"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)))
)
(let ((space-before-p (save-excursion (skip-chars-backward " \t") (not (bolp))))
- (space-after-p (save-excursion (skip-chars-forward " \t") (not (eolp)))))
+ (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
;; 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-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)
(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)
))
(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 '()
(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)
(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))
+
+ ((and
+ (not in-comment)
+ (not (eq typed-char ?_))
+ (ada-after-keyword-p))
+ (funcall ada-case-keyword -1))
+
+ (t (ada-case-adjust-identifier))
+ ))
+ )))
(defun ada-case-adjust-at-point (&optional in-comment)
"Adjust case of word at point, move to end of word.
(interactive "P")
(when
(and (not (eobp))
- (memq (char-syntax (char-after)) '(?w ?_)))
+ ;; 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))
;; no project, just use default vars
;; must match code in ada-prj-default
- (cl-case plist
+ (cl-case prop
(ada_compiler ada-compiler)
(auto_case ada-auto-case)
(case_keyword ada-case-keyword)
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)))
(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
"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.
(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 ()
(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 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."
;; 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)))
+ )
(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"))
(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
(looking-at (concat "\"\\(" ada-operator-re "\\)\"")))
(setq identifier (concat "\"" (match-string-no-properties 1) "\"")))
- ((looking-at "[a-zA-Z0-9_]+")
+ ((looking-at "[a-zA-Z0-9_]+\\|[+\\-*/&=<>]")
(setq identifier (match-string-no-properties 0)))
(t
(error "No identifier around"))
)))
+(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."
- (or (file-name-absolute-p file)
- (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
(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
"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 ...;'
- ;; An indentation engine can, so a rule for this is added there
- "of[ \t]+reverse\\|"
- "of\\|"
+ ;; "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"
(regexp-opt
(append
'("abort" "abs" "accept" "all"
- "and" "array" "at" "begin" "case" "declare" "delay" "delta"
+ ;; "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" "renames" "reverse"
+ "range" "record" "rem" "reverse"
"select" "separate" "task" "terminate"
"then" "when" "while" "xor")
(when (member ada-language-version '(ada95 ada2005 ada2012))
- '("abstract" "aliased" "requeue" "tagged" "until"))
+ ;; "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))
"\\>")
'(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
;; keywords followed by a name that should be in function-name-face if not already fontified
(list (concat
- "\\<\\("
- "end"
- "\\)\\>[ \t]*"
+ "\\<\\(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
(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)
(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
ada-95-keywords
ada-2005-keywords
ada-2012-keywords))))
+
+ (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-compiler)
- (require 'ada-gnat-compile))
-
(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))
))
+(unless (featurep 'ada-compiler)
+ (require 'ada-gnat-compile))
+
(unless (featurep 'ada-skeletons)
(require 'ada-skel))