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, to avoid "require" here,
 159     ;; which gives "warning: function not known".
 160     ;; Using 'require' at top level gives the wrong default ada-xref-tool
 161     (cl-ecase (ada-prj-get 'xref_tool project)
 162       ((gnat gnat_inspect)
 163        (let ((res (gnat-get-paths-1 src-dirs prj-dirs)))
 164          (setq src-dirs (car res))
 165          (setq prj-dirs (cadr res))))
 166
 167       (gpr_query
 168        (require 'gpr-query)
 169        (setq src-dirs (gpr-query-get-src-dirs src-dirs))
 170        (setq prj-dirs (gpr-query-get-prj-dirs prj-dirs)))
 171       )
 172
 173     (setq project (plist-put project 'src_dir (reverse src-dirs)))
 174     (mapc (lambda (dir) (gnat-prj-add-prj-dir dir project))
 175           (reverse prj-dirs))
 176     )
 177   project)
 178
 179 (defun gnat-parse-gpr (gpr-file project)
 180   "Append to src_dir and prj_dir in PROJECT by parsing GPR-FILE.
 181 Return new value of PROJECT.
 182 GPR-FILE must be full path to file, normalized.
 183 src_dir will include compiler runtime."
 184   ;; this can take a long time; let the user know what's up
 185   (message "Parsing %s ..." gpr-file)
 186
 187   (if (ada-prj-get 'gpr_file project)
 188       ;; gpr-file defined in Emacs Ada mode project file
 189       (when (not (equal gpr-file (ada-prj-get 'gpr_file project)))
 190         (error "Ada project file %s defines a different GNAT project file than %s"
 191                ada-prj-current-file
 192                gpr-file))
 193
 194     ;; gpr-file is top level Ada mode project file
 195     (setq project (plist-put project 'gpr_file gpr-file))
 196     )
 197
 198   (setq project (gnat-get-paths project))
 199
 200   (message "Parsing %s ... done" gpr-file)
 201   project)
 202
 203 ;;;; command line tool interface
 204
 205 (defun gnat-run-buffer-name (&optional prefix)
 206   (concat (or prefix " *gnat-run-")
 207           (or (ada-prj-get 'gpr_file)
 208               ada-prj-current-file)
 209           "*"))
 210
 211 (defun gnat-run-buffer (&optional buffer-name-prefix)
 212   "Return a buffer suitable for running gnat command line tools for the current project."
 213   (ada-require-project-file)
 214   (let* ((name (gnat-run-buffer-name buffer-name-prefix))
 215          (buffer (get-buffer name)))
 216     (if buffer
 217         buffer
 218       (setq buffer (get-buffer-create name))
 219       (with-current-buffer buffer
 220         (setq default-directory
 221               (file-name-directory
 222                (or (ada-prj-get 'gpr_file)
 223                    ada-prj-current-file)))
 224         )
 225       buffer)))
 226
 227 (defun gnat-run (exec command &optional err-msg expected-status)
 228   "Run a gnat command line tool, as \"EXEC COMMAND\".
 229 EXEC must be an executable found on `exec-path'.
 230 COMMAND must be a list of strings.
 231 ERR-MSG must be nil or a string.
 232 EXPECTED-STATUS must be nil or a list of integers; throws an error if
 233 process status is not a member.
 234
 235 Return process status.
 236 Assumes current buffer is (gnat-run-buffer)"
 237   (set 'buffer-read-only nil)
 238   (erase-buffer)
 239
 240   (setq command (cl-delete-if 'null command))
 241
 242   (let ((process-environment (ada-prj-get 'proc_env)) ;; for GPR_PROJECT_PATH
 243         status)
 244
 245     (insert (format "GPR_PROJECT_PATH=%s\n%s " (getenv "GPR_PROJECT_PATH") exec)); for debugging
 246     (mapc (lambda (str) (insert (concat str " "))) command); for debugging
 247     (newline)
 248
 249     (setq status (apply 'call-process exec nil t nil command))
 250     (cond
 251      ((memq status (or expected-status '(0))); success
 252       nil)
 253
 254      (t ; failure
 255       (pop-to-buffer (current-buffer))
 256       (if err-msg
 257           (error "%s %s failed; %s" exec (car command) err-msg)
 258         (error "%s %s failed" exec (car command))
 259         ))
 260      )))
 261
 262 (defun gnat-run-gnat (command &optional switches-args expected-status)
 263   "Run the \"gnat\" command line tool, as \"gnat COMMAND -P<prj> SWITCHES-ARGS\".
 264 COMMAND must be a string, SWITCHES-ARGS a list of strings.
 265 EXPECTED-STATUS must be nil or a list of integers.
 266 Return process status.
 267 Assumes current buffer is (gnat-run-buffer)"
 268   (let* ((project-file-switch
 269           (when (ada-prj-get 'gpr_file)
 270             (concat "-P" (file-name-nondirectory (ada-prj-get 'gpr_file)))))
 271          (cmd (append (list command) (list project-file-switch) switches-args)))
 272
 273     (gnat-run "gnat" cmd nil expected-status)
 274     ))
 275
 276 (defun gnat-run-no-prj (command &optional dir)
 277   "Run the gnat command line tool, as \"gnat COMMAND\", with DIR as current directory.
 278 Return process status.  Process output goes to current buffer,
 279 which is displayed on error."
 280   (set 'buffer-read-only nil)
 281   (erase-buffer)
 282
 283   (setq command (cl-delete-if 'null command))
 284   (mapc (lambda (str) (insert (concat str " "))) command)
 285   (newline)
 286
 287   (let ((default-directory (or dir default-directory))
 288         status)
 289
 290     (setq status (apply 'call-process "gnat" nil t nil command))
 291     (cond
 292      ((= status 0); success
 293       nil)
 294
 295      (t ; failure
 296       (pop-to-buffer (current-buffer))
 297       (error "gnat %s failed" (car command)))
 298      )))
 299
 300 ;;;; gnatprep utils
 301
 302 (defun gnatprep-indent ()
 303   "If point is on a gnatprep keyword, return indentation column
 304 for it. Otherwise return nil.  Intended to be added to
 305 `wisi-indent-calculate-functions' or other indentation function
 306 list."
 307   ;; gnatprep keywords are:
 308   ;;
 309   ;; #if identifier [then]
 310   ;; #elsif identifier [then]
 311   ;; #else
 312   ;; #end if;
 313   ;;
 314   ;; they are all indented at column 0.
 315   (when (equal (char-after) ?\#) 0))
 316
 317 (defun gnatprep-syntax-propertize (start end)
 318   (goto-char start)
 319   (save-match-data
 320     (while (re-search-forward
 321             "^[ \t]*\\(#\\(?:if\\|else\\|elsif\\|end\\)\\)"; gnatprep keywords.
 322             end t)
 323       (cond
 324        ((match-beginning 1)
 325         (put-text-property
 326          (match-beginning 1) (match-end 1) 'syntax-table '(11 . ?\n)))
 327        )
 328       )))
 329
 330 ;;;; support for xref tools
 331 (defun ada-gnat-file-name-from-ada-name (ada-name)
 332   "For `ada-file-name-from-ada-name'."
 333   (let ((result nil))
 334
 335     (while (string-match "\\." ada-name)
 336       (setq ada-name (replace-match "-" t t ada-name)))
 337
 338     (setq ada-name (downcase ada-name))
 339
 340     (with-current-buffer (gnat-run-buffer)
 341       (gnat-run-no-prj
 342        (list
 343         "krunch"
 344         ada-name
 345         ;; "0" means only krunch GNAT library names
 346         "0"))
 347
 348       (goto-char (point-min))
 349       (forward-line 1); skip  cmd
 350       (setq result (buffer-substring-no-properties (line-beginning-position) (line-end-position)))
 351       )
 352     result))
 353
 354 (defconst ada-gnat-predefined-package-alist
 355   '(("a-textio" . "Ada.Text_IO")
 356     ("a-chahan" . "Ada.Characters.Handling")
 357     ("a-comlin" . "Ada.Command_Line")
 358     ("a-except" . "Ada.Exceptions")
 359     ("a-numeri" . "Ada.Numerics")
 360     ("a-string" . "Ada.Strings")
 361     ("a-strmap" . "Ada.Strings.Maps")
 362     ("a-strunb" . "Ada.Strings.Unbounded")
 363     ("g-comlin" . "GNAT.Command_Line")
 364     ("g-dirope" . "GNAT.Directory_Operations")
 365     ("g-socket" . "GNAT.Sockets")
 366     ("interfac" . "Interfaces")
 367     ("i-c"      . "Interfaces.C")
 368     ("i-cstrin" . "Interfaces.C.Strings")
 369     ("s-stoele" . "System.Storage_Elements")
 370     ("unchconv" . "Unchecked_Conversion") ; Ada 83 name
 371     )
 372   "Alist (filename . package name) of GNAT file names for predefined Ada packages.")
 373
 374 (defun ada-gnat-ada-name-from-file-name (file-name)
 375   "For `ada-ada-name-from-file-name'."
 376   (let* (status
 377          (ada-name (file-name-sans-extension (file-name-nondirectory file-name)))
 378         (predefined (cdr (assoc ada-name ada-gnat-predefined-package-alist))))
 379
 380     (if predefined
 381         predefined
 382       (while (string-match "-" ada-name)
 383         (setq ada-name (replace-match "." t t ada-name)))
 384       ada-name)))
 385
 386 (defun ada-gnat-make-package-body (body-file-name)
 387   "For `ada-make-package-body'."
 388   ;; WORKAROUND: gnat stub 7.1w does not accept aggregate project files,
 389   ;; and doesn't use the gnatstub package if it is in a 'with'd
 390   ;; project file; see AdaCore ticket LC30-001. On the other hand we
 391   ;; need a project file to specify the source dirs so the tree file
 392   ;; can be generated. So we use gnat-run-no-prj, and the user
 393   ;; must specify the proper project file in gnat_stub_opts.
 394   ;;
 395   ;; gnatstub always creates the body in the current directory (in the
 396   ;; process where gnatstub is running); the -o parameter may not
 397   ;; contain path info. So we pass a directory to gnat-run-no-prj.
 398   (let ((start-buffer (current-buffer))
 399         (start-file (buffer-file-name))
 400         ;; can also specify gnat stub options/switches in .gpr file, in package 'gnatstub'.
 401         (opts (when (ada-prj-get 'gnat_stub_opts)
 402                 (split-string (ada-prj-get 'gnat_stub_opts))))
 403         (switches (when (ada-prj-get 'gnat_stub_switches)
 404                     (split-string (ada-prj-get 'gnat_stub_switches))))
 405         )
 406
 407     ;; Make sure all relevant files are saved to disk. This also saves
 408     ;; the bogus body buffer created by ff-find-the-other-file, so we
 409     ;; need -f gnat stub option. We won't get here if there is an
 410     ;; existing body file.
 411     (save-some-buffers t)
 412     (add-to-list 'opts "-f")
 413     (with-current-buffer (gnat-run-buffer)
 414       ;; FIXME: gnat-run-buffer requires a project, but we don't
 415       ;; actually need one. Just use a temp buffer. Same for other
 416       ;; uses of gnat-run-no-prj.
 417       (gnat-run-no-prj
 418        (append (list "stub") opts (list start-file "-cargs") switches)
 419        (file-name-directory body-file-name))
 420
 421       (find-file body-file-name)
 422       (indent-region (point-min) (point-max))
 423       (save-buffer)
 424       (set-buffer start-buffer)
 425       )
 426     nil))
 427
 428 (defun ada-gnat-syntax-propertize (start end)
 429   (goto-char start)
 430   (save-match-data
 431     (while (re-search-forward
 432             (concat
 433              "[^a-zA-Z0-9)]\\('\\)\\[[\"a-fA-F0-9]+\"\\]\\('\\)"; 1, 2: non-ascii character literal, not attributes
 434              "\\|\\(\\[\"[a-fA-F0-9]+\"\\]\\)"; 3: non-ascii character in identifier
 435              )
 436             end t)
 437       (cond
 438        ((match-beginning 1)
 439         (put-text-property
 440          (match-beginning 1) (match-end 1) 'syntax-table '(7 . ?'))
 441         (put-text-property
 442          (match-beginning 2) (match-end 2) 'syntax-table '(7 . ?')))
 443
 444        ((match-beginning 3)
 445         (put-text-property
 446          (match-beginning 3) (match-end 3) 'syntax-table '(2 . nil)))
 447        )
 448       )))
 449
 450 (provide 'gnat-core)
 451
 452 ;; end of file