;; ada-xref.el --- for lookup and completion in Ada mode
-;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 1994-2011 Free Software Foundation, Inc.
;; Author: Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de>
;; Rolf Ebert <ebert@inf.enst.fr>
;; Emmanuel Briot <briot@gnat.com>
;; Maintainer: Stephen Leake <stephen_leake@stephe-leake.org>
;; Keywords: languages ada xref
+;; Package: ada-mode
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; 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, or (at your option)
-;; any later version.
+;; 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
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; This Package provides a set of functions to use the output of the
:type 'boolean :group 'ada)
(defcustom ada-xref-confirm-compile nil
- "*Non-nil means ask for confirmation before compiling or running the application."
+ "*If non-nil, ask for confirmation before compiling or running the application."
:type 'boolean :group 'ada)
(defcustom ada-krunch-args "0"
Set to 0, if you don't use crunched filenames. This should be a string."
:type 'string :group 'ada)
+(defcustom ada-gnat-cmd "gnat"
+ "Default GNAT project file parser.
+Will be run with args \"list -v -Pfile.gpr\".
+Default is standard GNAT distribution; alternate \"gnatpath\"
+is faster, available from Ada mode web site."
+ :type 'string :group 'ada)
+
(defcustom ada-gnatls-args '("-v")
"*Arguments to pass to `gnatls' to find location of the runtime.
Typical use is to pass `--RTS=soft-floats' on some systems that support it.
"Default options for `gnatmake'."
:type 'string :group 'ada)
+(defcustom ada-prj-default-gpr-file ""
+ "Default GNAT project file.
+If non-empty, this file is parsed to set the source and object directories for
+the Ada mode project."
+ :type 'string :group 'ada)
+
+(defcustom ada-prj-ada-project-path-sep
+ (cond ((boundp 'path-separator) path-separator) ; 20.3+
+ ((memq system-type '(windows-nt ms-dos)) ";")
+ (t ":"))
+ "Default separator for ada_project_path project variable."
+ :type 'string :group 'ada)
+
(defcustom ada-prj-gnatfind-switches "-rf"
"Default switches to use for `gnatfind'.
You should modify this variable, for instance to add `-a', if you are working
:type 'string :group 'ada)
(defcustom ada-prj-default-make-cmd
- (concat "${cross_prefix}gnatmake -o ${main} ${main_unit} ${gnatmake_opt} "
+ (concat "${cross_prefix}gnatmake -o ${main} ${main} ${gnatmake_opt} "
"-cargs ${comp_opt} -bargs ${bind_opt} -largs ${link_opt}")
"*Default command to be used to compile the application.
This is the same syntax as in the project file."
:type '(file :must-match t) :group 'ada)
(defcustom ada-gnatstub-opts "-q -I${src_dir}"
- "*List of the options to pass to `gnatsub' to generate the body of a package.
+ "*Options to pass to `gnatsub' to generate the body of a package.
This has the same syntax as in the project file (with variable substitution)."
:type 'string :group 'ada)
Otherwise, ask the user for the name of the project file to use."
:type 'boolean :group 'ada)
-(defconst is-windows (memq system-type (quote (windows-nt)))
+(defconst ada-on-ms-windows (memq system-type '(windows-nt))
"True if we are running on Windows.")
(defcustom ada-tight-gvd-integration nil
On Windows systems using `cmdproxy.exe' as the shell,
we need to use `/d' or the drive is never changed.")
-(defvar ada-command-separator (if is-windows " && " "\n")
+(defvar ada-command-separator (if ada-on-ms-windows " && " "\n")
"Separator to use between multiple commands to `compile' or `start-process'.
`cmdproxy.exe' doesn't recognize multiple-line commands, so we have to use
\"&&\" for now.")
It has the format: (project project ...)
A project has the format: (project-file . project-plist)
\(See 'apropos plist' for operations on property lists).
-See `ada-xref-set-default-prj-values' for the list of valid properties.
+See `ada-default-prj-properties' for the list of valid properties.
The current project is retrieved with `ada-xref-current-project'.
Properties are retrieved with `ada-xref-get-project-field', set with
`ada-xref-set-project-field'. If project properties are accessed with no
(defun ada-find-executable (exec-name)
"Find the full path to the executable file EXEC-NAME.
-On Windows systems, this will properly handle .exe extension as well"
- (or (ada-find-file-in-dir exec-name exec-path)
- (ada-find-file-in-dir (concat exec-name ".exe") exec-path)
- exec-name))
+If not found, throw an error.
+On Windows systems, this will properly handle .exe extension as well."
+ (let ((result (or (ada-find-file-in-dir exec-name exec-path)
+ (ada-find-file-in-dir (concat exec-name ".exe") exec-path))))
+ (if result
+ result
+ (error "'%s' not found in path" exec-name))))
(defun ada-initialize-runtime-library (cross-prefix)
"Initialize the variables for the runtime library location.
CROSS-PREFIX is the prefix to use for the `gnatls' command."
- (save-excursion
- (setq ada-xref-runtime-library-specs-path '()
- ada-xref-runtime-library-ali-path '())
- (set-buffer (get-buffer-create "*gnatls*"))
- (widen)
- (erase-buffer)
- ;; Catch any error in the following form (i.e gnatls was not found)
- (condition-case nil
- ;; Even if we get an error, delete the *gnatls* buffer
- (unwind-protect
- (progn
- (let ((gnatls
- (ada-find-executable (concat cross-prefix "gnatls"))))
- (apply 'call-process gnatls (append '(nil t nil) ada-gnatls-args)))
- (goto-char (point-min))
-
- ;; Source path
-
- (search-forward "Source Search Path:")
- (forward-line 1)
- (while (not (looking-at "^$"))
- (back-to-indentation)
- (if (looking-at "<Current_Directory>")
- (add-to-list 'ada-xref-runtime-library-specs-path ".")
- (add-to-list 'ada-xref-runtime-library-specs-path
- (buffer-substring-no-properties
- (point)
- (save-excursion (end-of-line) (point)))))
- (forward-line 1))
-
- ;; Object path
-
- (search-forward "Object Search Path:")
- (forward-line 1)
- (while (not (looking-at "^$"))
- (back-to-indentation)
- (if (looking-at "<Current_Directory>")
- (add-to-list 'ada-xref-runtime-library-ali-path ".")
- (add-to-list 'ada-xref-runtime-library-ali-path
- (buffer-substring-no-properties
- (point)
- (save-excursion (end-of-line) (point)))))
- (forward-line 1))
- )
- (kill-buffer nil))
- (error nil))
+ (let ((gnatls
+ (condition-case nil
+ ;; if gnatls not found, just give up (may not be using GNAT)
+ (ada-find-executable (concat cross-prefix "gnatls"))
+ (error nil))))
+ (if gnatls
+ (save-excursion
+ (setq ada-xref-runtime-library-specs-path '()
+ ada-xref-runtime-library-ali-path '())
+ (set-buffer (get-buffer-create "*gnatls*"))
+ (widen)
+ (erase-buffer)
+ ;; Even if we get an error, delete the *gnatls* buffer
+ (unwind-protect
+ (let ((status (apply 'call-process gnatls (append '(nil t nil) ada-gnatls-args))))
+ (goto-char (point-min))
+
+ ;; Since we didn't provide all the inputs gnatls expects, it returns status 4
+ (if (/= 4 status)
+ (error (buffer-substring (point) (line-end-position))))
+
+ ;; Source path
+
+ (search-forward "Source Search Path:")
+ (forward-line 1)
+ (while (not (looking-at "^$"))
+ (back-to-indentation)
+ (if (looking-at "<Current_Directory>")
+ (add-to-list 'ada-xref-runtime-library-specs-path ".")
+ (add-to-list 'ada-xref-runtime-library-specs-path
+ (buffer-substring-no-properties
+ (point)
+ (point-at-eol))))
+ (forward-line 1))
+
+ ;; Object path
+
+ (search-forward "Object Search Path:")
+ (forward-line 1)
+ (while (not (looking-at "^$"))
+ (back-to-indentation)
+ (if (looking-at "<Current_Directory>")
+ (add-to-list 'ada-xref-runtime-library-ali-path ".")
+ (add-to-list 'ada-xref-runtime-library-ali-path
+ (buffer-substring-no-properties
+ (point)
+ (point-at-eol))))
+ (forward-line 1))
+ )
+ (kill-buffer nil))))
+
(set 'ada-xref-runtime-library-specs-path
(reverse ada-xref-runtime-library-specs-path))
(set 'ada-xref-runtime-library-ali-path
(reverse ada-xref-runtime-library-ali-path))
))
+(defun ada-gnat-parse-gpr (plist gpr-file)
+ "Set gpr_file, src_dir and obj_dir properties in PLIST by parsing GPR-FILE.
+Return new value of PLIST.
+GPR_FILE must be full path to file, normalized.
+src_dir, obj_dir will include compiler runtime.
+Assumes environment variable ADA_PROJECT_PATH is set properly."
+ (with-current-buffer (get-buffer-create "*gnatls*")
+ (erase-buffer)
+
+ ;; this can take a long time; let the user know what's up
+ (message "Parsing %s ..." gpr-file)
+
+ ;; Even if we get an error, delete the *gnatls* buffer
+ (unwind-protect
+ (let* ((cross-prefix (plist-get plist 'cross_prefix))
+ (gnat (concat cross-prefix ada-gnat-cmd))
+ ;; Putting quotes around gpr-file confuses gnatpath on Lynx; not clear why
+ (gpr-opt (concat "-P" gpr-file))
+ (src-dir '())
+ (obj-dir '())
+ (status (call-process gnat nil t nil "list" "-v" gpr-opt)))
+ (goto-char (point-min))
+
+ (if (/= 0 status)
+ (error (buffer-substring (point) (line-end-position))))
+
+ ;; Source path
+
+ (search-forward "Source Search Path:")
+ (forward-line 1) ; first directory in list
+ (while (not (looking-at "^$")) ; terminate on blank line
+ (back-to-indentation) ; skip whitespace
+ (add-to-list 'src-dir
+ (if (looking-at "<Current_Directory>")
+ default-directory
+ (expand-file-name
+ (buffer-substring-no-properties
+ (point) (line-end-position)))))
+ (forward-line 1))
+
+ ;; Object path
+
+ (search-forward "Object Search Path:")
+ (forward-line 1)
+ (while (not (looking-at "^$"))
+ (back-to-indentation)
+ (add-to-list 'obj-dir
+ (if (looking-at "<Current_Directory>")
+ default-directory
+ (expand-file-name
+ (buffer-substring-no-properties
+ (point) (line-end-position)))))
+ (forward-line 1))
+
+ ;; Set properties
+ (setq plist (plist-put plist 'gpr_file gpr-file))
+ (setq plist (plist-put plist 'src_dir src-dir))
+ (plist-put plist 'obj_dir obj-dir)
+ )
+ (kill-buffer nil)
+ (message "Parsing %s ... done" gpr-file)
+ )
+ ))
+
(defun ada-treat-cmd-string (cmd-string)
- "Replace meta-sequences like ${...} in CMD-STRING with the appropriate value.
+ "Replace variable references ${var} in CMD-STRING with the appropriate value.
+Also replace standard environment variables $var.
Assumes project exists.
As a special case, ${current} is replaced with the name of the current
file, minus extension but with directory, and ${full_current} is
(mapconcat (lambda(x) (concat prefix x)) value " ")
t t cmd-string)))))
))
- cmd-string)
+ (substitute-in-file-name cmd-string))
-(defun ada-xref-set-default-prj-values (symbol ada-buffer)
- "Reset the properties in SYMBOL to the default values for ADA-BUFFER."
-
- (let ((file (buffer-file-name ada-buffer))
- plist)
- (save-excursion
- (set-buffer ada-buffer)
-
- (set 'plist
- ;; Try hard to find a project file, even if the current
- ;; buffer is not an Ada file or not associated with a file
- (list 'filename (expand-file-name
- (cond
- (ada-prj-default-project-file
- ada-prj-default-project-file)
- (file (ada-prj-find-prj-file file t))
- (t
- (message (concat "Not editing an Ada file,"
- "and no default project "
- "file specified!"))
- "")))
- 'build_dir (file-name-as-directory (expand-file-name "."))
- 'src_dir (list ".")
- 'obj_dir (list ".")
- 'casing (if (listp ada-case-exception-file)
- ada-case-exception-file
- (list ada-case-exception-file))
- 'comp_opt ada-prj-default-comp-opt
- 'bind_opt ada-prj-default-bind-opt
- 'link_opt ada-prj-default-link-opt
- 'gnatmake_opt ada-prj-default-gnatmake-opt
- 'gnatfind_opt ada-prj-gnatfind-switches
- 'main (if file
- (file-name-nondirectory
- (file-name-sans-extension file))
- "")
- 'main_unit (if file
- (file-name-nondirectory
- (file-name-sans-extension file))
- "")
- 'cross_prefix ""
- 'remote_machine ""
- 'comp_cmd (list ada-prj-default-comp-cmd)
- 'check_cmd (list ada-prj-default-check-cmd)
- 'make_cmd (list ada-prj-default-make-cmd)
- 'run_cmd (list (concat "./${main}" (if is-windows ".exe")))
- 'debug_pre_cmd (list (concat ada-cd-command " ${build_dir}"))
- 'debug_cmd (concat ada-prj-default-debugger
- " ${main}" (if is-windows ".exe"))
- 'debug_post_cmd (list nil)))
- )
- (set symbol plist)))
(defun ada-xref-get-project-field (field)
"Extract the value of FIELD from the current project file.
which will in addition return the default paths."
(let* ((project-plist (cdr (ada-xref-current-project)))
- value)
+ (value (plist-get project-plist field)))
- (set 'value (plist-get project-plist field))
+ (cond
+ ((eq field 'gnatmake_opt)
+ (let ((gpr-file (plist-get project-plist 'gpr_file)))
+ (if (not (string= gpr-file ""))
+ (setq value (concat "-P\"" gpr-file "\" " value)))))
+
+ ;; FIXME: check for src_dir, obj_dir here, rather than requiring user to do it
+ (t
+ nil))
- ;; Substitute the ${...} constructs in all the strings, including
- ;; inside lists
+ ;; Substitute the ${...} constructs in all the strings, including
+ ;; inside lists
(cond
((stringp value)
(ada-treat-cmd-string value))
["New..." ada-prj-new t]
["Edit..." ada-prj-edit t]
"---"
- ;; Add the new items
+ ;; Add the project files
,@(mapcar
(lambda (x)
- (let ((name (or (car x) "<default>"))
- (command `(lambda ()
- "Change the active project file."
- (interactive)
- (ada-parse-prj-file ,(car x))
- (set 'ada-prj-default-project-file ,(car x))
- (ada-xref-update-project-menu))))
+ (let* ((name (or (car x) "<default>"))
+ (command `(lambda ()
+ "Select the current project file."
+ (interactive)
+ (ada-select-prj-file ,name))))
(vector
- (if (string= (file-name-extension name)
- ada-prj-file-extension)
- (file-name-sans-extension
- (file-name-nondirectory name))
- (file-name-nondirectory name))
+ (file-name-nondirectory name)
command
:button (cons
:toggle
(car x))
))))
- ;; Parses all the known project files, and insert at
- ;; least the default one (in case
- ;; ada-xref-project-files is nil)
(or ada-xref-project-files '(nil))))))
(easy-menu-add-item ada-mode-menu '() submenu)))
(defun ada-do-file-completion (string predicate flag)
"Completion function when reading a file from the minibuffer.
-Completion is attempted in all the directories in the source path, as
-defined in the project file."
+Completion is attempted in all the directories in the source path,
+as defined in the project file."
;; FIXME: doc arguments
;; This function is not itself interactive, but it is called as part
(defun ada-require-project-file ()
"If the current project does not exist, load or create a default one.
Should only be called from interactive functions."
- (if (not (ada-xref-current-project t))
- (ada-reread-prj-file)))
+ (if (string= "" ada-prj-default-project-file)
+ (ada-reread-prj-file (ada-prj-find-prj-file t))))
-(defun ada-xref-current-project-file (&optional no-user-question)
- "Return the current project file name; never nil unless NO-USER-QUESTION.
-If NO-USER-QUESTION, don't prompt user for file. Call
-`ada-require-project-file' first if a project must exist."
+(defun ada-xref-current-project-file ()
+ "Return the current project file name; never nil.
+Call `ada-require-project-file' first if a project must exist."
(if (not (string= "" ada-prj-default-project-file))
ada-prj-default-project-file
- (ada-prj-find-prj-file nil no-user-question)))
+ (ada-prj-find-prj-file t)))
-(defun ada-xref-current-project (&optional no-user-question)
- "Return the current project; nil if none.
-If NO-USER-QUESTION, don't prompt user for file. Call
-`ada-require-project-file' first if a project must exist."
- (let* ((file-name (ada-xref-current-project-file no-user-question)))
+(defun ada-xref-current-project ()
+ "Return the current project.
+Call `ada-require-project-file' first to ensure a project exists."
+ (let ((file-name (ada-xref-current-project-file)))
(assoc file-name ada-xref-project-files)))
(defun ada-show-current-project ()
(message (ada-xref-current-project-file)))
(defun ada-show-current-main ()
- "Display current main unit name in message buffer."
+ "Display current main file name in message buffer."
(interactive)
- (message "ada-mode main_unit: %s" (ada-xref-get-project-field 'main_unit)))
+ (message "ada-mode main: %s" (ada-xref-get-project-field 'main)))
(defun ada-xref-push-pos (filename position)
"Push (FILENAME, POSITION) on the position ring for cross-references."
name)
;; FIXME: use convert-standard-filename instead
-(defun ada-set-default-project-file (name &optional keep-existing)
- "Set the file whose name is NAME as the default project file.
-If KEEP-EXISTING is true and a project file has already been loaded, nothing
-is done. This is meant to be used from `ada-mode-hook', for instance, to force
-a project file unless the user has already loaded one."
+(defun ada-set-default-project-file (file)
+ "Set FILE as the current project file."
(interactive "fProject file:")
- (if (or (not keep-existing)
- (not ada-prj-default-project-file)
- (equal ada-prj-default-project-file ""))
- (progn
- (setq ada-prj-default-project-file name)
- (ada-reread-prj-file name))))
+ (ada-parse-prj-file file)
+ (ada-select-prj-file file))
;; ------ Handling the project file -----------------------------
-(defun ada-prj-find-prj-file (&optional file no-user-question)
- "Find the project file associated with FILE (or the current buffer if nil).
+(defun ada-prj-find-prj-file (&optional no-user-question)
+ "Find the project file associated with the current buffer.
If the buffer is not in Ada mode, or not associated with a file,
return `ada-prj-default-project-file'. Otherwise, search for a file with
the same base name as the Ada file, but extension given by
(let (selected)
(if (not (and (derived-mode-p 'ada-mode)
- buffer-file-name))
+ buffer-file-name))
;; Not in an Ada buffer, or current buffer not associated
;; with a file (for instance an emerge buffer)
-
- (if (and ada-prj-default-project-file
- (not (string= ada-prj-default-project-file "")))
- (setq selected ada-prj-default-project-file)
- (setq selected nil))
+ (setq selected nil)
;; other cases: use a more complex algorithm
- (let* ((current-file (or file (buffer-file-name)))
+ (let* ((current-file (buffer-file-name))
(first-choice (concat
(file-name-sans-extension current-file)
ada-prj-file-extension))
(or selected "default.adp")
))
+(defun ada-default-prj-properties ()
+ "Return the default project properties list with the current buffer as main."
+
+ (let ((file (buffer-file-name nil)))
+ (list
+ ;; variable name alphabetical order
+ 'ada_project_path (or (getenv "ADA_PROJECT_PATH") "")
+ 'ada_project_path_sep ada-prj-ada-project-path-sep
+ 'bind_opt ada-prj-default-bind-opt
+ 'build_dir default-directory
+ 'casing (if (listp ada-case-exception-file)
+ ada-case-exception-file
+ (list ada-case-exception-file))
+ 'check_cmd (list ada-prj-default-check-cmd) ;; FIXME: should not a list
+ 'comp_cmd (list ada-prj-default-comp-cmd) ;; FIXME: should not a list
+ 'comp_opt ada-prj-default-comp-opt
+ 'cross_prefix ""
+ 'debug_cmd (concat ada-prj-default-debugger
+ " ${main}" (if ada-on-ms-windows ".exe")) ;; FIXME: don't need .exe?
+ 'debug_post_cmd (list nil)
+ 'debug_pre_cmd (list (concat ada-cd-command " ${build_dir}"))
+ 'gnatmake_opt ada-prj-default-gnatmake-opt
+ 'gnatfind_opt ada-prj-gnatfind-switches
+ 'gpr_file ada-prj-default-gpr-file
+ 'link_opt ada-prj-default-link-opt
+ 'main (if file
+ (file-name-nondirectory
+ (file-name-sans-extension file))
+ "")
+ 'make_cmd (list ada-prj-default-make-cmd) ;; FIXME: should not a list
+ 'obj_dir (list ".")
+ 'remote_machine ""
+ 'run_cmd (list (concat "./${main}" (if ada-on-ms-windows ".exe")))
+ ;; FIXME: should not a list
+ ;; FIXME: don't need .exe?
+ 'src_dir (list ".")
+ )))
(defun ada-parse-prj-file (prj-file)
- "Read PRJ-FILE, set it as the active project."
- ;; FIXME: doc nil, search, etc.
- (if prj-file
- (let (project src_dir obj_dir make_cmd comp_cmd check_cmd casing
- run_cmd debug_pre_cmd debug_post_cmd
- (ada-buffer (current-buffer)))
- (setq prj-file (expand-file-name prj-file))
-
- ;; Set the project file as the active one.
- (setq ada-prj-default-project-file prj-file)
-
- ;; Initialize the project with the default values
- (ada-xref-set-default-prj-values 'project (current-buffer))
-
- ;; Do not use find-file below, since we don't want to show this
- ;; buffer. If the file is open through speedbar, we can't use
- ;; find-file anyway, since the speedbar frame is special and does not
- ;; allow the selection of a file in it.
-
- (if (file-exists-p prj-file)
- (progn
- (let* ((buffer (run-hook-with-args-until-success
- 'ada-load-project-hook prj-file)))
- (unless buffer
- (setq buffer (find-file-noselect prj-file nil)))
- (set-buffer buffer))
-
- (widen)
- (goto-char (point-min))
-
- ;; Now overrides these values with the project file
- (while (not (eobp))
- (if (looking-at "^\\([^=]+\\)=\\(.*\\)")
- (cond
- ;; fields that are lists or paths require special processing
- ;; FIXME: strip trailing spaces
- ((string= (match-string 1) "src_dir")
- (add-to-list 'src_dir
- (file-name-as-directory (match-string 2))))
- ((string= (match-string 1) "obj_dir")
- (add-to-list 'obj_dir
- (file-name-as-directory (match-string 2))))
- ((string= (match-string 1) "casing")
- (set 'casing (cons (match-string 2) casing)))
- ((string= (match-string 1) "build_dir")
- (set 'project
- (plist-put project 'build_dir
- (file-name-as-directory (match-string 2)))))
- ((string= (match-string 1) "make_cmd")
- (add-to-list 'make_cmd (match-string 2)))
- ((string= (match-string 1) "comp_cmd")
- (add-to-list 'comp_cmd (match-string 2)))
- ((string= (match-string 1) "check_cmd")
- (add-to-list 'check_cmd (match-string 2)))
- ((string= (match-string 1) "run_cmd")
- (add-to-list 'run_cmd (match-string 2)))
- ((string= (match-string 1) "debug_pre_cmd")
- (add-to-list 'debug_pre_cmd (match-string 2)))
- ((string= (match-string 1) "debug_post_cmd")
- (add-to-list 'debug_post_cmd (match-string 2)))
- (t
- ;; any other field in the file is just copied
- (set 'project (plist-put project (intern (match-string 1))
- (match-string 2))))))
- (forward-line 1))
-
- (if src_dir (set 'project (plist-put project 'src_dir
- (reverse src_dir))))
- (if obj_dir (set 'project (plist-put project 'obj_dir
- (reverse obj_dir))))
- (if casing (set 'project (plist-put project 'casing
- (reverse casing))))
- (if make_cmd (set 'project (plist-put project 'make_cmd
- (reverse make_cmd))))
- (if comp_cmd (set 'project (plist-put project 'comp_cmd
- (reverse comp_cmd))))
- (if check_cmd (set 'project (plist-put project 'check_cmd
- (reverse check_cmd))))
- (if run_cmd (set 'project (plist-put project 'run_cmd
- (reverse run_cmd))))
- (if debug_post_cmd (set 'project (plist-put project 'debug_post_cmd
- (reverse debug_post_cmd))))
- (if debug_pre_cmd (set 'project (plist-put project 'debug_pre_cmd
- (reverse debug_pre_cmd))))
-
- (set-buffer ada-buffer)
- )
+ "Read PRJ-FILE, set project properties in `ada-xref-project-files'."
+ (let ((project (ada-default-prj-properties)))
- ;; Else the file wasn't readable (probably the default project).
- ;; We initialize it with the current environment variables.
- ;; We need to add the startup directory in front so that
- ;; files locally redefined are properly found. We cannot
- ;; add ".", which varies too much depending on what the
- ;; current buffer is.
- (set 'project
- (plist-put project 'src_dir
- (append
- (list command-line-default-directory)
- (split-string (or (getenv "ADA_INCLUDE_PATH") "") ":")
- (list "." default-directory))))
- (set 'project
- (plist-put project 'obj_dir
- (append
- (list command-line-default-directory)
- (split-string (or (getenv "ADA_OBJECTS_PATH") "") ":")
- (list "." default-directory))))
- )
+ (setq prj-file (expand-file-name prj-file))
+ (if (string= (file-name-extension prj-file) "gpr")
+ (set 'project (ada-gnat-parse-gpr project prj-file))
+ (set 'project (ada-parse-prj-file-1 prj-file project))
+ )
- ;; Delete the default project file from the list, if it is there.
- ;; Note that in that case, this default project is the only one in
- ;; the list
- (if (assoc nil ada-xref-project-files)
- (setq ada-xref-project-files nil))
+ ;; Store the project properties
+ (if (assoc prj-file ada-xref-project-files)
+ (setcdr (assoc prj-file ada-xref-project-files) project)
+ (add-to-list 'ada-xref-project-files (cons prj-file project)))
- ;; Memorize the newly read project file
- (if (assoc prj-file ada-xref-project-files)
- (setcdr (assoc prj-file ada-xref-project-files) project)
- (add-to-list 'ada-xref-project-files (cons prj-file project)))
+ (ada-xref-update-project-menu)
+ ))
- ;; Sets up the compilation-search-path so that Emacs is able to
- ;; go to the source of the errors in a compilation buffer
- (setq compilation-search-path (ada-xref-get-src-dir-field))
+(defun ada-parse-prj-file-1 (prj-file project)
+ "Parse the Ada mode project file PRJ-FILE, set project properties in PROJECT.
+Return new value of PROJECT."
+ (let ((ada-buffer (current-buffer))
+ ;; fields that are lists or otherwise require special processing
+ ada_project_path casing comp_cmd check_cmd
+ debug_pre_cmd debug_post_cmd gpr_file make_cmd obj_dir src_dir run_cmd)
+
+ ;; Give users a chance to use compiler-specific project file formats
+ (let ((buffer (run-hook-with-args-until-success
+ 'ada-load-project-hook prj-file)))
+ (unless buffer
+ ;; we load the project file with no warnings; if it does not
+ ;; exist, we stay in the Ada buffer; no project variable
+ ;; settings will be found. That works for the default
+ ;; "default.adp", which does not exist as a file.
+ (setq buffer (find-file-noselect prj-file nil)))
+ (set-buffer buffer))
- ;; Set the casing exceptions file list
- (if casing
- (progn
- (setq ada-case-exception-file (reverse casing))
- (ada-case-read-exceptions)))
+ (widen)
+ (goto-char (point-min))
- ;; Add the directories to the search path for ff-find-other-file
- ;; Do not add the '/' or '\' at the end
- (setq ada-search-directories-internal
- (append (mapcar 'directory-file-name compilation-search-path)
- ada-search-directories))
+ ;; process each line
+ (while (not (eobp))
- (ada-xref-update-project-menu)
- )
+ ;; ignore lines that don't have the format "name=value", put
+ ;; 'name', 'value' in match-string.
+ (if (looking-at "^\\([^=\n]+\\)=\\(.*\\)")
+ (cond
+ ;; FIXME: strip trailing spaces
+ ;; variable name alphabetical order
+ ((string= (match-string 1) "ada_project_path")
+ (add-to-list 'ada_project_path
+ (expand-file-name
+ (substitute-in-file-name (match-string 2)))))
+
+ ((string= (match-string 1) "build_dir")
+ (set 'project
+ (plist-put project 'build_dir
+ (file-name-as-directory (match-string 2)))))
+
+ ((string= (match-string 1) "casing")
+ (add-to-list 'casing
+ (expand-file-name (substitute-in-file-name (match-string 2)))))
+
+ ((string= (match-string 1) "check_cmd")
+ (add-to-list 'check_cmd (match-string 2)))
+
+ ((string= (match-string 1) "comp_cmd")
+ (add-to-list 'comp_cmd (match-string 2)))
+
+ ((string= (match-string 1) "debug_post_cmd")
+ (add-to-list 'debug_post_cmd (match-string 2)))
+
+ ((string= (match-string 1) "debug_pre_cmd")
+ (add-to-list 'debug_pre_cmd (match-string 2)))
+
+ ((string= (match-string 1) "gpr_file")
+ ;; expand now; path is relative to Emacs project file
+ (setq gpr_file (expand-file-name (match-string 2))))
+
+ ((string= (match-string 1) "make_cmd")
+ (add-to-list 'make_cmd (match-string 2)))
+
+ ((string= (match-string 1) "obj_dir")
+ (add-to-list 'obj_dir
+ (file-name-as-directory
+ (expand-file-name (match-string 2)))))
+
+ ((string= (match-string 1) "run_cmd")
+ (add-to-list 'run_cmd (match-string 2)))
- ;; No prj file ? => Setup default values
- ;; Note that nil means that all compilation modes will first look in the
- ;; current directory, and only then in the current file's directory. This
- ;; current file is assumed at this point to be in the common source
- ;; directory.
- (setq compilation-search-path (list nil default-directory))
+ ((string= (match-string 1) "src_dir")
+ (add-to-list 'src_dir
+ (file-name-as-directory
+ (expand-file-name (match-string 2)))))
+
+ (t
+ ;; any other field in the file is just copied
+ (set 'project (plist-put project
+ (intern (match-string 1))
+ (match-string 2))))))
+
+ (forward-line 1))
+
+ ;; done reading file
+
+ ;; back to the user buffer
+ (set-buffer ada-buffer)
+
+ ;; process accumulated lists
+ (if ada_project_path
+ (let ((sep (plist-get project 'ada_project_path_sep)))
+ (setq ada_project_path (reverse ada_project_path))
+ (setq ada_project_path (mapconcat 'identity ada_project_path sep))
+ (set 'project (plist-put project 'ada_project_path ada_project_path))
+ ;; env var needed now for ada-gnat-parse-gpr
+ (setenv "ADA_PROJECT_PATH" ada_project_path)))
+
+ (if debug_post_cmd (set 'project (plist-put project 'debug_post_cmd (reverse debug_post_cmd))))
+ (if debug_pre_cmd (set 'project (plist-put project 'debug_pre_cmd (reverse debug_pre_cmd))))
+ (if casing (set 'project (plist-put project 'casing (reverse casing))))
+ (if check_cmd (set 'project (plist-put project 'check_cmd (reverse check_cmd))))
+ (if comp_cmd (set 'project (plist-put project 'comp_cmd (reverse comp_cmd))))
+ (if make_cmd (set 'project (plist-put project 'make_cmd (reverse make_cmd))))
+ (if run_cmd (set 'project (plist-put project 'run_cmd (reverse run_cmd))))
+
+ (if gpr_file
+ (progn
+ (set 'project (ada-gnat-parse-gpr project gpr_file))
+ ;; append Ada source and object directories to others from Emacs project file
+ (setq src_dir (append (plist-get project 'src_dir) src_dir))
+ (setq obj_dir (append (plist-get project 'obj_dir) obj_dir))
+ (setq ada-xref-runtime-library-specs-path '()
+ ada-xref-runtime-library-ali-path '()))
+ )
+
+ ;; FIXME: gnatpath.exe doesn't output the runtime libraries, so always call ada-initialize-runtime-library
+ ;; if using a gpr_file, the runtime library directories are
+ ;; included in src_dir and obj_dir; otherwise they are in the
+ ;; 'runtime-library' variables.
+ ;; FIXME: always append to src_dir, obj_dir
+ (ada-initialize-runtime-library (or (ada-xref-get-project-field 'cross_prefix) ""))
+ ;;)
+
+ (if obj_dir (set 'project (plist-put project 'obj_dir (reverse obj_dir))))
+ (if src_dir (set 'project (plist-put project 'src_dir (reverse src_dir))))
+
+ project
))
+(defun ada-select-prj-file (file)
+ "Select FILE as the current project file."
+ (interactive)
+ (setq ada-prj-default-project-file (expand-file-name file))
+
+ (let ((casing (ada-xref-get-project-field 'casing)))
+ (if casing
+ (progn
+ ;; FIXME: use ada-get-absolute-dir here
+ (setq ada-case-exception-file casing)
+ (ada-case-read-exceptions))))
+
+ (let ((ada_project_path (ada-xref-get-project-field 'ada_project_path)))
+ (if ada_project_path
+ ;; FIXME: use ada-get-absolute-dir, mapconcat here
+ (setenv "ADA_PROJECT_PATH" ada_project_path)))
+
+ (setq compilation-search-path (ada-xref-get-src-dir-field))
+
+ (setq ada-search-directories-internal
+ ;; FIXME: why do we need directory-file-name here?
+ (append (mapcar 'directory-file-name compilation-search-path)
+ ada-search-directories))
+
+ ;; return 't', for decent display in message buffer when called interactively
+ t)
(defun ada-find-references (&optional pos arg local-only)
"Find all references to the entity under POS.
Calls gnatfind to find the references.
-If ARG is t, the contents of the old *gnatfind* buffer is preserved.
-If LOCAL-ONLY is t, only the declarations in the current file are returned."
+If ARG is non-nil, the contents of the old *gnatfind* buffer is preserved.
+If LOCAL-ONLY is non-nil, only declarations in the current file are returned."
(interactive "d\nP")
(ada-require-project-file)
(defun ada-find-local-references (&optional pos arg)
"Find all references to the entity under POS.
Calls `gnatfind' to find the references.
-If ARG is t, the contents of the old *gnatfind* buffer is preserved."
+If ARG is non-nil, the contents of the old *gnatfind* buffer is preserved."
(interactive "d\nP")
(ada-find-references pos arg t))
(entity &optional file line column local-only append)
"Search for references to any entity whose name is ENTITY.
ENTITY was first found the location given by FILE, LINE and COLUMN.
-If LOCAL-ONLY is t, then list only the references in FILE, which
-is much faster.
-If APPEND is t, then append the output of the command to the existing
-buffer `*gnatfind*', if there is one."
+If LOCAL-ONLY is non-nil, then list only the references in FILE,
+which is much faster.
+If APPEND is non-nil, then append the output of the command to the
+existing buffer `*gnatfind*', if there is one."
(interactive "sEntity name: ")
(ada-require-project-file)
;; processed (gnatfind \"+\":...).
(let* ((quote-entity
(if (= (aref entity 0) ?\")
- (if is-windows
+ (if ada-on-ms-windows
(concat "\\\"" (substring entity 1 -1) "\\\"")
(concat "'\"" (substring entity 1 -1) "\"'"))
entity))
(switches (ada-xref-get-project-field 'gnatfind_opt))
- (command (concat "gnat find " switches " "
+ ;; FIXME: use gpr_file
+ (cross-prefix (ada-xref-get-project-field 'cross_prefix))
+ (command (concat cross-prefix "gnat find " switches " "
quote-entity
(if file (concat ":" (file-name-nondirectory file)))
(if line (concat ":" line))
(not (string= ada-prj-default-project-file "")))
(if (string-equal (file-name-extension ada-prj-default-project-file)
"gpr")
- (setq command (concat command " -P" ada-prj-default-project-file))
- (setq command (concat command " -p" ada-prj-default-project-file))))
+ (setq command (concat command " -P\"" ada-prj-default-project-file "\""))
+ (setq command (concat command " -p\"" ada-prj-default-project-file "\""))))
(if (and append (get-buffer ada-gnatfind-buffer-name))
- (save-excursion
- (set-buffer "*gnatfind*")
+ (with-current-buffer "*gnatfind*"
(setq old-contents (buffer-string))))
(let ((compilation-error "reference"))
(compilation-start command 'compilation-mode (lambda (mode) ada-gnatfind-buffer-name)))
;; Hide the "Compilation" menu
- (save-excursion
- (set-buffer ada-gnatfind-buffer-name)
+ (with-current-buffer ada-gnatfind-buffer-name
(local-unset-key [menu-bar compilation-menu])
(if old-contents
(defun ada-get-absolute-dir-list (dir-list root-dir)
"Return the list of absolute directories found in DIR-LIST.
-If a directory is a relative directory, ROOT-DIR is prepended."
- (mapcar (lambda (x) (expand-file-name x root-dir)) dir-list))
+If a directory is a relative directory, ROOT-DIR is prepended.
+Project and environment variables are substituted."
+ (mapcar (lambda (x) (expand-file-name x (ada-treat-cmd-string root-dir))) dir-list))
(defun ada-set-environment ()
"Prepare an environment for Ada compilation.
(compile (ada-quote-cmd cmd))))
(defun ada-set-main-compile-application ()
- "Set main_unit and main project variables to current buffer, build main."
+ "Set main project variable to current buffer, build main."
(interactive)
(ada-require-project-file)
(let* ((file (buffer-file-name (current-buffer)))
(file-name-sans-extension file))
""))
(ada-xref-set-project-field 'main main)
- (ada-xref-set-project-field 'main_unit main)
(ada-compile-application))))
(defun ada-compile-current (&optional arg prj-field)
"Recompile the current file.
-If ARG is not nil, ask for user confirmation of the command.
+If ARG is non-nil, ask for user confirmation of the command.
PRJ-FIELD is the name of the field to use in the project file to get the
command, and should be either `comp_cmd' (default) or `check_cmd'."
(interactive "P")
(process-environment (ada-set-environment))
(compilation-scroll-output t))
- (setq compilation-search-path (ada-xref-get-src-dir-field))
-
(unless cmd
(setq cmd '("") arg t))
(defun ada-check-current (&optional arg)
"Check the current file for syntax errors.
-If ARG is not nil, ask for user confirmation of the command."
+If ARG is non-nil, ask for user confirmation of the command."
(interactive "P")
(ada-compile-current arg 'check_cmd))
(defun ada-run-application (&optional arg)
"Run the application.
-if ARG is not-nil, ask for user confirmation."
+If ARG is non-nil, ask for user confirmation."
(interactive)
(ada-require-project-file)
command)))
;; Run the command
- (save-excursion
- (set-buffer (get-buffer-create "*run*"))
+ (with-current-buffer (get-buffer-create "*run*")
(set 'buffer-read-only nil)
(erase-buffer)
)))
(defun ada-reread-prj-file (&optional filename)
- "Reread either the current project, or FILENAME if non-nil."
+ "Reread either the current project, or FILENAME if non-nil.
+If FILENAME is non-nil, set it as current project."
(interactive "P")
- (if filename
- (ada-parse-prj-file filename)
- (ada-parse-prj-file (ada-prj-find-prj-file)))
-
- ;; Reread the location of the standard runtime library
- (ada-initialize-runtime-library
- (or (ada-xref-get-project-field 'cross_prefix) ""))
- )
+ (if (not filename)
+ (setq filename ada-prj-default-project-file))
+ (ada-parse-prj-file filename)
+ (ada-select-prj-file filename))
;; ------ Private routines
(ada-find-file-in-dir file (ada-xref-get-src-dir-field)))
(defun ada-get-ali-file-name (file)
- "Create the ali file name for the ada-file FILE.
+ "Create the ali file name for the Ada file FILE.
The file is searched for in every directory shown in the obj_dir lines of
the project file."
;; the 'D' lines. This is done repeatedly, in case the direct parent is
;; also a separate.
- (save-excursion
- (set-buffer (get-file-buffer file))
+ (with-current-buffer (get-file-buffer file)
(let ((short-ali-file-name
(concat (file-name-sans-extension (file-name-nondirectory file))
".ali"))
(progn
(kill-buffer ali-buffer)
- (error "No declaration of %s found." (ada-name-of identlist))
+ (error "No declaration of %s found" (ada-name-of identlist))
)))
)
(beginning-of-line)
(if declaration-found
(let ((current-line (buffer-substring
- (point) (save-excursion (end-of-line) (point)))))
+ (point) (point-at-eol))))
(save-excursion
(forward-line 1)
(beginning-of-line)
(ada-name-of identlist)))
;; one => should be the right one
((= len 1)
- (goto-line (caar declist)))
+ (goto-char (point-min))
+ (forward-line (1- (caar declist))))
;; more than one => display choice list
(t
(read-from-minibuffer "Enter No. of your choice: "))))
)
(set-buffer ali-buffer)
- (goto-line (car (nth (1- choice) declist)))
+ (goto-char (point-min))
+ (forward-line (1- (car (nth (1- choice) declist))))
))))))
choice
file)
- (save-excursion
-
- ;; Do the grep in all the directories. We do multiple shell
- ;; commands instead of one in case there is no .ali file in one
- ;; of the directory and the shell stops because of that.
+ ;; Do the grep in all the directories. We do multiple shell
+ ;; commands instead of one in case there is no .ali file in one
+ ;; of the directory and the shell stops because of that.
- (set-buffer (get-buffer-create "*grep*"))
+ (with-current-buffer (get-buffer-create "*grep*")
(while dirs
(insert (shell-command-to-string
(concat
(defun ada-xref-change-buffer
(file line column identlist &optional other-frame)
"Select and display FILE, at LINE and COLUMN.
-If we do not end on the same identifier as IDENTLIST, find the closest
-match. Kills the .ali buffer at the end.
+If we do not end on the same identifier as IDENTLIST, find the
+closest match. Kills the .ali buffer at the end.
If OTHER-FRAME is non-nil, creates a new frame to show the file."
(let (declaration-buffer)
;; move the cursor to the correct position
(push-mark)
- (goto-line line)
+ (goto-char (point-min))
+ (forward-line (1- line))
(move-to-column column)
;; If we are not on the identifier, the ali file was not up-to-date.
(unit-name nil)
(body-name nil)
(ali-name nil))
- (save-excursion
- (set-buffer buffer)
+ (with-current-buffer buffer
(goto-char (point-min))
(re-search-forward "^U \\([^ \t%]+\\)%[bs][ \t]+\\([^ \t]+\\)")
(setq unit-name (match-string 1))
(defun ada-make-filename-from-adaname (adaname)
"Determine the filename in which ADANAME is found.
This is a GNAT specific function that uses gnatkrunch."
- (let (krunch-buf)
- (setq krunch-buf (generate-new-buffer "*gkrunch*"))
- (save-excursion
- (set-buffer krunch-buf)
+ (let ((krunch-buf (generate-new-buffer "*gkrunch*"))
+ (cross-prefix (plist-get (cdr (ada-xref-current-project)) 'cross_prefix)))
+ (with-current-buffer krunch-buf
;; send adaname to external process `gnatkr'.
;; Add a dummy extension, since gnatkr versions have two different
;; behaviors depending on the version:
;; Up to 3.15: "AA.BB.CC" => aa-bb-cc
;; After: "AA.BB.CC" => aa-bb.cc
- (call-process "gnatkr" nil krunch-buf nil
+ (call-process (concat cross-prefix "gnatkr") nil krunch-buf nil
(concat adaname ".adb") ada-krunch-args)
;; fetch output of that process
(setq adaname (buffer-substring
(defun ada-make-body-gnatstub (&optional interactive)
"Create an Ada package body in the current buffer.
-This function uses the `gnatstub' program to create the body.
-If INTERACTIVE is nil, kill the current buffer.
-This function typically is to be hooked into `ff-file-created-hook'."
+This function uses the `gnat stub' program to create the body.
+This function typically is to be hooked into `ff-file-created-hook'.
+If INTERACTIVE is nil, assume this is called from `ff-file-created-hook'."
(interactive "p")
(ada-require-project-file)
- (save-some-buffers nil nil)
-
- ;; If the current buffer is the body (as is the case when calling this
- ;; function from ff-file-created-hook), then kill this temporary buffer
+ ;; If not interactive, assume we are being called from
+ ;; ff-file-created-hook. Then the current buffer is for the body
+ ;; file, but we will create a new one after gnat stub runs
(unless interactive
(set-buffer-modified-p nil)
(kill-buffer (current-buffer)))
+ (save-some-buffers nil nil)
- ;; Make sure the current buffer is the spec (this might not be the case
- ;; if for instance the user was asked for a project file)
+ ;; Make sure the current buffer is the spec, so gnat stub gets the
+ ;; right package parameter (this might not be the case if for
+ ;; instance the user was asked for a project file)
(unless (buffer-file-name (car (buffer-list)))
(set-buffer (cadr (buffer-list))))
- ;; Call the external process gnatstub
- (let* ((gnatstub-opts (ada-treat-cmd-string ada-gnatstub-opts))
+ ;; Call the external process
+ (let* ((project-plist (cdr (ada-xref-current-project)))
+ (gnatstub-opts (ada-treat-cmd-string ada-gnatstub-opts))
+ (gpr-file (plist-get project-plist 'gpr_file))
(filename (buffer-file-name (car (buffer-list))))
(output (concat (file-name-sans-extension filename) ".adb"))
- (gnatstub-cmd (concat "gnatstub " gnatstub-opts " " filename))
- (buffer (get-buffer-create "*gnatstub*")))
-
- (save-excursion
- (set-buffer buffer)
+ (cross-prefix (plist-get project-plist 'cross_prefix))
+ (gnatstub-cmd (concat cross-prefix "gnat stub"
+ (if (not (string= gpr-file ""))
+ (concat " -P\"" gpr-file "\""))
+ " " gnatstub-opts " " filename))
+ (buffer (get-buffer-create "*gnat stub*")))
+
+ (with-current-buffer buffer
(compilation-minor-mode 1)
(erase-buffer)
(insert gnatstub-cmd)
(newline)
)
- ;; call gnatstub to create the body file
- (call-process shell-file-name nil buffer nil "-c" gnatstub-cmd)
- (if (save-excursion
- (set-buffer buffer)
- (goto-char (point-min))
- (search-forward "command not found" nil t))
- (progn
- (message "gnatstub was not found -- using the basic algorithm")
- (sleep-for 2)
- (kill-buffer buffer)
- (ada-make-body))
+ (call-process shell-file-name nil buffer nil "-c" gnatstub-cmd)
- ;; Else clean up the output
+ ;; clean up the output
- (if (file-exists-p output)
- (progn
- (find-file output)
- (kill-buffer buffer))
+ (if (file-exists-p output)
+ (progn
+ (find-file output)
+ (kill-buffer buffer))
- ;; display the error buffer
- (display-buffer buffer)
- )
- )))
+ ;; file not created; display the error message
+ (display-buffer buffer))))
(defun ada-xref-initialize ()
"Function called by `ada-mode-hook' to initialize the ada-xref.el package.
'error-message
"File not found in src-dir (check project file): ")
-;; Initializes the cross references to the runtime library
-(ada-initialize-runtime-library "")
-
-;; Add these standard directories to the search path
-(set 'ada-search-directories-internal
- (append (mapcar 'directory-file-name ada-xref-runtime-library-specs-path)
- ada-search-directories))
-
(provide 'ada-xref)
-;; arch-tag: 415a39fe-577b-4676-b3b1-6ff6db7ca24e
;;; ada-xref.el ends here
HCoop / bpt / emacs.git / blobdiff