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