1 ;; gnat-core.el --- Support for running GNAT tools, which support multiple programming -*- lexical-binding:t -*-
4 ;; GNAT is provided by AdaCore; see http://libre.adacore.com/
6 ;;; Copyright (C) 2012 - 2015 Free Software Foundation, Inc.
8 ;; Author: Stephen Leake <stephen_leake@member.fsf.org>
9 ;; Maintainer: Stephen Leake <stephen_leake@member.fsf.org>
11 ;; This file is part of GNU Emacs.
13 ;; GNU Emacs is free software: you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation, either version 3 of the License, or
16 ;; (at your option) any later version.
18 ;; GNU Emacs is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
27 (require 'ada-mode) ;; for ada-prj-* etc; will be refactored sometime
31 ;;;; project file handling
33 (defun gnat-prj-add-prj-dir (dir project)
34 "Add DIR to 'prj_dir and to GPR_PROJECT_PATH in 'proc_env. Return new project."
35 (let ((prj-dir (plist-get project 'prj_dir)))
39 (cl-pushnew dir prj-dir :test #'equal))
42 (setq prj-dir (list dir)))
46 (setq project (plist-put project 'prj_dir prj-dir))
48 (let ((process-environment (plist-get project 'proc_env)))
49 (setenv "GPR_PROJECT_PATH"
51 (plist-get project 'prj_dir)
52 (plist-get project 'path_sep)))
54 (setq project (plist-put project 'proc_env process-environment))
59 (defun gnat-prj-show-prj-path ()
60 "For `ada-prj-show-prj-path'."
62 (if (ada-prj-get 'prj_dir)
64 (pop-to-buffer (get-buffer-create "*GNAT project file search path*"))
66 (dolist (file (ada-prj-get 'prj_dir))
67 (insert (format "%s\n" file))))
68 (message "no project file search path set")
71 (defun gnat-prj-parse-emacs-one (name value project)
72 "Handle gnat-specific Emacs Ada project file settings.
73 Return new PROJECT if NAME recognized, nil otherwise.
74 See also `gnat-parse-emacs-final'."
75 (let ((process-environment (plist-get project 'proc_env))); for substitute-in-file-name
78 ;; we allow either name here for backward compatibility
79 (string= name "gpr_project_path")
80 (string= name "ada_project_path"))
81 ;; We maintain two project values for this;
82 ;; 'prj_dir - a list of directories, for gpr-ff-special-with
83 ;; GPR_PROJECT_PATH in 'proc_env, for gnat-run
84 (gnat-prj-add-prj-dir (expand-file-name (substitute-in-file-name value)) project))
86 ((string= (match-string 1) "gpr_file")
87 ;; The file is parsed in `gnat-parse-emacs-prj-file-final', so
88 ;; it can add to user-specified src_dir.
92 (expand-file-name (substitute-in-file-name value))))
96 (defun gnat-prj-parse-emacs-final (project)
97 "Final processing of gnat-specific Emacs Ada project file settings."
98 (when (buffer-live-p (get-buffer (gnat-run-buffer-name)))
99 (kill-buffer (gnat-run-buffer-name))); things may have changed, force re-create
101 (if (ada-prj-get 'gpr_file project)
102 (setq project (gnat-parse-gpr (ada-prj-get 'gpr_file project) project))
104 ;; add the compiler libraries to src_dir
105 (setq project (gnat-get-paths project))
110 (defun gnat-get-paths-1 (src-dirs prj-dirs)
111 "Append list of source and project dirs in current gpr project to SRC-DIRS, PRJ-DIRS.
112 Uses 'gnat list'. Returns new (SRC-DIRS PRJ-DIRS)."
113 (with-current-buffer (gnat-run-buffer)
114 ;; gnat list -v -P can return status 0 or 4; always lists compiler dirs
116 ;; WORKAROUND: GNAT 7.2.1 gnatls does not support C++ fully; it
117 ;; does not return src_dirs from C++ projects (see AdaCore ticket
118 ;; M724-045). The workaround is to include the src_dirs in an
119 ;; Emacs Ada mode project.
120 (gnat-run-gnat "list" (list "-v") '(0 4))
122 (goto-char (point-min))
127 (search-forward "Source Search Path:")
129 (while (not (looking-at "^$")) ; terminate on blank line
130 (back-to-indentation) ; skip whitespace forward
132 (if (looking-at "<Current_Directory>")
133 (directory-file-name default-directory)
134 (expand-file-name ; Canonicalize path part.
136 (buffer-substring-no-properties (point) (point-at-eol)))))
143 ;; These are also added to src_dir, so compilation errors
144 ;; reported in project files are found.
145 (search-forward "Project Search Path:")
147 (while (not (looking-at "^$"))
148 (back-to-indentation)
149 (if (looking-at "<Current_Directory>")
150 (cl-pushnew (directory-file-name default-directory) prj-dirs :test #'equal)
151 (let ((f (expand-file-name
152 (buffer-substring-no-properties (point) (point-at-eol)))))
153 (cl-pushnew f prj-dirs :test #'equal)
154 (cl-pushnew f src-dirs :test #'equal)))
159 (pop-to-buffer (current-buffer))
160 ;; search-forward failed
161 (error "parse gpr failed")
163 (list src-dirs prj-dirs)))
165 ;; FIXME: use a dispatching function instead, with autoload, to
166 ;; avoid "require" here, and this declare
167 ;; Using 'require' at top level gives the wrong default ada-xref-tool
168 (declare-function gpr-query-get-src-dirs "gpr-query.el" (src-dirs))
169 (declare-function gpr-query-get-prj-dirs "gpr-query.el" (prj-dirs))
170 (defun gnat-get-paths (project)
171 "Add project and/or compiler source, project paths to PROJECT src_dir and/or prj_dir."
172 (let ((src-dirs (ada-prj-get 'src_dir project))
173 (prj-dirs (ada-prj-get 'prj_dir project)))
175 (cl-ecase (ada-prj-get 'xref_tool project)
177 (let ((res (gnat-get-paths-1 src-dirs prj-dirs)))
178 (setq src-dirs (car res))
179 (setq prj-dirs (cadr res))))
182 (when (ada-prj-get 'gpr_file)
184 (setq src-dirs (gpr-query-get-src-dirs src-dirs))
185 (setq prj-dirs (gpr-query-get-prj-dirs prj-dirs))))
188 (setq project (plist-put project 'src_dir (reverse src-dirs)))
189 (mapc (lambda (dir) (gnat-prj-add-prj-dir dir project))
194 (defun gnat-parse-gpr (gpr-file project)
195 "Append to src_dir and prj_dir in PROJECT by parsing GPR-FILE.
196 Return new value of PROJECT.
197 GPR-FILE must be full path to file, normalized.
198 src_dir will include compiler runtime."
199 ;; this can take a long time; let the user know what's up
200 (message "Parsing %s ..." gpr-file)
202 (if (ada-prj-get 'gpr_file project)
203 ;; gpr-file defined in Emacs Ada mode project file
204 (when (not (equal gpr-file (ada-prj-get 'gpr_file project)))
205 (error "Ada project file %s defines a different GNAT project file than %s"
209 ;; gpr-file is top level Ada mode project file
210 (setq project (plist-put project 'gpr_file gpr-file))
213 (setq project (gnat-get-paths project))
215 (message "Parsing %s ... done" gpr-file)
218 ;;;; command line tool interface
220 (defun gnat-run-buffer-name (&optional prefix)
221 (concat (or prefix " *gnat-run-")
222 (or (ada-prj-get 'gpr_file)
223 ada-prj-current-file)
226 (defun gnat-run-buffer (&optional buffer-name-prefix)
227 "Return a buffer suitable for running gnat command line tools for the current project."
228 (ada-require-project-file)
229 (let* ((name (gnat-run-buffer-name buffer-name-prefix))
230 (buffer (get-buffer name)))
233 (setq buffer (get-buffer-create name))
234 (with-current-buffer buffer
235 (setq default-directory
237 (or (ada-prj-get 'gpr_file)
238 ada-prj-current-file)))
242 (defun ada-gnat-show-run-buffer ()
244 (pop-to-buffer (gnat-run-buffer)))
246 (defun gnat-run (exec command &optional err-msg expected-status)
247 "Run a gnat command line tool, as \"EXEC COMMAND\".
248 EXEC must be an executable found on `exec-path'.
249 COMMAND must be a list of strings.
250 ERR-MSG must be nil or a string.
251 EXPECTED-STATUS must be nil or a list of integers; throws an error if
252 process status is not a member.
254 Return process status.
255 Assumes current buffer is (gnat-run-buffer)"
256 (set 'buffer-read-only nil)
259 (setq command (cl-delete-if 'null command))
261 (let ((process-environment (ada-prj-get 'proc_env)) ;; for GPR_PROJECT_PATH
264 (insert (format "GPR_PROJECT_PATH=%s\n%s " (getenv "GPR_PROJECT_PATH") exec)); for debugging
265 (mapc (lambda (str) (insert (concat str " "))) command); for debugging
268 (setq status (apply 'call-process exec nil t nil command))
270 ((memq status (or expected-status '(0))); success
274 (pop-to-buffer (current-buffer))
276 (error "%s %s failed; %s" exec (car command) err-msg)
277 (error "%s %s failed" exec (car command))
281 (defun gnat-run-gnat (command &optional switches-args expected-status)
282 "Run the \"gnat\" command line tool, as \"gnat COMMAND -P<prj> SWITCHES-ARGS\".
283 COMMAND must be a string, SWITCHES-ARGS a list of strings.
284 EXPECTED-STATUS must be nil or a list of integers.
285 Return process status.
286 Assumes current buffer is (gnat-run-buffer)"
287 (let* ((project-file-switch
288 (when (ada-prj-get 'gpr_file)
289 (concat "-P" (file-name-nondirectory (ada-prj-get 'gpr_file)))))
290 (cmd (append (list command) (list project-file-switch) switches-args)))
292 (gnat-run "gnat" cmd nil expected-status)
295 (defun gnat-run-no-prj (command &optional dir)
296 "Run the gnat command line tool, as \"gnat COMMAND\", with DIR as current directory.
297 Return process status. Process output goes to current buffer,
298 which is displayed on error."
299 (set 'buffer-read-only nil)
302 (setq command (cl-delete-if 'null command))
303 (mapc (lambda (str) (insert (concat str " "))) command)
306 (let ((default-directory (or dir default-directory))
309 (setq status (apply 'call-process "gnat" nil t nil command))
311 ((= status 0); success
315 (pop-to-buffer (current-buffer))
316 (error "gnat %s failed" (car command)))
321 (defun gnatprep-indent ()
322 "If point is on a gnatprep keyword, return indentation column
323 for it. Otherwise return nil. Intended to be added to
324 `wisi-indent-calculate-functions' or other indentation function
326 ;; gnatprep keywords are:
328 ;; #if identifier [then]
329 ;; #elsif identifier [then]
333 ;; they are all indented at column 0.
334 (when (equal (char-after) ?\#) 0))
336 (defun gnatprep-syntax-propertize (start end)
339 (while (re-search-forward
340 "^[ \t]*\\(#\\(?:if\\|else\\|elsif\\|end\\)\\)"; gnatprep keywords.
345 (match-beginning 1) (match-end 1) 'syntax-table '(11 . ?\n)))
349 (defun gnatprep-setup ()
350 (when (boundp 'wisi-indent-calculate-functions)
351 (add-to-list 'wisi-indent-calculate-functions 'gnatprep-indent))
354 ;;;; support for xref tools
355 (defun ada-gnat-file-name-from-ada-name (ada-name)
356 "For `ada-file-name-from-ada-name'."
359 (while (string-match "\\." ada-name)
360 (setq ada-name (replace-match "-" t t ada-name)))
362 (setq ada-name (downcase ada-name))
364 (with-current-buffer (gnat-run-buffer)
369 ;; "0" means only krunch GNAT library names
372 (goto-char (point-min))
373 (forward-line 1); skip cmd
374 (setq result (buffer-substring-no-properties (line-beginning-position) (line-end-position)))
378 (defconst ada-gnat-predefined-package-alist
379 '(("a-textio" . "Ada.Text_IO")
380 ("a-chahan" . "Ada.Characters.Handling")
381 ("a-comlin" . "Ada.Command_Line")
382 ("a-contai" . "Ada.Containers")
383 ("a-except" . "Ada.Exceptions")
384 ("a-numeri" . "Ada.Numerics")
385 ("a-string" . "Ada.Strings")
386 ("a-strmap" . "Ada.Strings.Maps")
387 ("a-strunb" . "Ada.Strings.Unbounded")
388 ("g-comlin" . "GNAT.Command_Line")
389 ("g-dirope" . "GNAT.Directory_Operations")
390 ("g-socket" . "GNAT.Sockets")
391 ("interfac" . "Interfaces")
392 ("i-c" . "Interfaces.C")
393 ("i-cstrin" . "Interfaces.C.Strings")
394 ("s-stoele" . "System.Storage_Elements")
395 ("unchconv" . "Unchecked_Conversion") ; Ada 83 name
397 "Alist (filename . package name) of GNAT file names for predefined Ada packages.")
399 (defun ada-gnat-ada-name-from-file-name (file-name)
400 "For `ada-ada-name-from-file-name'."
401 (let* ((ada-name (file-name-sans-extension (file-name-nondirectory file-name)))
402 (predefined (cdr (assoc ada-name ada-gnat-predefined-package-alist))))
406 (while (string-match "-" ada-name)
407 (setq ada-name (replace-match "." t t ada-name)))
410 (defun ada-gnat-make-package-body (body-file-name)
411 "For `ada-make-package-body'."
412 ;; WORKAROUND: gnat stub 7.1w does not accept aggregate project files,
413 ;; and doesn't use the gnatstub package if it is in a 'with'd
414 ;; project file; see AdaCore ticket LC30-001. On the other hand we
415 ;; need a project file to specify the source dirs so the tree file
416 ;; can be generated. So we use gnat-run-no-prj, and the user
417 ;; must specify the proper project file in gnat_stub_opts.
419 ;; gnatstub always creates the body in the current directory (in the
420 ;; process where gnatstub is running); the -o parameter may not
421 ;; contain path info. So we pass a directory to gnat-run-no-prj.
422 (let ((start-buffer (current-buffer))
423 (start-file (buffer-file-name))
424 (opts (when (ada-prj-get 'gnat_stub_opts)
425 (split-string (ada-prj-get 'gnat_stub_opts))))
426 (switches (when (ada-prj-get 'gnat_stub_switches)
427 (split-string (ada-prj-get 'gnat_stub_switches))))
428 (process-environment (ada-prj-get 'proc_env)) ;; for GPR_PROJECT_PATH
431 ;; Make sure all relevant files are saved to disk.
432 (save-some-buffers t)
433 (with-current-buffer (gnat-run-buffer)
435 (append (list "stub") opts (list start-file "-cargs") switches)
436 (file-name-directory body-file-name))
438 (find-file body-file-name)
439 (indent-region (point-min) (point-max))
441 (set-buffer start-buffer)
445 (defun ada-gnat-syntax-propertize (start end)
448 (while (re-search-forward
450 "[^a-zA-Z0-9)]\\('\\)\\[[\"a-fA-F0-9]+\"\\]\\('\\)"; 1, 2: non-ascii character literal, not attributes
451 "\\|\\(\\[\"[a-fA-F0-9]+\"\\]\\)"; 3: non-ascii character in identifier
457 (match-beginning 1) (match-end 1) 'syntax-table '(7 . ?'))
459 (match-beginning 2) (match-end 2) 'syntax-table '(7 . ?')))
463 (match-beginning 3) (match-end 3) 'syntax-table '(2 . nil)))