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

   1 ;; gnat-core.el --- Support for running GNAT tools, which support multiple programming  -*- lexical-binding:t -*-
   2 ;; languages.
   3 ;;
   4 ;; GNAT is provided by AdaCore; see http://libre.adacore.com/
   5 ;;
   6 ;;; Copyright (C) 2012 - 2015  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       (cl-pushnew dir prj-dir :test #'equal))
  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-show-path ()
  60   "For `ada-prj-show-path'."
  61     (interactive)
  62   (if (ada-prj-get 'prj_dir)
  63       (progn
  64         (pop-to-buffer (get-buffer-create "*GNAT project search path*"))
  65         (erase-buffer)
  66         (dolist (file (ada-prj-get 'prj_dir))
  67           (insert (format "%s\n" file))))
  68     (message "no GNAT project search path files")
  69     ))
  70
  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
  76     (cond
  77      ((or
  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))
  85
  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.
  89       (setq project
  90             (plist-put project
  91                        'gpr_file
  92                        (expand-file-name (substitute-in-file-name value))))
  93       project)
  94      )))
  95
  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
 100
 101   (if (ada-prj-get 'gpr_file project)
 102       (setq project (gnat-parse-gpr (ada-prj-get 'gpr_file project) project))
 103
 104     ;; add the compiler libraries to src_dir
 105     (setq project (gnat-get-paths project))
 106     )
 107
 108   project)
 109
 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
 115     ;;
 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))
 121
 122     (goto-char (point-min))
 123
 124     (condition-case nil
 125         (progn
 126           ;; Source path
 127           (search-forward "Source Search Path:")
 128           (forward-line 1)
 129           (while (not (looking-at "^$")) ; terminate on blank line
 130             (back-to-indentation) ; skip whitespace forward
 131             (cl-pushnew
 132              (if (looking-at "<Current_Directory>")
 133                  (directory-file-name default-directory)
 134                (expand-file-name ; Canonicalize path part.
 135                 (directory-file-name
 136                  (buffer-substring-no-properties (point) (point-at-eol)))))
 137              src-dirs
 138              :test #'equal)
 139             (forward-line 1))
 140
 141           ;; Project path
 142           ;;
 143           ;; These are also added to src_dir, so compilation errors
 144           ;; reported in project files are found.
 145           (search-forward "Project Search Path:")
 146           (forward-line 1)
 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)))
 155             (forward-line 1))
 156
 157           )
 158       (error
 159        (pop-to-buffer (current-buffer))
 160        ;; search-forward failed
 161        (error "parse gpr failed")
 162        ))
 163     (list src-dirs prj-dirs)))
 164
 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)))
 169
 170     ;; FIXME: use a dispatching function instead, with autoload, to
 171     ;; avoid "require" here, which gives "warning: function not
 172     ;; known".
 173     ;; Using 'require' at top level gives the wrong default ada-xref-tool
 174     (cl-ecase (ada-prj-get 'xref_tool project)
 175       (gnat
 176        (let ((res (gnat-get-paths-1 src-dirs prj-dirs)))
 177          (setq src-dirs (car res))
 178          (setq prj-dirs (cadr res))))
 179
 180       (gpr_query
 181        (when (ada-prj-get 'gpr_file)
 182          (require 'gpr-query)
 183          (setq src-dirs (gpr-query-get-src-dirs src-dirs))
 184          (setq prj-dirs (gpr-query-get-prj-dirs prj-dirs))))
 185       )
 186
 187     (setq project (plist-put project 'src_dir (reverse src-dirs)))
 188     (mapc (lambda (dir) (gnat-prj-add-prj-dir dir project))
 189           (reverse prj-dirs))
 190     )
 191   project)
 192
 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)
 200
 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"
 205                ada-prj-current-file
 206                gpr-file))
 207
 208     ;; gpr-file is top level Ada mode project file
 209     (setq project (plist-put project 'gpr_file gpr-file))
 210     )
 211
 212   (setq project (gnat-get-paths project))
 213
 214   (message "Parsing %s ... done" gpr-file)
 215   project)
 216
 217 ;;;; command line tool interface
 218
 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)
 223           "*"))
 224
 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)))
 230     (if buffer
 231         buffer
 232       (setq buffer (get-buffer-create name))
 233       (with-current-buffer buffer
 234         (setq default-directory
 235               (file-name-directory
 236                (or (ada-prj-get 'gpr_file)
 237                    ada-prj-current-file)))
 238         )
 239       buffer)))
 240
 241 (defun ada-gnat-show-run-buffer ()
 242   (interactive)
 243   (pop-to-buffer (gnat-run-buffer)))
 244
 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.
 252
 253 Return process status.
 254 Assumes current buffer is (gnat-run-buffer)"
 255   (set 'buffer-read-only nil)
 256   (erase-buffer)
 257
 258   (setq command (cl-delete-if 'null command))
 259
 260   (let ((process-environment (ada-prj-get 'proc_env)) ;; for GPR_PROJECT_PATH
 261         status)
 262
 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
 265     (newline)
 266
 267     (setq status (apply 'call-process exec nil t nil command))
 268     (cond
 269      ((memq status (or expected-status '(0))); success
 270       nil)
 271
 272      (t ; failure
 273       (pop-to-buffer (current-buffer))
 274       (if err-msg
 275           (error "%s %s failed; %s" exec (car command) err-msg)
 276         (error "%s %s failed" exec (car command))
 277         ))
 278      )))
 279
 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)))
 290
 291     (gnat-run "gnat" cmd nil expected-status)
 292     ))
 293
 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)
 299   (erase-buffer)
 300
 301   (setq command (cl-delete-if 'null command))
 302   (mapc (lambda (str) (insert (concat str " "))) command)
 303   (newline)
 304
 305   (let ((default-directory (or dir default-directory))
 306         status)
 307
 308     (setq status (apply 'call-process "gnat" nil t nil command))
 309     (cond
 310      ((= status 0); success
 311       nil)
 312
 313      (t ; failure
 314       (pop-to-buffer (current-buffer))
 315       (error "gnat %s failed" (car command)))
 316      )))
 317
 318 ;;;; gnatprep utils
 319
 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
 324 list."
 325   ;; gnatprep keywords are:
 326   ;;
 327   ;; #if identifier [then]
 328   ;; #elsif identifier [then]
 329   ;; #else
 330   ;; #end if;
 331   ;;
 332   ;; they are all indented at column 0.
 333   (when (equal (char-after) ?\#) 0))
 334
 335 (defun gnatprep-syntax-propertize (start end)
 336   (goto-char start)
 337   (save-match-data
 338     (while (re-search-forward
 339             "^[ \t]*\\(#\\(?:if\\|else\\|elsif\\|end\\)\\)"; gnatprep keywords.
 340             end t)
 341       (cond
 342        ((match-beginning 1)
 343         (put-text-property
 344          (match-beginning 1) (match-end 1) 'syntax-table '(11 . ?\n)))
 345        )
 346       )))
 347
 348 (defun gnatprep-setup ()
 349   (when (boundp 'wisi-indent-calculate-functions)
 350     (add-to-list 'wisi-indent-calculate-functions 'gnatprep-indent))
 351   )
 352
 353 ;;;; support for xref tools
 354 (defun ada-gnat-file-name-from-ada-name (ada-name)
 355   "For `ada-file-name-from-ada-name'."
 356   (let ((result nil))
 357
 358     (while (string-match "\\." ada-name)
 359       (setq ada-name (replace-match "-" t t ada-name)))
 360
 361     (setq ada-name (downcase ada-name))
 362
 363     (with-current-buffer (gnat-run-buffer)
 364       (gnat-run-no-prj
 365        (list
 366         "krunch"
 367         ada-name
 368         ;; "0" means only krunch GNAT library names
 369         "0"))
 370
 371       (goto-char (point-min))
 372       (forward-line 1); skip  cmd
 373       (setq result (buffer-substring-no-properties (line-beginning-position) (line-end-position)))
 374       )
 375     result))
 376
 377 (defconst ada-gnat-predefined-package-alist
 378   '(("a-textio" . "Ada.Text_IO")
 379     ("a-chahan" . "Ada.Characters.Handling")
 380     ("a-comlin" . "Ada.Command_Line")
 381     ("a-except" . "Ada.Exceptions")
 382     ("a-numeri" . "Ada.Numerics")
 383     ("a-string" . "Ada.Strings")
 384     ("a-strmap" . "Ada.Strings.Maps")
 385     ("a-strunb" . "Ada.Strings.Unbounded")
 386     ("g-comlin" . "GNAT.Command_Line")
 387     ("g-dirope" . "GNAT.Directory_Operations")
 388     ("g-socket" . "GNAT.Sockets")
 389     ("interfac" . "Interfaces")
 390     ("i-c"      . "Interfaces.C")
 391     ("i-cstrin" . "Interfaces.C.Strings")
 392     ("s-stoele" . "System.Storage_Elements")
 393     ("unchconv" . "Unchecked_Conversion") ; Ada 83 name
 394     )
 395   "Alist (filename . package name) of GNAT file names for predefined Ada packages.")
 396
 397 (defun ada-gnat-ada-name-from-file-name (file-name)
 398   "For `ada-ada-name-from-file-name'."
 399   (let* ((ada-name (file-name-sans-extension (file-name-nondirectory file-name)))
 400          (predefined (cdr (assoc ada-name ada-gnat-predefined-package-alist))))
 401
 402     (if predefined
 403         predefined
 404       (while (string-match "-" ada-name)
 405         (setq ada-name (replace-match "." t t ada-name)))
 406       ada-name)))
 407
 408 (defun ada-gnat-make-package-body (body-file-name)
 409   "For `ada-make-package-body'."
 410   ;; WORKAROUND: gnat stub 7.1w does not accept aggregate project files,
 411   ;; and doesn't use the gnatstub package if it is in a 'with'd
 412   ;; project file; see AdaCore ticket LC30-001. On the other hand we
 413   ;; need a project file to specify the source dirs so the tree file
 414   ;; can be generated. So we use gnat-run-no-prj, and the user
 415   ;; must specify the proper project file in gnat_stub_opts.
 416   ;;
 417   ;; gnatstub always creates the body in the current directory (in the
 418   ;; process where gnatstub is running); the -o parameter may not
 419   ;; contain path info. So we pass a directory to gnat-run-no-prj.
 420   (let ((start-buffer (current-buffer))
 421         (start-file (buffer-file-name))
 422         ;; can also specify gnat stub options/switches in .gpr file, in package 'gnatstub'.
 423         (opts (when (ada-prj-get 'gnat_stub_opts)
 424                 (split-string (ada-prj-get 'gnat_stub_opts))))
 425         (switches (when (ada-prj-get 'gnat_stub_switches)
 426                     (split-string (ada-prj-get 'gnat_stub_switches))))
 427         )
 428
 429     ;; Make sure all relevant files are saved to disk. This also saves
 430     ;; the bogus body buffer created by ff-find-the-other-file, so we
 431     ;; need -f gnat stub option. We won't get here if there is an
 432     ;; existing body file.
 433     (save-some-buffers t)
 434     (cl-pushnew "-f" opts :test #'equal)
 435     (with-current-buffer (gnat-run-buffer)
 436       (gnat-run-no-prj
 437        (append (list "stub") opts (list start-file "-cargs") switches)
 438        (file-name-directory body-file-name))
 439
 440       (find-file body-file-name)
 441       (indent-region (point-min) (point-max))
 442       (save-buffer)
 443       (set-buffer start-buffer)
 444       )
 445     nil))
 446
 447 (defun ada-gnat-syntax-propertize (start end)
 448   (goto-char start)
 449   (save-match-data
 450     (while (re-search-forward
 451             (concat
 452              "[^a-zA-Z0-9)]\\('\\)\\[[\"a-fA-F0-9]+\"\\]\\('\\)"; 1, 2: non-ascii character literal, not attributes
 453              "\\|\\(\\[\"[a-fA-F0-9]+\"\\]\\)"; 3: non-ascii character in identifier
 454              )
 455             end t)
 456       (cond
 457        ((match-beginning 1)
 458         (put-text-property
 459          (match-beginning 1) (match-end 1) 'syntax-table '(7 . ?'))
 460         (put-text-property
 461          (match-beginning 2) (match-end 2) 'syntax-table '(7 . ?')))
 462
 463        ((match-beginning 3)
 464         (put-text-property
 465          (match-beginning 3) (match-end 3) 'syntax-table '(2 . nil)))
 466        )
 467       )))
 468
 469 (provide 'gnat-core)
 470
 471 ;; end of file