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