X-Git-Url: https://code.delx.au/gnu-emacs-elpa/blobdiff_plain/829641e050c37aeecc2750de5eb0ba4e47d18971..6d5b40e20601bf41656f6055cceff664667af41c:/packages/ada-mode/gnat-core.el diff --git a/packages/ada-mode/gnat-core.el b/packages/ada-mode/gnat-core.el new file mode 100755 index 000000000..c6e597fe5 --- /dev/null +++ b/packages/ada-mode/gnat-core.el @@ -0,0 +1,400 @@ +;; 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 +;; Maintainer: Stephen Leake +;; +;; 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 . + +;; 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 "") + (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 "") + (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 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