1 ;; Support for running GNAT tools, which support multiple programming
4 ;; GNAT is provided by AdaCore; see http://libre.adacore.com/
6 ;;; Copyright (C) 2012 - 2014 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-path ()
60 "For `ada-prj-show-path'."
62 (if (ada-prj-get 'prj_dir)
64 (pop-to-buffer (get-buffer-create "*GNAT project search path*"))
66 (dolist (file (ada-prj-get 'prj_dir))
67 (insert (format "%s\n" file))))
68 (message "no GNAT project search path files")
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 "." 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 (defun gnat-get-paths (project)
166 "Add project and/or compiler source, project paths to PROJECT src_dir and/or prj_dir."
167 (let ((src-dirs (ada-prj-get 'src_dir project))
168 (prj-dirs (ada-prj-get 'prj_dir project)))
170 ;; FIXME: use a dispatching function instead, with autoload, to
171 ;; avoid "require" here, which gives "warning: function not
173 ;; Using 'require' at top level gives the wrong default ada-xref-tool
174 (cl-ecase (ada-prj-get 'xref_tool project)
176 (let ((res (gnat-get-paths-1 src-dirs prj-dirs)))
177 (setq src-dirs (car res))
178 (setq prj-dirs (cadr res))))
181 (when (ada-prj-get 'gpr_file)
183 (setq src-dirs (gpr-query-get-src-dirs src-dirs))
184 (setq prj-dirs (gpr-query-get-prj-dirs prj-dirs))))
187 (setq project (plist-put project 'src_dir (reverse src-dirs)))
188 (mapc (lambda (dir) (gnat-prj-add-prj-dir dir project))
193 (defun gnat-parse-gpr (gpr-file project)
194 "Append to src_dir and prj_dir in PROJECT by parsing GPR-FILE.
195 Return new value of PROJECT.
196 GPR-FILE must be full path to file, normalized.
197 src_dir will include compiler runtime."
198 ;; this can take a long time; let the user know what's up
199 (message "Parsing %s ..." gpr-file)
201 (if (ada-prj-get 'gpr_file project)
202 ;; gpr-file defined in Emacs Ada mode project file
203 (when (not (equal gpr-file (ada-prj-get 'gpr_file project)))
204 (error "Ada project file %s defines a different GNAT project file than %s"
208 ;; gpr-file is top level Ada mode project file
209 (setq project (plist-put project 'gpr_file gpr-file))
212 (setq project (gnat-get-paths project))
214 (message "Parsing %s ... done" gpr-file)
217 ;;;; command line tool interface
219 (defun gnat-run-buffer-name (&optional prefix)
220 (concat (or prefix " *gnat-run-")
221 (or (ada-prj-get 'gpr_file)
222 ada-prj-current-file)
225 (defun gnat-run-buffer (&optional buffer-name-prefix)
226 "Return a buffer suitable for running gnat command line tools for the current project."
227 (ada-require-project-file)
228 (let* ((name (gnat-run-buffer-name buffer-name-prefix))
229 (buffer (get-buffer name)))
232 (setq buffer (get-buffer-create name))
233 (with-current-buffer buffer
234 (setq default-directory
236 (or (ada-prj-get 'gpr_file)
237 ada-prj-current-file)))
241 (defun ada-gnat-show-run-buffer ()
243 (pop-to-buffer (gnat-run-buffer)))
245 (defun gnat-run (exec command &optional err-msg expected-status)
246 "Run a gnat command line tool, as \"EXEC COMMAND\".
247 EXEC must be an executable found on `exec-path'.
248 COMMAND must be a list of strings.
249 ERR-MSG must be nil or a string.
250 EXPECTED-STATUS must be nil or a list of integers; throws an error if
251 process status is not a member.
253 Return process status.
254 Assumes current buffer is (gnat-run-buffer)"
255 (set 'buffer-read-only nil)
258 (setq command (cl-delete-if 'null command))
260 (let ((process-environment (ada-prj-get 'proc_env)) ;; for GPR_PROJECT_PATH
263 (insert (format "GPR_PROJECT_PATH=%s\n%s " (getenv "GPR_PROJECT_PATH") exec)); for debugging
264 (mapc (lambda (str) (insert (concat str " "))) command); for debugging
267 (setq status (apply 'call-process exec nil t nil command))
269 ((memq status (or expected-status '(0))); success
273 (pop-to-buffer (current-buffer))
275 (error "%s %s failed; %s" exec (car command) err-msg)
276 (error "%s %s failed" exec (car command))
280 (defun gnat-run-gnat (command &optional switches-args expected-status)
281 "Run the \"gnat\" command line tool, as \"gnat COMMAND -P<prj> SWITCHES-ARGS\".
282 COMMAND must be a string, SWITCHES-ARGS a list of strings.
283 EXPECTED-STATUS must be nil or a list of integers.
284 Return process status.
285 Assumes current buffer is (gnat-run-buffer)"
286 (let* ((project-file-switch
287 (when (ada-prj-get 'gpr_file)
288 (concat "-P" (file-name-nondirectory (ada-prj-get 'gpr_file)))))
289 (cmd (append (list command) (list project-file-switch) switches-args)))
291 (gnat-run "gnat" cmd nil expected-status)
294 (defun gnat-run-no-prj (command &optional dir)
295 "Run the gnat command line tool, as \"gnat COMMAND\", with DIR as current directory.
296 Return process status. Process output goes to current buffer,
297 which is displayed on error."
298 (set 'buffer-read-only nil)
301 (setq command (cl-delete-if 'null command))
302 (mapc (lambda (str) (insert (concat str " "))) command)
305 (let ((default-directory (or dir default-directory))
308 (setq status (apply 'call-process "gnat" nil t nil command))
310 ((= status 0); success
314 (pop-to-buffer (current-buffer))
315 (error "gnat %s failed" (car command)))
320 (defun gnatprep-indent ()
321 "If point is on a gnatprep keyword, return indentation column
322 for it. Otherwise return nil. Intended to be added to
323 `wisi-indent-calculate-functions' or other indentation function
325 ;; gnatprep keywords are:
327 ;; #if identifier [then]
328 ;; #elsif identifier [then]
332 ;; they are all indented at column 0.
333 (when (equal (char-after) ?\#) 0))
335 (defun gnatprep-syntax-propertize (start end)
338 (while (re-search-forward
339 "^[ \t]*\\(#\\(?:if\\|else\\|elsif\\|end\\)\\)"; gnatprep keywords.
344 (match-beginning 1) (match-end 1) 'syntax-table '(11 . ?\n)))
348 ;;;; support for xref tools
349 (defun ada-gnat-file-name-from-ada-name (ada-name)
350 "For `ada-file-name-from-ada-name'."
353 (while (string-match "\\." ada-name)
354 (setq ada-name (replace-match "-" t t ada-name)))
356 (setq ada-name (downcase ada-name))
358 (with-current-buffer (gnat-run-buffer)
363 ;; "0" means only krunch GNAT library names
366 (goto-char (point-min))
367 (forward-line 1); skip cmd
368 (setq result (buffer-substring-no-properties (line-beginning-position) (line-end-position)))
372 (defconst ada-gnat-predefined-package-alist
373 '(("a-textio" . "Ada.Text_IO")
374 ("a-chahan" . "Ada.Characters.Handling")
375 ("a-comlin" . "Ada.Command_Line")
376 ("a-except" . "Ada.Exceptions")
377 ("a-numeri" . "Ada.Numerics")
378 ("a-string" . "Ada.Strings")
379 ("a-strmap" . "Ada.Strings.Maps")
380 ("a-strunb" . "Ada.Strings.Unbounded")
381 ("g-comlin" . "GNAT.Command_Line")
382 ("g-dirope" . "GNAT.Directory_Operations")
383 ("g-socket" . "GNAT.Sockets")
384 ("interfac" . "Interfaces")
385 ("i-c" . "Interfaces.C")
386 ("i-cstrin" . "Interfaces.C.Strings")
387 ("s-stoele" . "System.Storage_Elements")
388 ("unchconv" . "Unchecked_Conversion") ; Ada 83 name
390 "Alist (filename . package name) of GNAT file names for predefined Ada packages.")
392 (defun ada-gnat-ada-name-from-file-name (file-name)
393 "For `ada-ada-name-from-file-name'."
395 (ada-name (file-name-sans-extension (file-name-nondirectory file-name)))
396 (predefined (cdr (assoc ada-name ada-gnat-predefined-package-alist))))
400 (while (string-match "-" ada-name)
401 (setq ada-name (replace-match "." t t ada-name)))
404 (defun ada-gnat-make-package-body (body-file-name)
405 "For `ada-make-package-body'."
406 ;; WORKAROUND: gnat stub 7.1w does not accept aggregate project files,
407 ;; and doesn't use the gnatstub package if it is in a 'with'd
408 ;; project file; see AdaCore ticket LC30-001. On the other hand we
409 ;; need a project file to specify the source dirs so the tree file
410 ;; can be generated. So we use gnat-run-no-prj, and the user
411 ;; must specify the proper project file in gnat_stub_opts.
413 ;; gnatstub always creates the body in the current directory (in the
414 ;; process where gnatstub is running); the -o parameter may not
415 ;; contain path info. So we pass a directory to gnat-run-no-prj.
416 (let ((start-buffer (current-buffer))
417 (start-file (buffer-file-name))
418 ;; can also specify gnat stub options/switches in .gpr file, in package 'gnatstub'.
419 (opts (when (ada-prj-get 'gnat_stub_opts)
420 (split-string (ada-prj-get 'gnat_stub_opts))))
421 (switches (when (ada-prj-get 'gnat_stub_switches)
422 (split-string (ada-prj-get 'gnat_stub_switches))))
425 ;; Make sure all relevant files are saved to disk. This also saves
426 ;; the bogus body buffer created by ff-find-the-other-file, so we
427 ;; need -f gnat stub option. We won't get here if there is an
428 ;; existing body file.
429 (save-some-buffers t)
430 (cl-pushnew "-f" opts :test #'equal)
431 (with-current-buffer (gnat-run-buffer)
433 (append (list "stub") opts (list start-file "-cargs") switches)
434 (file-name-directory body-file-name))
436 (find-file body-file-name)
437 (indent-region (point-min) (point-max))
439 (set-buffer start-buffer)
443 (defun ada-gnat-syntax-propertize (start end)
446 (while (re-search-forward
448 "[^a-zA-Z0-9)]\\('\\)\\[[\"a-fA-F0-9]+\"\\]\\('\\)"; 1, 2: non-ascii character literal, not attributes
449 "\\|\\(\\[\"[a-fA-F0-9]+\"\\]\\)"; 3: non-ascii character in identifier
455 (match-beginning 1) (match-end 1) 'syntax-table '(7 . ?'))
457 (match-beginning 2) (match-end 2) 'syntax-table '(7 . ?')))
461 (match-beginning 3) (match-end 3) 'syntax-table '(2 . nil)))