-;;; ada-mode.el --- major-mode for editing Ada sources
+;;; ada-mode.el --- major-mode for editing Ada sources -*- lexical-binding:t -*-
;;
-;;; Copyright (C) 1994, 1995, 1997 - 2014 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 1995, 1997 - 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.1.4
-;; package-requires: ((wisi "1.0.4") (cl-lib "0.4") (emacs "24.2"))
+;; 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)
(defun ada-mode-version ()
"Return Ada mode version."
(interactive)
- (let ((version-string "5.1.4"))
+ (let ((version-string "5.1.8"))
;; must match:
;; ada-mode.texi
- ;; README
+ ;; README-ada-mode
;; Version: above
(if (called-interactively-p 'interactive)
(message version-string)
Casing of Ada keywords is done according to `ada-case-keyword',
identifiers are Mixed_Case."
:type 'boolean
- :group 'ada
- :safe 'booleanp)
+ :safe #'booleanp)
(make-variable-buffer-local 'ada-auto-case)
(defcustom ada-case-exception-file nil
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'.
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."
+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 downcase-region)
- (const upcase-region))
- :group 'ada
- :safe 'functionp)
+ (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
If non-nil, force Mixed_Case for identifiers.
Otherwise, allow UPPERCASE for identifiers."
:type 'boolean
- :group 'ada
- :safe 'booleanp)
+ :safe #'booleanp)
(make-variable-buffer-local 'ada-case-strict)
(defcustom ada-language-version 'ada2012
(const ada95)
(const ada2005)
(const ada2012))
- :group 'ada
- :safe 'symbolp)
+ :safe #'symbolp)
(make-variable-buffer-local 'ada-language-version)
(defcustom ada-fill-comment-prefix "-- "
"Comment fill prefix."
- :type 'string
- :group 'ada)
-(make-variable-buffer-local 'ada-language-version)
+ :type 'string)
(defcustom ada-fill-comment-postfix " --"
"Comment fill postfix."
- :type 'string
- :group 'ada)
-(make-variable-buffer-local 'ada-language-version)
+ :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 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\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]
["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]
["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.
["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
"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)))
)
(let ((space-before-p (save-excursion (skip-chars-backward " \t") (not (bolp))))
;; 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)
(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
(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'.")
(point))))
(member (downcase word) ada-keywords)))
-(defun ada-mixed-case (start end)
+(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 ada-case-strict
+ (if (or force-case-strict ada-case-strict)
(downcase-region start end))
(goto-char start)
(while (not done)
(copy-marker (1+ end))))
;; upcase first char
- (insert-char (upcase (following-char)) 1)
- (delete-char 1)
+ (upcase-region (point) (1+ (point)))
(goto-char next)
(if (< (point) end)
(setq done t))
)))
-(defun ada-case-adjust-identifier ()
+(defun ada-case-adjust-identifier (&optional force-case)
"Adjust case of the previous word as an identifier.
Uses `ada-case-identifier', with exceptions defined in
`ada-case-full-exceptions', `ada-case-partial-exceptions'."
(delete-region (point) end))
;; else apply ada-case-identifier
- (funcall ada-case-identifier start end)
+ (funcall ada-case-identifier start end force-case)
;; apply partial-exceptions
(goto-char start)
"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
(save-excursion
(skip-syntax-backward "w_")
(eq (char-before) ?')))
- (ada-case-adjust-identifier))
+ (ada-case-adjust-identifier in-comment))
((and
(not in-comment)
(ada-after-keyword-p))
(funcall ada-case-keyword -1))
- (t (ada-case-adjust-identifier))
+ (t (ada-case-adjust-identifier in-comment))
))
)))
(defun ada-case-adjust-at-point (&optional in-comment)
"Adjust case of word at point, move to end of word.
-With prefix arg, adjust case even if in comment."
+With prefix arg, adjust case as code even if in comment;
+otherwise, capitalize words in comments."
(interactive "P")
- (when
- (and (not (eobp))
- ;; we use '(syntax-after (point))' here, not '(char-syntax
- ;; (char-after))', because the latter does not respect
- ;; ada-syntax-propertize.
- (memq (syntax-class (syntax-after (point))) '(2 3)))
- (skip-syntax-forward "w_"))
- (ada-case-adjust nil in-comment))
+ (cond
+ ((and (not in-comment)
+ (ada-in-string-or-comment-p))
+ (skip-syntax-backward "w_")
+ (capitalize-word 1))
+
+ (t
+ (when
+ (and (not (eobp))
+ ;; we use '(syntax-after (point))' here, not '(char-syntax
+ ;; (char-after))', because the latter does not respect
+ ;; ada-syntax-propertize.
+ (memq (syntax-class (syntax-after (point))) '(2 3)))
+ (skip-syntax-forward "w_"))
+ (ada-case-adjust nil in-comment))
+ ))
(defun ada-case-adjust-region (begin end)
"Adjust case of all words in region BEGIN END."
;; 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 properties list. Function should add to the properties
list and return it.")
-(defun ada-prj-default ()
+(defun ada-prj-default (&optional src-dir)
"Return the default project properties list.
+If SRC-DIR is non-nil, use it as the default for src_dir.
Include properties set via `ada-prj-default-compiler-alist',
`ada-prj-default-xref-alist'."
(list ada-case-exception-file))
'path_sep path-separator;; prj variable so users can override it for their compiler
'proc_env process-environment
- 'src_dir (list ".")
+ 'src_dir (list (if src-dir src-dir "."))
'xref_tool ada-xref-tool
))
(defun ada-parse-prj-file (prj-file)
"Read Emacs Ada or compiler-specific project file PRJ-FILE, set project properties in `ada-prj-alist'."
;; Not called ada-prj-parse-file for Ada mode 4.01 compatibility
+ ;; FIXME: 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 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."
(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)
"\\|\\(--\\)"; 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
+ ;; 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
(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
(when (null (car compilation-search-path))
(error "no file search path defined; set project file?"))
- (unless (string= file-name
- (locate-file (file-name-nondirectory file-name)
- compilation-search-path))
- (error "current file not part of current project; wrong project?")))
+ ;; 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,
(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.
(interactive "P")
(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.")
(when (null ada-xref-other-function)
(error "no cross reference information available"))
- (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)
+ (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-goto-declaration-start ()
"Call `ada-goto-declaration-start'."
+ (interactive)
(when ada-goto-declaration-start
(funcall ada-goto-declaration-start)))
"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
(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
(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
(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
(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 global-font-lock-mode
- ;; This calls ada-font-lock-keywords, which depends on
- ;; ada-language-version
- (font-lock-refresh-defaults))
+ ;; fill-region-as-paragraph in ada-fill-comment-paragraph does not
+ ;; call syntax-propertize, so set comment syntax on
+ ;; ada-fill-comment-prefix. In post-local because user may want to
+ ;; set it per-file.
+ (put-text-property 0 2 'syntax-table '(11 . nil) ada-fill-comment-prefix)
(cl-case ada-language-version
(ada83
ada-2005-keywords
ada-2012-keywords))))
+ (when global-font-lock-mode
+ ;; This calls ada-font-lock-keywords, which depends on
+ ;; ada-keywords
+ (font-lock-refresh-defaults))
+
(when ada-goto-declaration-start
(set (make-local-variable 'beginning-of-defun-function) ada-goto-declaration-start))
(unless (featurep 'ada-xref-tool)
(cl-case ada-xref-tool
- ((nil 'gnat) (require 'ada-gnat-xref))
- ('gnat_inspect (require 'gnat-inspect))
- ('gpr_query (require 'gpr-query))
+ ((nil gnat) (require 'ada-gnat-xref))
+ (gpr_query (require 'gpr-query))
))
(unless (featurep 'ada-compiler)