X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/2b0d5df6f626fa1bc1413f4e51f1e9bcbd290816..2d44e7fef7e7388759518cba1a424495119679d1:/packages/ada-mode/gnat-core.el diff --git a/packages/ada-mode/gnat-core.el b/packages/ada-mode/gnat-core.el index c6e597fe5..2637c8934 100755 --- a/packages/ada-mode/gnat-core.el +++ b/packages/ada-mode/gnat-core.el @@ -3,7 +3,7 @@ ;; ;; GNAT is provided by AdaCore; see http://libre.adacore.com/ ;; -;;; Copyright (C) 2012, 2013 Free Software Foundation, Inc. +;;; Copyright (C) 2012 - 2014 Free Software Foundation, Inc. ;; ;; Author: Stephen Leake ;; Maintainer: Stephen Leake @@ -23,11 +23,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see . -;; We use cl-delete-if, defined in cl-seq.el. cl-seq.el has no -;; 'provide'. autoload for cl-delete-if is defined in cl-loaddefs.el, -;; which is not pre-loaded. cl-lib does (load "cl-loaddefs.el"), so -;; that seems to be the thing to do (require 'cl-lib) +(require 'ada-mode) ;; for ada-prj-* etc; will be refactored sometime ;;;;; code @@ -98,61 +95,86 @@ See also `gnat-parse-emacs-final'." 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 + (if (looking-at "") + (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 "") + (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") + )) + (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 gnat_inspect) + (let ((res (gnat-get-paths-1 src-dirs prj-dirs))) + (setq src-dirs (car res)) + (setq prj-dirs (cadr res)))) + + (gpr_query + (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 "") - (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 "") - (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) @@ -203,11 +225,18 @@ src_dir will include compiler runtime." ) 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) @@ -251,8 +280,8 @@ Assumes current buffer is (gnat-run-buffer)" (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) @@ -292,17 +321,18 @@ list." (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)) @@ -335,6 +365,8 @@ list." ("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") @@ -395,6 +427,28 @@ list." ) 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