code.delx.au - gnu-emacs-elpa/blob - packages/ada-mode/gnat-core.el

   1 ;; Support for running GNAT tools, which support multiple programming
   2 ;; languages.
   3 ;;
   4 ;; GNAT is provided by AdaCore; see http://libre.adacore.com/
   5 ;;
   6 ;;; Copyright (C) 2012 - 2014  Free Software Foundation, Inc.
   7 ;;
   8 ;; Author: Stephen Leake <stephen_leake@member.fsf.org>
   9 ;; Maintainer: Stephen Leake <stephen_leake@member.fsf.org>
  10 ;;
  11 ;; This file is part of GNU Emacs.
  12 ;;
  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.
  17 ;;
  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.
  22 ;;
  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/>.
  25
  26 (require 'cl-lib)
  27 (require 'ada-mode) ;; for ada-prj-* etc; will be refactored sometime
  28
  29 ;;;;; code
  30
  31 ;;;; project file handling
  32
  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)))
  36
  37     (cond
  38      ((listp prj-dir)
  39         (add-to-list 'prj-dir dir))
  40
  41      (prj-dir
  42       (setq prj-dir (list dir)))
  43
  44      (t nil))
  45
  46     (setq project (plist-put project 'prj_dir prj-dir))
  47
  48     (let ((process-environment (plist-get project 'proc_env)))
  49       (setenv "GPR_PROJECT_PATH"
  50               (mapconcat 'identity
  51                          (plist-get project 'prj_dir)
  52                          (plist-get project 'path_sep)))
  53
  54       (setq project (plist-put project 'proc_env process-environment))
  55       )
  56
  57     project))
  58
  59 (defun gnat-prj-parse-emacs-one (name value project)
  60   "Handle gnat-specific Emacs Ada project file settings.
  61 Return new PROJECT if NAME recognized, nil otherwise.
  62 See also `gnat-parse-emacs-final'."
  63   (let ((process-environment (plist-get project 'proc_env))); for substitute-in-file-name
  64     (cond
  65      ((or
  66        ;; we allow either name here for backward compatibility
  67        (string= name "gpr_project_path")
  68        (string= name "ada_project_path"))
  69       ;; We maintain two project values for this;
  70       ;; 'prj_dir - a list of directories, for gpr-ff-special-with
  71       ;; GPR_PROJECT_PATH in 'proc_env, for gnat-run
  72       (gnat-prj-add-prj-dir (expand-file-name (substitute-in-file-name value)) project))
  73
  74      ((string= (match-string 1) "gpr_file")
  75       ;; The file is parsed in `gnat-parse-emacs-prj-file-final', so
  76       ;; it can add to user-specified src_dir.
  77       (setq project
  78             (plist-put project
  79                        'gpr_file
  80                        (expand-file-name (substitute-in-file-name value))))
  81       project)
  82      )))
  83
  84 (defun gnat-prj-parse-emacs-final (project)
  85   "Final processing of gnat-specific Emacs Ada project file settings."
  86   (when (buffer-live-p (get-buffer (gnat-run-buffer-name)))
  87     (kill-buffer (gnat-run-buffer-name))); things may have changed, force re-create
  88
  89   (if (ada-prj-get 'gpr_file project)
  90       (set 'project (gnat-parse-gpr (ada-prj-get 'gpr_file project) project))
  91
  92     ;; add the compiler libraries to src_dir
  93     (setq project (gnat-get-paths project))
  94     )
  95
  96   project)
  97
  98 (defun gnat-get-paths-1 (src-dirs prj-dirs)
  99   "Append list of source and project dirs in current gpr project to SRC-DIRS, PRJ-DIRS.
 100 Uses 'gnat list'. Returns new '(src-dirs prj-dirs)."
 101   (with-current-buffer (gnat-run-buffer)
 102     ;; gnat list -v -P can return status 0 or 4; always lists compiler dirs
 103     ;;
 104     ;; WORKAROUND: GNAT 7.2.1 gnatls does not support C++ fully; it
 105     ;; does not return src_dirs from C++ projects (see AdaCore ticket
 106     ;; M724-045). The workaround is to include the src_dirs in an
 107     ;; Emacs Ada mode project.
 108     (gnat-run-gnat "list" (list "-v") '(0 4))
 109
 110     (goto-char (point-min))
 111
 112     (condition-case nil
 113         (progn
 114           ;; Source path
 115           (search-forward "Source Search Path:")
 116           (forward-line 1)
 117           (while (not (looking-at "^$")) ; terminate on blank line
 118             (back-to-indentation) ; skip whitespace forward
 119             (if (looking-at "<Current_Directory>")
 120                 (add-to-list 'src-dirs  (directory-file-name default-directory))
 121               (add-to-list 'src-dirs
 122                            (expand-file-name ; canonicalize path part
 123                             (directory-file-name
 124                              (buffer-substring-no-properties (point) (point-at-eol))))))
 125             (forward-line 1))
 126
 127           ;; Project path
 128           ;;
 129           ;; These are also added to src_dir, so compilation errors
 130           ;; reported in project files are found.
 131           (search-forward "Project Search Path:")
 132           (forward-line 1)
 133           (while (not (looking-at "^$"))
 134             (back-to-indentation)
 135             (if (looking-at "<Current_Directory>")
 136                 (add-to-list 'prj-dirs ".")
 137               (add-to-list 'prj-dirs
 138                            (expand-file-name
 139                             (buffer-substring-no-properties (point) (point-at-eol))))
 140               (add-to-list 'src-dirs
 141                            (expand-file-name
 142                             (buffer-substring-no-properties (point) (point-at-eol)))))
 143             (forward-line 1))
 144
 145           )
 146       ('error
 147        (pop-to-buffer (current-buffer))
 148        ;; search-forward failed
 149        (error "parse gpr failed")
 150        ))
 151     (list src-dirs prj-dirs)))
 152
 153 (defun gnat-get-paths (project)
 154   "Add project and/or compiler source, project paths to PROJECT src_dir and/or prj_dir."
 155   (let ((src-dirs (ada-prj-get 'src_dir project))
 156         (prj-dirs (ada-prj-get 'prj_dir project)))
 157
 158     ;; FIXME: use a dispatching function instead, with autoload, to
 159     ;; avoid "require" here, which gives "warning: function not
 160     ;; known".
 161     ;; Using 'require' at top level gives the wrong default ada-xref-tool
 162     (cl-ecase (ada-prj-get 'xref_tool project)
 163       ((gnat gnat_inspect)
 164        (let ((res (gnat-get-paths-1 src-dirs prj-dirs)))
 165          (setq src-dirs (car res))
 166          (setq prj-dirs (cadr res))))
 167
 168       (gpr_query
 169        (when (ada-prj-get 'gpr_file)
 170          (require 'gpr-query)
 171          (setq src-dirs (gpr-query-get-src-dirs src-dirs))
 172          (setq prj-dirs (gpr-query-get-prj-dirs prj-dirs))))
 173       )
 174
 175     (setq project (plist-put project 'src_dir (reverse src-dirs)))
 176     (mapc (lambda (dir) (gnat-prj-add-prj-dir dir project))
 177           (reverse prj-dirs))
 178     )
 179   project)
 180
 181 (defun gnat-parse-gpr (gpr-file project)
 182   "Append to src_dir and prj_dir in PROJECT by parsing GPR-FILE.
 183 Return new value of PROJECT.
 184 GPR-FILE must be full path to file, normalized.
 185 src_dir will include compiler runtime."
 186   ;; this can take a long time; let the user know what's up
 187   (message "Parsing %s ..." gpr-file)
 188
 189   (if (ada-prj-get 'gpr_file project)
 190       ;; gpr-file defined in Emacs Ada mode project file
 191       (when (not (equal gpr-file (ada-prj-get 'gpr_file project)))
 192         (error "Ada project file %s defines a different GNAT project file than %s"
 193                ada-prj-current-file
 194                gpr-file))
 195
 196     ;; gpr-file is top level Ada mode project file
 197     (setq project (plist-put project 'gpr_file gpr-file))
 198     )
 199
 200   (setq project (gnat-get-paths project))
 201
 202   (message "Parsing %s ... done" gpr-file)
 203   project)
 204
 205 ;;;; command line tool interface
 206
 207 (defun gnat-run-buffer-name (&optional prefix)
 208   (concat (or prefix " *gnat-run-")
 209           (or (ada-prj-get 'gpr_file)
 210               ada-prj-current-file)
 211           "*"))
 212
 213 (defun gnat-run-buffer (&optional buffer-name-prefix)
 214   "Return a buffer suitable for running gnat command line tools for the current project."
 215   (ada-require-project-file)
 216   (let* ((name (gnat-run-buffer-name buffer-name-prefix))
 217          (buffer (get-buffer name)))
 218     (if buffer
 219         buffer
 220       (setq buffer (get-buffer-create name))
 221       (with-current-buffer buffer
 222         (setq default-directory
 223               (file-name-directory
 224                (or (ada-prj-get 'gpr_file)
 225                    ada-prj-current-file)))
 226         )
 227       buffer)))
 228
 229 (defun ada-gnat-show-run-buffer ()
 230   (interactive)
 231   (pop-to-buffer (gnat-run-buffer)))
 232
 233 (defun gnat-run (exec command &optional err-msg expected-status)
 234   "Run a gnat command line tool, as \"EXEC COMMAND\".
 235 EXEC must be an executable found on `exec-path'.
 236 COMMAND must be a list of strings.
 237 ERR-MSG must be nil or a string.
 238 EXPECTED-STATUS must be nil or a list of integers; throws an error if
 239 process status is not a member.
 240
 241 Return process status.
 242 Assumes current buffer is (gnat-run-buffer)"
 243   (set 'buffer-read-only nil)
 244   (erase-buffer)
 245
 246   (setq command (cl-delete-if 'null command))
 247
 248   (let ((process-environment (ada-prj-get 'proc_env)) ;; for GPR_PROJECT_PATH
 249         status)
 250
 251     (insert (format "GPR_PROJECT_PATH=%s\n%s " (getenv "GPR_PROJECT_PATH") exec)); for debugging
 252     (mapc (lambda (str) (insert (concat str " "))) command); for debugging
 253     (newline)
 254
 255     (setq status (apply 'call-process exec nil t nil command))
 256     (cond
 257      ((memq status (or expected-status '(0))); success
 258       nil)
 259
 260      (t ; failure
 261       (pop-to-buffer (current-buffer))
 262       (if err-msg
 263           (error "%s %s failed; %s" exec (car command) err-msg)
 264         (error "%s %s failed" exec (car command))
 265         ))
 266      )))
 267
 268 (defun gnat-run-gnat (command &optional switches-args expected-status)
 269   "Run the \"gnat\" command line tool, as \"gnat COMMAND -P<prj> SWITCHES-ARGS\".
 270 COMMAND must be a string, SWITCHES-ARGS a list of strings.
 271 EXPECTED-STATUS must be nil or a list of integers.
 272 Return process status.
 273 Assumes current buffer is (gnat-run-buffer)"
 274   (let* ((project-file-switch
 275           (when (ada-prj-get 'gpr_file)
 276             (concat "-P" (file-name-nondirectory (ada-prj-get 'gpr_file)))))
 277          (cmd (append (list command) (list project-file-switch) switches-args)))
 278
 279     (gnat-run "gnat" cmd nil expected-status)
 280     ))
 281
 282 (defun gnat-run-no-prj (command &optional dir)
 283   "Run the gnat command line tool, as \"gnat COMMAND\", with DIR as current directory.
 284 Return process status.  Process output goes to current buffer,
 285 which is displayed on error."
 286   (set 'buffer-read-only nil)
 287   (erase-buffer)
 288
 289   (setq command (cl-delete-if 'null command))
 290   (mapc (lambda (str) (insert (concat str " "))) command)
 291   (newline)
 292
 293   (let ((default-directory (or dir default-directory))
 294         status)
 295
 296     (setq status (apply 'call-process "gnat" nil t nil command))
 297     (cond
 298      ((= status 0); success
 299       nil)
 300
 301      (t ; failure
 302       (pop-to-buffer (current-buffer))
 303       (error "gnat %s failed" (car command)))
 304      )))
 305
 306 ;;;; gnatprep utils
 307
 308 (defun gnatprep-indent ()
 309   "If point is on a gnatprep keyword, return indentation column
 310 for it. Otherwise return nil.  Intended to be added to
 311 `wisi-indent-calculate-functions' or other indentation function
 312 list."
 313   ;; gnatprep keywords are:
 314   ;;
 315   ;; #if identifier [then]
 316   ;; #elsif identifier [then]
 317   ;; #else
 318   ;; #end if;
 319   ;;
 320   ;; they are all indented at column 0.
 321   (when (equal (char-after) ?\#) 0))
 322
 323 (defun gnatprep-syntax-propertize (start end)
 324   (goto-char start)
 325   (save-match-data
 326     (while (re-search-forward
 327             "^[ \t]*\\(#\\(?:if\\|else\\|elsif\\|end\\)\\)"; gnatprep keywords.
 328             end t)
 329       (cond
 330        ((match-beginning 1)
 331         (put-text-property
 332          (match-beginning 1) (match-end 1) 'syntax-table '(11 . ?\n)))
 333        )
 334       )))
 335
 336 ;;;; support for xref tools
 337 (defun ada-gnat-file-name-from-ada-name (ada-name)
 338   "For `ada-file-name-from-ada-name'."
 339   (let ((result nil))
 340
 341     (while (string-match "\\." ada-name)
 342       (setq ada-name (replace-match "-" t t ada-name)))
 343
 344     (setq ada-name (downcase ada-name))
 345
 346     (with-current-buffer (gnat-run-buffer)
 347       (gnat-run-no-prj
 348        (list
 349         "krunch"
 350         ada-name
 351         ;; "0" means only krunch GNAT library names
 352         "0"))
 353
 354       (goto-char (point-min))
 355       (forward-line 1); skip  cmd
 356       (setq result (buffer-substring-no-properties (line-beginning-position) (line-end-position)))
 357       )
 358     result))
 359
 360 (defconst ada-gnat-predefined-package-alist
 361   '(("a-textio" . "Ada.Text_IO")
 362     ("a-chahan" . "Ada.Characters.Handling")
 363     ("a-comlin" . "Ada.Command_Line")
 364     ("a-except" . "Ada.Exceptions")
 365     ("a-numeri" . "Ada.Numerics")
 366     ("a-string" . "Ada.Strings")
 367     ("a-strmap" . "Ada.Strings.Maps")
 368     ("a-strunb" . "Ada.Strings.Unbounded")
 369     ("g-comlin" . "GNAT.Command_Line")
 370     ("g-dirope" . "GNAT.Directory_Operations")
 371     ("g-socket" . "GNAT.Sockets")
 372     ("interfac" . "Interfaces")
 373     ("i-c"      . "Interfaces.C")
 374     ("i-cstrin" . "Interfaces.C.Strings")
 375     ("s-stoele" . "System.Storage_Elements")
 376     ("unchconv" . "Unchecked_Conversion") ; Ada 83 name
 377     )
 378   "Alist (filename . package name) of GNAT file names for predefined Ada packages.")
 379
 380 (defun ada-gnat-ada-name-from-file-name (file-name)
 381   "For `ada-ada-name-from-file-name'."
 382   (let* (status
 383          (ada-name (file-name-sans-extension (file-name-nondirectory file-name)))
 384         (predefined (cdr (assoc ada-name ada-gnat-predefined-package-alist))))
 385
 386     (if predefined
 387         predefined
 388       (while (string-match "-" ada-name)
 389         (setq ada-name (replace-match "." t t ada-name)))
 390       ada-name)))
 391
 392 (defun ada-gnat-make-package-body (body-file-name)
 393   "For `ada-make-package-body'."
 394   ;; WORKAROUND: gnat stub 7.1w does not accept aggregate project files,
 395   ;; and doesn't use the gnatstub package if it is in a 'with'd
 396   ;; project file; see AdaCore ticket LC30-001. On the other hand we
 397   ;; need a project file to specify the source dirs so the tree file
 398   ;; can be generated. So we use gnat-run-no-prj, and the user
 399   ;; must specify the proper project file in gnat_stub_opts.
 400   ;;
 401   ;; gnatstub always creates the body in the current directory (in the
 402   ;; process where gnatstub is running); the -o parameter may not
 403   ;; contain path info. So we pass a directory to gnat-run-no-prj.
 404   (let ((start-buffer (current-buffer))
 405         (start-file (buffer-file-name))
 406         ;; can also specify gnat stub options/switches in .gpr file, in package 'gnatstub'.
 407         (opts (when (ada-prj-get 'gnat_stub_opts)
 408                 (split-string (ada-prj-get 'gnat_stub_opts))))
 409         (switches (when (ada-prj-get 'gnat_stub_switches)
 410                     (split-string (ada-prj-get 'gnat_stub_switches))))
 411         )
 412
 413     ;; Make sure all relevant files are saved to disk. This also saves
 414     ;; the bogus body buffer created by ff-find-the-other-file, so we
 415     ;; need -f gnat stub option. We won't get here if there is an
 416     ;; existing body file.
 417     (save-some-buffers t)
 418     (add-to-list 'opts "-f")
 419     (with-current-buffer (gnat-run-buffer)
 420       (gnat-run-no-prj
 421        (append (list "stub") opts (list start-file "-cargs") switches)
 422        (file-name-directory body-file-name))
 423
 424       (find-file body-file-name)
 425       (indent-region (point-min) (point-max))
 426       (save-buffer)
 427       (set-buffer start-buffer)
 428       )
 429     nil))
 430
 431 (defun ada-gnat-syntax-propertize (start end)
 432   (goto-char start)
 433   (save-match-data
 434     (while (re-search-forward
 435             (concat
 436              "[^a-zA-Z0-9)]\\('\\)\\[[\"a-fA-F0-9]+\"\\]\\('\\)"; 1, 2: non-ascii character literal, not attributes
 437              "\\|\\(\\[\"[a-fA-F0-9]+\"\\]\\)"; 3: non-ascii character in identifier
 438              )
 439             end t)
 440       (cond
 441        ((match-beginning 1)
 442         (put-text-property
 443          (match-beginning 1) (match-end 1) 'syntax-table '(7 . ?'))
 444         (put-text-property
 445          (match-beginning 2) (match-end 2) 'syntax-table '(7 . ?')))
 446
 447        ((match-beginning 3)
 448         (put-text-property
 449          (match-beginning 3) (match-end 3) 'syntax-table '(2 . nil)))
 450        )
 451       )))
 452
 453 (provide 'gnat-core)
 454
 455 ;; end of file