[gnu-emacs-elpa] / packages / ada-mode / gnat-core.el

;; Support for running GNAT tools, which support multiple programming
;; languages.
;;
;; GNAT is provided by AdaCore; see http://libre.adacore.com/
;;
;;; Copyright (C) 2012, 2013  Free Software Foundation, Inc.
;;
;; Author: Stephen Leake <stephen_leake@member.fsf.org>
;; Maintainer: Stephen Leake <stephen_leake@member.fsf.org>
;;
;; This file is part of GNU Emacs.
;;
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;; We use cl-delete-if, defined in cl-seq.el. cl-seq.el has no
;; 'provide'.  autoload for cl-delete-if is defined in cl-loaddefs.el,
;; which is not pre-loaded.  cl-lib does (load "cl-loaddefs.el"), so
;; that seems to be the thing to do
(require 'cl-lib)

;;;;; code

;;;; project file handling

(defun gnat-prj-add-prj-dir (dir project)
  "Add DIR to 'prj_dir and to GPR_PROJECT_PATH in 'proc_env. Return new project."
  (let ((prj-dir (plist-get project 'prj_dir)))

    (cond
     ((listp prj-dir)
        (add-to-list 'prj-dir dir))

     (prj-dir
      (setq prj-dir (list dir)))

     (t nil))

    (setq project (plist-put project 'prj_dir prj-dir))

    (let ((process-environment (plist-get project 'proc_env)))
      (setenv "GPR_PROJECT_PATH"
              (mapconcat 'identity
                         (plist-get project 'prj_dir)
                         (plist-get project 'path_sep)))

      (setq project (plist-put project 'proc_env process-environment))
      )

    project))

(defun gnat-prj-parse-emacs-one (name value project)
  "Handle gnat-specific Emacs Ada project file settings.
Return new PROJECT if NAME recognized, nil otherwise.
See also `gnat-parse-emacs-final'."
  (let ((process-environment (plist-get project 'proc_env))); for substitute-in-file-name
    (cond
     ((or
       ;; we allow either name here for backward compatibility
       (string= name "gpr_project_path")
       (string= name "ada_project_path"))
      ;; We maintain two project values for this;
      ;; 'prj_dir - a list of directories, for gpr-ff-special-with
      ;; GPR_PROJECT_PATH in 'proc_env, for gnat-run
      (gnat-prj-add-prj-dir (expand-file-name (substitute-in-file-name value)) project))

     ((string= (match-string 1) "gpr_file")
      ;; The file is parsed in `gnat-parse-emacs-prj-file-final', so
      ;; it can add to user-specified src_dir.
      (setq project
            (plist-put project
                       'gpr_file
                       (expand-file-name (substitute-in-file-name value))))
      project)
     )))

(defun gnat-prj-parse-emacs-final (project)
  "Final processing of gnat-specific Emacs Ada project file settings."
  (when (buffer-live-p (get-buffer (gnat-run-buffer-name)))
    (kill-buffer (gnat-run-buffer-name))); things may have changed, force re-create

  (if (ada-prj-get 'gpr_file project)
      (set 'project (gnat-parse-gpr (ada-prj-get 'gpr_file project) project))

    ;; add the compiler libraries to src_dir
    (setq project (gnat-get-paths project))
    )

  project)

(defun gnat-get-paths (project)
  "Add project and/or compiler source, object paths to PROJECT src_dir and/or prc_dir."
  (with-current-buffer (gnat-run-buffer)
    ;; gnat list -v -P can return status 0 or 4; always lists compiler dirs
    (let ((src-dirs (ada-prj-get 'src_dir project))
          (prj-dirs (ada-prj-get 'prj_dir project)))

      (gnat-run-gnat "list" (list "-v") '(0 4))

      (goto-char (point-min))

      (condition-case nil
          (progn
            ;; Source path
            (search-forward "Source Search Path:")
            (forward-line 1)
            (while (not (looking-at "^$")) ; terminate on blank line
              (back-to-indentation) ; skip whitespace forward
              (if (looking-at "<Current_Directory>")
                  (add-to-list 'src-dirs  (directory-file-name default-directory))
                (add-to-list 'src-dirs
                             (expand-file-name ; canonicalize path part
                              (directory-file-name
                               (buffer-substring-no-properties (point) (point-at-eol))))))
              (forward-line 1))

            ;; Project path
            ;;
            ;; These are also added to src_dir, so compilation errors
            ;; reported in project files are found.
            (search-forward "Project Search Path:")
            (forward-line 1)
            (while (not (looking-at "^$"))
              (back-to-indentation)
              (if (looking-at "<Current_Directory>")
                  (add-to-list 'prj-dirs ".")
                (add-to-list 'prj-dirs
                             (expand-file-name
                              (buffer-substring-no-properties (point) (point-at-eol))))
                (add-to-list 'src-dirs
                             (expand-file-name
                              (buffer-substring-no-properties (point) (point-at-eol)))))
              (forward-line 1))

            )
        ('error
         (pop-to-buffer (current-buffer))
         ;; search-forward failed
         (error "parse gpr failed")
         ))

      (setq project (plist-put project 'src_dir (reverse src-dirs)))
      (mapc (lambda (dir) (gnat-prj-add-prj-dir dir project))
            (reverse prj-dirs))
      ))
  project)

(defun gnat-parse-gpr (gpr-file project)
  "Append to src_dir and prj_dir in PROJECT by parsing GPR-FILE.
Return new value of PROJECT.
GPR-FILE must be full path to file, normalized.
src_dir will include compiler runtime."
  ;; this can take a long time; let the user know what's up
  (message "Parsing %s ..." gpr-file)

  (if (ada-prj-get 'gpr_file project)
      ;; gpr-file defined in Emacs Ada mode project file
      (when (not (equal gpr-file (ada-prj-get 'gpr_file project)))
        (error "Ada project file %s defines a different GNAT project file than %s"
               ada-prj-current-file
               gpr-file))

    ;; gpr-file is top level Ada mode project file
    (setq project (plist-put project 'gpr_file gpr-file))
    )

  (setq project (gnat-get-paths project))

  (message "Parsing %s ... done" gpr-file)
  project)

;;;; command line tool interface

(defun gnat-run-buffer-name (&optional prefix)
  (concat (or prefix " *gnat-run-")
          (or (ada-prj-get 'gpr_file)
              ada-prj-current-file)
          "*"))

(defun gnat-run-buffer (&optional buffer-name-prefix)
  "Return a buffer suitable for running gnat command line tools for the current project."
  (ada-require-project-file)
  (let* ((name (gnat-run-buffer-name buffer-name-prefix))
         (buffer (get-buffer name)))
    (if buffer
        buffer
      (setq buffer (get-buffer-create name))
      (with-current-buffer buffer
        (setq default-directory
              (file-name-directory
               (or (ada-prj-get 'gpr_file)
                   ada-prj-current-file)))
        )
      buffer)))

(defun gnat-run (exec command &optional err-msg expected-status)
  "Run a gnat command line tool, as \"EXEC COMMAND\".
EXEC must be an executable found on `exec-path'. COMMAND must be a list of strings.
ERR-MSG must be nil or a string.
EXPECTED-STATUS must be nil or a list of integers.
Return process status.
Assumes current buffer is (gnat-run-buffer)"
  (set 'buffer-read-only nil)
  (erase-buffer)

  (setq command (cl-delete-if 'null command))

  (let ((process-environment (ada-prj-get 'proc_env)) ;; for GPR_PROJECT_PATH
        status)

    (insert (format "GPR_PROJECT_PATH=%s\n%s " (getenv "GPR_PROJECT_PATH") exec)); for debugging
    (mapc (lambda (str) (insert (concat str " "))) command); for debugging
    (newline)

    (setq status (apply 'call-process exec nil t nil command))
    (cond
     ((memq status (or expected-status '(0))); success
      nil)

     (t ; failure
      (pop-to-buffer (current-buffer))
      (if err-msg
          (error "%s %s failed; %s" exec (car command) err-msg)
        (error "%s %s failed" exec (car command))
        ))
     )))

(defun gnat-run-gnat (command &optional switches-args expected-status)
  "Run the \"gnat\" command line tool, as \"gnat COMMAND -P<prj> SWITCHES-ARGS\".
COMMAND must be a string, SWITCHES-ARGS a list of strings.
EXPECTED-STATUS must be nil or a list of integers.
Return process status.
Assumes current buffer is (gnat-run-buffer)"
  (let* ((project-file-switch
          (when (ada-prj-get 'gpr_file)
            (concat "-P" (file-name-nondirectory (ada-prj-get 'gpr_file)))))
         (cmd (append (list command) (list project-file-switch) switches-args)))

    (gnat-run "gnat" cmd nil expected-status)
    ))

(defun gnat-run-no-prj (command &optional dir)
  "Run the gnat command line tool, as \"gnat COMMAND\", with DIR as current directory.
Return process status.  Assumes current buffer
is (gnat-run-buffer)"
  (set 'buffer-read-only nil)
  (erase-buffer)

  (setq command (cl-delete-if 'null command))
  (mapc (lambda (str) (insert (concat str " "))) command)
  (newline)

  (let ((default-directory (or dir default-directory))
        status)

    (setq status (apply 'call-process "gnat" nil t nil command))
    (cond
     ((= status 0); success
      nil)

     (t ; failure
      (pop-to-buffer (current-buffer))
      (error "gnat %s failed" (car command)))
     )))

;;;; gnatprep utils

(defun gnatprep-indent ()
  "If point is on a gnatprep keyword, return indentation column
for it. Otherwise return nil.  Intended to be added to
`wisi-indent-calculate-functions' or other indentation function
list."
  ;; gnatprep keywords are:
  ;;
  ;; #if identifier [then]
  ;; #elsif identifier [then]
  ;; #else
  ;; #end if;
  ;;
  ;; they are all indented at column 0.
  (when (equal (char-after) ?\#) 0))

(defun gnatprep-syntax-propertize (start end)
  (goto-char start)
  (while (re-search-forward
          "^[ \t]*\\(#\\(?:if\\|else\\|elsif\\|end\\)\\)"; gnatprep keywords.
          end t)
    (cond
     ((match-beginning 1)
      (put-text-property
       (match-beginning 1) (match-end 1) 'syntax-table '(11 . ?\n)))
     )
    ))

;;;; support for ada-gnat-xref and ada-gnatinspect
(defun ada-gnat-file-name-from-ada-name (ada-name)
  "For `ada-file-name-from-ada-name'."
  (let ((result nil))

    (while (string-match "\\." ada-name)
      (setq ada-name (replace-match "-" t t ada-name)))

    (setq ada-name (downcase ada-name))

    (with-current-buffer (gnat-run-buffer)
      (gnat-run-no-prj
       (list
        "krunch"
        ada-name
        ;; "0" means only krunch GNAT library names
        "0"))

      (goto-char (point-min))
      (forward-line 1); skip  cmd
      (setq result (buffer-substring-no-properties (line-beginning-position) (line-end-position)))
      )
    result))

(defconst ada-gnat-predefined-package-alist
  '(("a-textio" . "Ada.Text_IO")
    ("a-chahan" . "Ada.Characters.Handling")
    ("a-comlin" . "Ada.Command_Line")
    ("a-except" . "Ada.Exceptions")
    ("a-numeri" . "Ada.Numerics")
    ("a-string" . "Ada.Strings")
    ("a-strmap" . "Ada.Strings.Maps")
    ("a-strunb" . "Ada.Strings.Unbounded")
    ("g-socket" . "GNAT.Sockets")
    ("interfac" . "Interfaces")
    ("i-c"      . "Interfaces.C")
    ("i-cstrin" . "Interfaces.C.Strings")
    ("s-stoele" . "System.Storage_Elements")
    ("unchconv" . "Unchecked_Conversion") ; Ada 83 name
    )
  "Alist (filename . package name) of GNAT file names for predefined Ada packages.")

(defun ada-gnat-ada-name-from-file-name (file-name)
  "For `ada-ada-name-from-file-name'."
  (let* (status
         (ada-name (file-name-sans-extension (file-name-nondirectory file-name)))
        (predefined (cdr (assoc ada-name ada-gnat-predefined-package-alist))))

    (if predefined
        predefined
      (while (string-match "-" ada-name)
        (setq ada-name (replace-match "." t t ada-name)))
      ada-name)))

(defun ada-gnat-make-package-body (body-file-name)
  "For `ada-make-package-body'."
  ;; WORKAROUND: gnat stub 7.1w does not accept aggregate project files,
  ;; and doesn't use the gnatstub package if it is in a 'with'd
  ;; project file; see AdaCore ticket LC30-001. On the other hand we
  ;; need a project file to specify the source dirs so the tree file
  ;; can be generated. So we use gnat-run-no-prj, and the user
  ;; must specify the proper project file in gnat_stub_opts.
  ;;
  ;; gnatstub always creates the body in the current directory (in the
  ;; process where gnatstub is running); the -o parameter may not
  ;; contain path info. So we pass a directory to gnat-run-no-prj.
  (let ((start-buffer (current-buffer))
        (start-file (buffer-file-name))
        ;; can also specify gnat stub options/switches in .gpr file, in package 'gnatstub'.
        (opts (when (ada-prj-get 'gnat_stub_opts)
                (split-string (ada-prj-get 'gnat_stub_opts))))
        (switches (when (ada-prj-get 'gnat_stub_switches)
                    (split-string (ada-prj-get 'gnat_stub_switches))))
        )

    ;; Make sure all relevant files are saved to disk. This also saves
    ;; the bogus body buffer created by ff-find-the-other-file, so we
    ;; need -f gnat stub option. We won't get here if there is an
    ;; existing body file.
    (save-some-buffers t)
    (add-to-list 'opts "-f")
    (with-current-buffer (gnat-run-buffer)
      (gnat-run-no-prj
       (append (list "stub") opts (list start-file "-cargs") switches)
       (file-name-directory body-file-name))

      (find-file body-file-name)
      (indent-region (point-min) (point-max))
      (save-buffer)
      (set-buffer start-buffer)
      )
    nil))

(provide 'gnat-core)

;; end of file