;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
(require 'cl-lib)
+(require 'ada-mode) ;; for ada-prj-* etc; will be refactored sometime
;;;;; code
(cond
((listp prj-dir)
- (add-to-list 'prj-dir dir))
+ (cl-pushnew dir prj-dir :test #'equal))
(prj-dir
(setq prj-dir (list dir)))
project))
+(defun gnat-prj-show-path ()
+ "For `ada-prj-show-path'."
+ (interactive)
+ (if (ada-prj-get 'prj_dir)
+ (progn
+ (pop-to-buffer (get-buffer-create "*GNAT project search path*"))
+ (erase-buffer)
+ (dolist (file (ada-prj-get 'prj_dir))
+ (insert (format "%s\n" file))))
+ (message "no GNAT project search path files")
+ ))
+
(defun gnat-prj-parse-emacs-one (name value project)
"Handle gnat-specific Emacs Ada project file settings.
Return new PROJECT if NAME recognized, nil otherwise.
(kill-buffer (gnat-run-buffer-name))); things may have changed, force re-create
(if (ada-prj-get 'gpr_file project)
- (set 'project (gnat-parse-gpr (ada-prj-get 'gpr_file project) project))
+ (setq project (gnat-parse-gpr (ada-prj-get 'gpr_file project) project))
;; add the compiler libraries to src_dir
(setq project (gnat-get-paths project))
project)
-(defun gnat-get-paths (project)
- "Add project and/or compiler source, object paths to PROJECT src_dir and/or prc_dir."
+(defun gnat-get-paths-1 (src-dirs prj-dirs)
+ "Append list of source and project dirs in current gpr project to SRC-DIRS, PRJ-DIRS.
+Uses 'gnat list'. Returns new (SRC-DIRS PRJ-DIRS)."
(with-current-buffer (gnat-run-buffer)
;; gnat list -v -P can return status 0 or 4; always lists compiler dirs
- (let ((src-dirs (ada-prj-get 'src_dir project))
- (prj-dirs (ada-prj-get 'prj_dir project)))
-
- (gnat-run-gnat "list" (list "-v") '(0 4))
+ ;;
+ ;; WORKAROUND: GNAT 7.2.1 gnatls does not support C++ fully; it
+ ;; does not return src_dirs from C++ projects (see AdaCore ticket
+ ;; M724-045). The workaround is to include the src_dirs in an
+ ;; Emacs Ada mode project.
+ (gnat-run-gnat "list" (list "-v") '(0 4))
+
+ (goto-char (point-min))
+
+ (condition-case nil
+ (progn
+ ;; Source path
+ (search-forward "Source Search Path:")
+ (forward-line 1)
+ (while (not (looking-at "^$")) ; terminate on blank line
+ (back-to-indentation) ; skip whitespace forward
+ (cl-pushnew
+ (if (looking-at "<Current_Directory>")
+ (directory-file-name default-directory)
+ (expand-file-name ; Canonicalize path part.
+ (directory-file-name
+ (buffer-substring-no-properties (point) (point-at-eol)))))
+ src-dirs
+ :test #'equal)
+ (forward-line 1))
+
+ ;; Project path
+ ;;
+ ;; These are also added to src_dir, so compilation errors
+ ;; reported in project files are found.
+ (search-forward "Project Search Path:")
+ (forward-line 1)
+ (while (not (looking-at "^$"))
+ (back-to-indentation)
+ (if (looking-at "<Current_Directory>")
+ (cl-pushnew "." prj-dirs :test #'equal)
+ (let ((f (expand-file-name
+ (buffer-substring-no-properties (point) (point-at-eol)))))
+ (cl-pushnew f prj-dirs :test #'equal)
+ (cl-pushnew f src-dirs :test #'equal)))
+ (forward-line 1))
+
+ )
+ (error
+ (pop-to-buffer (current-buffer))
+ ;; search-forward failed
+ (error "parse gpr failed")
+ ))
+ (list src-dirs prj-dirs)))
- (goto-char (point-min))
+(defun gnat-get-paths (project)
+ "Add project and/or compiler source, project paths to PROJECT src_dir and/or prj_dir."
+ (let ((src-dirs (ada-prj-get 'src_dir project))
+ (prj-dirs (ada-prj-get 'prj_dir project)))
+
+ ;; FIXME: use a dispatching function instead, with autoload, to
+ ;; avoid "require" here, which gives "warning: function not
+ ;; known".
+ ;; Using 'require' at top level gives the wrong default ada-xref-tool
+ (cl-ecase (ada-prj-get 'xref_tool project)
+ (gnat
+ (let ((res (gnat-get-paths-1 src-dirs prj-dirs)))
+ (setq src-dirs (car res))
+ (setq prj-dirs (cadr res))))
+
+ (gpr_query
+ (when (ada-prj-get 'gpr_file)
+ (require 'gpr-query)
+ (setq src-dirs (gpr-query-get-src-dirs src-dirs))
+ (setq prj-dirs (gpr-query-get-prj-dirs prj-dirs))))
+ )
- (condition-case nil
- (progn
- ;; Source path
- (search-forward "Source Search Path:")
- (forward-line 1)
- (while (not (looking-at "^$")) ; terminate on blank line
- (back-to-indentation) ; skip whitespace forward
- (if (looking-at "<Current_Directory>")
- (add-to-list 'src-dirs (directory-file-name default-directory))
- (add-to-list 'src-dirs
- (expand-file-name ; canonicalize path part
- (directory-file-name
- (buffer-substring-no-properties (point) (point-at-eol))))))
- (forward-line 1))
-
- ;; Project path
- ;;
- ;; These are also added to src_dir, so compilation errors
- ;; reported in project files are found.
- (search-forward "Project Search Path:")
- (forward-line 1)
- (while (not (looking-at "^$"))
- (back-to-indentation)
- (if (looking-at "<Current_Directory>")
- (add-to-list 'prj-dirs ".")
- (add-to-list 'prj-dirs
- (expand-file-name
- (buffer-substring-no-properties (point) (point-at-eol))))
- (add-to-list 'src-dirs
- (expand-file-name
- (buffer-substring-no-properties (point) (point-at-eol)))))
- (forward-line 1))
-
- )
- ('error
- (pop-to-buffer (current-buffer))
- ;; search-forward failed
- (error "parse gpr failed")
- ))
-
- (setq project (plist-put project 'src_dir (reverse src-dirs)))
- (mapc (lambda (dir) (gnat-prj-add-prj-dir dir project))
- (reverse prj-dirs))
- ))
+ (setq project (plist-put project 'src_dir (reverse src-dirs)))
+ (mapc (lambda (dir) (gnat-prj-add-prj-dir dir project))
+ (reverse prj-dirs))
+ )
project)
(defun gnat-parse-gpr (gpr-file project)
)
buffer)))
+(defun ada-gnat-show-run-buffer ()
+ (interactive)
+ (pop-to-buffer (gnat-run-buffer)))
+
(defun gnat-run (exec command &optional err-msg expected-status)
"Run a gnat command line tool, as \"EXEC COMMAND\".
-EXEC must be an executable found on `exec-path'. COMMAND must be a list of strings.
+EXEC must be an executable found on `exec-path'.
+COMMAND must be a list of strings.
ERR-MSG must be nil or a string.
-EXPECTED-STATUS must be nil or a list of integers.
+EXPECTED-STATUS must be nil or a list of integers; throws an error if
+process status is not a member.
+
Return process status.
Assumes current buffer is (gnat-run-buffer)"
(set 'buffer-read-only nil)
(defun gnat-run-no-prj (command &optional dir)
"Run the gnat command line tool, as \"gnat COMMAND\", with DIR as current directory.
-Return process status. Assumes current buffer
-is (gnat-run-buffer)"
+Return process status. Process output goes to current buffer,
+which is displayed on error."
(set 'buffer-read-only nil)
(erase-buffer)
(defun gnatprep-syntax-propertize (start end)
(goto-char start)
- (while (re-search-forward
- "^[ \t]*\\(#\\(?:if\\|else\\|elsif\\|end\\)\\)"; gnatprep keywords.
- end t)
- (cond
- ((match-beginning 1)
- (put-text-property
- (match-beginning 1) (match-end 1) 'syntax-table '(11 . ?\n)))
- )
- ))
-
-;;;; support for ada-gnat-xref and ada-gnatinspect
+ (save-match-data
+ (while (re-search-forward
+ "^[ \t]*\\(#\\(?:if\\|else\\|elsif\\|end\\)\\)"; gnatprep keywords.
+ end t)
+ (cond
+ ((match-beginning 1)
+ (put-text-property
+ (match-beginning 1) (match-end 1) 'syntax-table '(11 . ?\n)))
+ )
+ )))
+
+;;;; support for xref tools
(defun ada-gnat-file-name-from-ada-name (ada-name)
"For `ada-file-name-from-ada-name'."
(let ((result nil))
("a-string" . "Ada.Strings")
("a-strmap" . "Ada.Strings.Maps")
("a-strunb" . "Ada.Strings.Unbounded")
+ ("g-comlin" . "GNAT.Command_Line")
+ ("g-dirope" . "GNAT.Directory_Operations")
("g-socket" . "GNAT.Sockets")
("interfac" . "Interfaces")
("i-c" . "Interfaces.C")
;; need -f gnat stub option. We won't get here if there is an
;; existing body file.
(save-some-buffers t)
- (add-to-list 'opts "-f")
+ (cl-pushnew "-f" opts :test #'equal)
(with-current-buffer (gnat-run-buffer)
(gnat-run-no-prj
(append (list "stub") opts (list start-file "-cargs") switches)
)
nil))
+(defun ada-gnat-syntax-propertize (start end)
+ (goto-char start)
+ (save-match-data
+ (while (re-search-forward
+ (concat
+ "[^a-zA-Z0-9)]\\('\\)\\[[\"a-fA-F0-9]+\"\\]\\('\\)"; 1, 2: non-ascii character literal, not attributes
+ "\\|\\(\\[\"[a-fA-F0-9]+\"\\]\\)"; 3: non-ascii character in identifier
+ )
+ end t)
+ (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) (match-end 3) 'syntax-table '(2 . nil)))
+ )
+ )))
+
(provide 'gnat-core)
;; end of file