-;;; ada-xref.el --- for lookup and completion in Ada mode
+;; ada-xref.el --- for lookup and completion in Ada mode
-;; Copyright (C) 1994, 95, 96, 97, 98, 99, 2000 Free Software Foundation, Inc.
+;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+;; 2004, 2005, 2006 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: Emmanuel Briot <briot@gnat.com>
-;; Ada Core Technologies's version: $Revision: 1.6 $
+;; Maintainer: Stephen Leake <stephen_leake@stephe-leake.org>
;; Keywords: languages ada xref
;; This file is part of GNU Emacs.
;; 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., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
;;; This Package provides a set of functions to use the output of the
;;; cross reference capabilities of the GNAT Ada compiler
;;; for lookup and completion in Ada mode.
;;;
-;;; The functions provided are the following ones :
-;;; - `ada-complete-identifier': completes the current identifier as much as
-;;; possible, depending of the known identifier in the unit
-;;; - `ada-point-and-xref': moves the mouse pointer and shows the declaration
-;;; of the selected identifier (either in the same buffer or in another
-;;; buffer
-;;; - `ada-goto-declaration': shows the declaration of the selected
-;;; identifier (the one under the cursor), either in the same buffer or in
-;;; another buffer
-;;; - `ada-goto-declaration-other-frame': same as previous, but opens a new
-;; frame to show the declaration
-;;; - `ada-compile-application': recompile your whole application, provided
-;;; that a project file exists in your directory
-;;; - `ada-run-application': run your application directly from Emacs
-;;; - `ada-reread-prj-file': force Emacs to read your project file again.
-;;; Otherwise, this file is only read the first time Emacs needs some
-;;; informations, which are then kept in memory
-;;; - `ada-change-prj': change the prj file associated with a buffer
-;;; - `ada-change-default-prj': change the default project file used for
-;;; every new buffer
-;;;
;;; If a file *.`adp' exists in the ada-file directory, then it is
-;;; read for configuration informations. It is read only the first
+;;; read for configuration informations. It is read only the first
;;; time a cross-reference is asked for, and is not read later.
;;; You need Emacs >= 20.2 to run this package
+
+;;; History:
+;;
+
;;; Code:
;; ----- Requirements -----------------------------------------------------
(require 'compile)
(require 'comint)
+(require 'find-file)
+(require 'ada-mode)
-;; ------ Use variables
+;; ------ User variables
(defcustom ada-xref-other-buffer t
"*If nil, always display the cross-references in the same buffer.
Otherwise create either a new buffer or a new frame."
:type 'boolean :group 'ada)
-(defcustom ada-xref-create-ali t
+(defcustom ada-xref-create-ali nil
"*If non-nil, run gcc whenever the cross-references are not up-to-date.
-If nil, the cross-reference mode will never run gcc."
+If nil, the cross-reference mode never runs gcc."
:type 'boolean :group 'ada)
(defcustom ada-xref-confirm-compile nil
- "*If non-nil, always ask for user confirmation before compiling or running
-the application."
+ "*Non-nil means ask for confirmation before compiling or running the application."
:type 'boolean :group 'ada)
(defcustom ada-krunch-args "0"
- "*Maximum number of characters for filenames created by gnatkr.
-Set to 0, if you don't use crunched filenames. This should be a string."
+ "*Maximum number of characters for filenames created by `gnatkr'.
+Set to 0, if you don't use crunched filenames. This should be a string."
:type 'string :group 'ada)
-(defcustom ada-prj-default-comp-opt "-gnatq"
+(defcustom ada-gnatls-args '("-v")
+ "*Arguments to pass to `gnatfind' to find location of the runtime.
+Typical use is to pass `--RTS=soft-floats' on some systems that support it.
+
+You can also add `-I-' if you do not want the current directory to be included.
+Otherwise, going from specs to bodies and back will first look for files in the
+current directory. This only has an impact if you are not using project files,
+but only ADA_INCLUDE_PATH."
+ :type '(repeat string) :group 'ada)
+
+(defcustom ada-prj-default-comp-opt "-gnatq -gnatQ"
"Default compilation options."
:type 'string :group 'ada)
:type 'string :group 'ada)
(defcustom ada-prj-default-gnatmake-opt "-g"
- "Default options for gnatmake."
+ "Default options for `gnatmake'."
+ :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
+in an environment where most ALI files are write-protected.
+The command `gnatfind' is used every time you choose the menu
+\"Show all references\"."
+ :type 'string :group 'ada)
+
+(defcustom ada-prj-default-check-cmd
+ (concat "${cross_prefix}gnatmake -u -c -gnatc ${gnatmake_opt} ${full_current}"
+ " -cargs ${comp_opt}")
+ "*Default command to be used to compile a single file.
+Emacs will substitute the current filename for ${full_current}, or add
+the filename at the end. This is the same syntax as in the project file."
:type 'string :group 'ada)
(defcustom ada-prj-default-comp-cmd
- "${cross_prefix}gcc -c ${comp_opt}"
+ (concat "${cross_prefix}gnatmake -u -c ${gnatmake_opt} ${full_current} -cargs"
+ " ${comp_opt}")
"*Default command to be used to compile a single file.
-Emacs will add the filename at the end of this command. This is the same
-syntax as in the project file."
+Emacs will substitute the current filename for ${full_current}, or add
+the filename at the end. This is the same syntax as in the project file."
:type 'string :group 'ada)
(defcustom ada-prj-default-debugger "${cross_prefix}gdb"
- "*Default name of the debugger. We recommend either `gdb',
-`gdb --emacs_gdbtk' or `ddd --tty -fullname'."
+ "*Default name of the debugger."
:type 'string :group 'ada)
(defcustom ada-prj-default-make-cmd
(concat "${cross_prefix}gnatmake -o ${main} ${main_unit} ${gnatmake_opt} "
- "-cargs ${comp_opt} -bargs ${bind_opt} -largs ${link_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 'string :group 'ada)
(defcustom ada-prj-default-project-file ""
- "*Name of the project file to use for every Ada file.
-Emacs will not try to use the standard algorithm to find the project file if
-this string is not empty."
+ "*Name of the current project file.
+Emacs will not try to use the search algorithm to find the project file if
+this string is not empty. It is set whenever a project file is found."
: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.
+ "*List of the 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)))
+ "True if we are running on Windows NT or Windows 95.")
+
+(defcustom ada-tight-gvd-integration nil
+ "*If non-nil, a new Emacs frame will be swallowed in GVD when debugging.
+If GVD is not the debugger used, nothing happens."
+ :type 'boolean :group 'ada)
+
+(defcustom ada-xref-search-with-egrep t
+ "*If non-nil, use egrep to find the possible declarations for an entity.
+This alternate method is used when the exact location was not found in the
+information provided by GNAT. However, it might be expensive if you have a lot
+of sources, since it will search in all the files in your project."
+ :type 'boolean :group 'ada)
+
+(defvar ada-load-project-hook nil
+ "Hook that is run when loading a project file.
+Each function in this hook takes one argument FILENAME, that is the name of
+the project file to load.
+This hook should be used to support new formats for the project files.
+
+If the function can load the file with the given filename, it should create a
+buffer that contains a conversion of the file to the standard format of the
+project files, and return that buffer. (The usual \"src_dir=\" or \"obj_dir=\"
+lines.) It should return nil if it doesn't know how to convert that project
+file.")
+
+
;; ------- Nothing to be modified by the user below this
(defvar ada-last-prj-file ""
"Name of the last project file entered by the user.")
-(defvar ada-check-switch "-gnats"
- "Switch added to the command line to check the current file.")
-
-(defvar ada-project-file-extension ".adp"
+(defconst ada-prj-file-extension ".adp"
"The extension used for project files.")
-(defconst is-windows (memq system-type (quote (windows-nt)))
- "True if we are running on windows NT or windows 95.")
-
(defvar ada-xref-runtime-library-specs-path '()
"Directories where the specs for the standard library is found.
This is used for cross-references.")
"List of positions selected by the cross-references functions.
Used to go back to these positions.")
+(defvar ada-cd-command
+ (if (string-match "cmdproxy.exe" shell-file-name)
+ "cd /d"
+ "cd")
+ "Command to use to change to a specific directory.
+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")
+ "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.")
+
(defconst ada-xref-pos-ring-max 16
"Number of positions kept in the list ada-xref-pos-ring.")
"\\+\\|-\\|/\\|\\*\\*\\|\\*\\|=\\|&\\|abs\\|mod\\|rem\\|and\\|not\\|or\\|xor\\|<=\\|<\\|>=\\|>"
"Regexp to match for operators.")
-(defvar ada-xref-default-prj-file nil
- "Name of the default prj file, per directory.
-Every directory is potentially associated with a default project file.
-If it is nil, then the first prj file loaded will be the default for this
-Emacs session.")
+(defvar ada-xref-project-files '()
+ "Associative list of project files with properties.
+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. 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
+project file, a (nil . default-properties) entry is created.")
-(defvar ada-xref-project-files '()
- "Associative list of project files.
-It has the following format:
-((project_name . value) (project_name . value) ...)
-As always, the values of the project file are defined through properties.")
-
-(defvar ada-prj-prj-file nil
- "Buffer local variable that specifies the name of the project file.
-Getting the project is done by looking up the key in ada-pxref-project-file.")
-
-(defun my-local-variable-if-set-p (variable &optional buffer)
- "Returns t if VARIABLE is local in BUFFER and is non-nil."
- (and (local-variable-p variable buffer)
- (save-excursion
- (set-buffer buffer)
- (symbol-value variable))))
-
-(defun ada-initialize-runtime-library ()
- "Initializes the variables for the runtime library location."
+;; ----- Identlist manipulation -------------------------------------------
+;; An identlist is a vector that is used internally to reference an identifier
+;; To facilitate its use, we provide the following macros
+
+(defmacro ada-make-identlist () (make-vector 8 nil))
+(defmacro ada-name-of (identlist) (list 'aref identlist 0))
+(defmacro ada-line-of (identlist) (list 'aref identlist 1))
+(defmacro ada-column-of (identlist) (list 'aref identlist 2))
+(defmacro ada-file-of (identlist) (list 'aref identlist 3))
+(defmacro ada-ali-index-of (identlist) (list 'aref identlist 4))
+(defmacro ada-declare-file-of (identlist) (list 'aref identlist 5))
+(defmacro ada-references-of (identlist) (list 'aref identlist 6))
+(defmacro ada-on-declaration (identlist) (list 'aref identlist 7))
+
+(defmacro ada-set-name (identlist name) (list 'aset identlist 0 name))
+(defmacro ada-set-line (identlist line) (list 'aset identlist 1 line))
+(defmacro ada-set-column (identlist col) (list 'aset identlist 2 col))
+(defmacro ada-set-file (identlist file) (list 'aset identlist 3 file))
+(defmacro ada-set-ali-index (identlist index) (list 'aset identlist 4 index))
+(defmacro ada-set-declare-file (identlist file) (list 'aset identlist 5 file))
+(defmacro ada-set-references (identlist ref) (list 'aset identlist 6 ref))
+(defmacro ada-set-on-declaration (ident value) (list 'aset ident 7 value))
+
+(defsubst ada-get-ali-buffer (file)
+ "Read the ali file FILE into a new buffer, and return the buffer's name."
+ (find-file-noselect (ada-get-ali-file-name file)))
+
+
+;; -----------------------------------------------------------------------
+
+(defun ada-quote-cmd (cmd)
+ "Duplicate all \\ characters in CMD so that it can be passed to `compile'."
+ (mapconcat 'identity (split-string cmd "\\\\") "\\\\"))
+
+(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))
+
+(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
- (set 'ada-xref-runtime-library-specs-path '())
- (set 'ada-xref-runtime-library-ali-path '())
+ (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
(progn
- (call-process "gnatls" nil t nil "-v")
+ (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)
- (unless (looking-at "<Current_Directory>")
+ (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)
(forward-line 1))
;; Object path
-
+
(search-forward "Object Search Path:")
(forward-line 1)
(while (not (looking-at "^$"))
(back-to-indentation)
- (unless (looking-at "<Current_Directory>")
+ (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)
(defun ada-treat-cmd-string (cmd-string)
"Replace meta-sequences like ${...} in CMD-STRING with the appropriate value.
-The project file must have been loaded first.
-As a special case, ${current} is replaced with the name of the currently
-edited file, minus extension but with directory."
+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
+replaced by the name including the extension."
(while (string-match "\\(-[^-\$IO]*[IO]\\)?\${\\([^}]+\\)}" cmd-string)
- (let (value)
- (if (string= (match-string 2 cmd-string) "current")
- (set 'value (file-name-sans-extension (buffer-file-name)))
+ (let (value
+ (name (match-string 2 cmd-string)))
+ (cond
+ ((string= name "current")
+ (setq value (file-name-sans-extension (buffer-file-name))))
+ ((string= name "full_current")
+ (setq value (buffer-file-name)))
+ (t
(save-match-data
- (set 'value (ada-xref-get-project-field
- (intern (match-string 2 cmd-string))))))
+ (setq value (ada-xref-get-project-field (intern name))))))
+
+ ;; Check if there is an environment variable with the same name
+ (if (null value)
+ (if (not (setq value (getenv name)))
+ (message "%s" (concat "No environment variable " name " found"))))
+
(cond
((null value)
- (set 'cmd-string (replace-match "" t t cmd-string)))
+ (setq cmd-string (replace-match "" t t cmd-string)))
((stringp value)
- (set 'cmd-string (replace-match value t t cmd-string)))
+ (setq cmd-string (replace-match value t t cmd-string)))
((listp value)
(let ((prefix (match-string 1 cmd-string)))
- (set 'cmd-string (replace-match
+ (setq cmd-string (replace-match
(mapconcat (lambda(x) (concat prefix x)) value " ")
t t cmd-string)))))
))
plist)
(save-excursion
(set-buffer ada-buffer)
-
+
(set 'plist
- ;; Try hard to find a default value for filename, so that the user
- ;; can edit his project file even if the current buffer is not an
- ;; Ada file or not even associated with a file
- (list 'filename (cond
- (file
- (ada-prj-get-prj-dir file))
- (ada-prj-prj-file
- ada-prj-prj-file)
- (ada-xref-default-prj-file
- ada-xref-default-prj-file)
- (t
- (error (concat "Not editing an Ada file,"
- "and no default project "
- "file specified!"))))
+ ;; 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 ".")
'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-sans-extension file)
+ (file-name-nondirectory
+ (file-name-sans-extension file))
"")
'main_unit (if file
(file-name-nondirectory
"")
'cross_prefix ""
'remote_machine ""
- 'comp_cmd (concat "cd ${build_dir} && "
- ada-prj-default-comp-cmd)
- 'check_cmd (concat ada-prj-default-comp-cmd " "
- ada-check-switch)
- 'make_cmd (concat "cd ${build_dir} && "
- ada-prj-default-make-cmd)
- 'run_cmd (concat "cd ${build_dir} && ${main}"
- (if is-windows ".exe"))
+ '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
- (if is-windows " ${main}.exe"
- " ${main}"))))
+ " ${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 project file of the current buffer.
-The project file must have been loaded first.
-A default value is returned if the file was not found."
+ "Extract the value of FIELD from the current project file.
+Project variables are substituted.
+
+Note that for src_dir and obj_dir, you should rather use
+`ada-xref-get-src-dir-field' or `ada-xref-get-obj-dir-field' which will in
+addition return the default paths."
- (let ((file-name ada-prj-prj-file)
+ (let ((file-name ada-prj-default-project-file)
file value)
- ;; If a default project file was set, use it if no other project
- ;; file was specified for the buffer
- (if (and (not file-name)
- ada-prj-default-project-file
- (not (string= ada-prj-default-project-file "")))
- (set 'file-name ada-prj-default-project-file))
-
- (set 'file (assoc file-name ada-xref-project-files))
-
+ ;; Get the project file (either the current one, or a default one)
+ (setq file (or (assoc file-name ada-xref-project-files)
+ (assoc nil ada-xref-project-files)))
+
;; If the file was not found, use the default values
(if file
;; Get the value from the file
;; Create a default nil file that contains the default values
(ada-xref-set-default-prj-values 'value (current-buffer))
(add-to-list 'ada-xref-project-files (cons nil value))
+ (ada-xref-update-project-menu)
(set 'value (plist-get value field))
)
- (if (stringp value)
- (ada-treat-cmd-string value)
- value))
- )
-;; ----- Keybindings ------------------------------------------------------
+ ;; Substitute the ${...} constructs in all the strings, including
+ ;; inside lists
+ (cond
+ ((stringp value)
+ (ada-treat-cmd-string value))
+ ((null value)
+ nil)
+ ((listp value)
+ (mapcar (lambda(x) (if x (ada-treat-cmd-string x) x)) value))
+ (t
+ value)
+ )
+ ))
-(defun ada-add-keymap ()
- "Add new key bindings when using `ada-xrel.el'."
- (interactive)
- (if ada-xemacs
- (progn
- (define-key ada-mode-map '(shift button3) 'ada-point-and-xref)
- (define-key ada-mode-map '(control tab) 'ada-complete-identifier))
- (define-key ada-mode-map [C-tab] 'ada-complete-identifier)
- (define-key ada-mode-map [S-mouse-3] 'ada-point-and-xref))
-
- (define-key ada-mode-map "\C-co" 'ff-find-other-file)
- (define-key ada-mode-map "\C-c5\C-d" 'ada-goto-declaration-other-frame)
- (define-key ada-mode-map "\C-c\C-d" 'ada-goto-declaration)
- (define-key ada-mode-map "\C-c\C-s" 'ada-xref-goto-previous-reference)
- (define-key ada-mode-map "\C-c\C-x" 'ada-reread-prj-file)
- (define-key ada-mode-map "\C-c\C-c" 'ada-compile-application)
- (define-key ada-mode-map "\C-cb" 'ada-buffer-list)
- (define-key ada-mode-map "\C-cc" 'ada-change-prj)
- (define-key ada-mode-map "\C-cd" 'ada-change-default-prj)
- (define-key ada-mode-map "\C-cg" 'ada-gdb-application)
- (define-key ada-mode-map "\C-cr" 'ada-run-application)
- (define-key ada-mode-map "\C-c\C-o" 'ada-goto-parent)
- (define-key ada-mode-map "\C-c\C-r" 'ada-find-references)
- (define-key ada-mode-map "\C-c\C-v" 'ada-check-current)
- )
+(defun ada-xref-get-src-dir-field ()
+ "Return the full value for src_dir, including the default directories.
+All the directories are returned as absolute directories."
+
+ (let ((build-dir (ada-xref-get-project-field 'build_dir)))
+ (append
+ ;; Add ${build_dir} in front of the path
+ (list build-dir)
+
+ (ada-get-absolute-dir-list (ada-xref-get-project-field 'src_dir)
+ build-dir)
+
+ ;; Add the standard runtime at the end
+ ada-xref-runtime-library-specs-path)))
+
+(defun ada-xref-get-obj-dir-field ()
+ "Return the full value for obj_dir, including the default directories.
+All the directories are returned as absolute directories."
+
+ (let ((build-dir (ada-xref-get-project-field 'build_dir)))
+ (append
+ ;; Add ${build_dir} in front of the path
+ (list build-dir)
+
+ (ada-get-absolute-dir-list (ada-xref-get-project-field 'obj_dir)
+ build-dir)
+
+ ;; Add the standard runtime at the end
+ ada-xref-runtime-library-ali-path)))
+
+(defun ada-xref-update-project-menu ()
+ "Update the menu Ada->Project, with the list of available project files."
+ ;; Create the standard items.
+ (let ((submenu
+ `("Project"
+ ["Load..." ada-set-default-project-file t]
+ ["New..." ada-prj-new t]
+ ["Edit..." ada-prj-edit t]
+ "---"
+ ;; Add the new items
+ ,@(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))))
+ (vector
+ (if (string= (file-name-extension name)
+ ada-prj-file-extension)
+ (file-name-sans-extension
+ (file-name-nondirectory name))
+ (file-name-nondirectory name))
+ command
+ :button (cons
+ :toggle
+ (equal ada-prj-default-project-file
+ (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)))
+
+
+;;-------------------------------------------------------------
+;;-- Searching a file anywhere on the source path.
+;;--
+;;-- The following functions provide support for finding a file anywhere
+;;-- on the source path, without providing an explicit directory.
+;;-- They also provide file name completion in the minibuffer.
+;;--
+;;-- Public subprograms: ada-find-file
+;;--
+;;-------------------------------------------------------------
+
+(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."
+ ;; FIXME: doc arguments
+ (let (list
+ (dirs (ada-xref-get-src-dir-field)))
+
+ (while dirs
+ (if (file-directory-p (car dirs))
+ (set 'list (append list (file-name-all-completions string (car dirs)))))
+ (set 'dirs (cdr dirs)))
+ (cond ((equal flag 'lambda)
+ (assoc string list))
+ (flag
+ list)
+ (t
+ (try-completion string
+ (mapcar (lambda (x) (cons x 1)) list)
+ predicate)))))
+
+;;;###autoload
+(defun ada-find-file (filename)
+ "Open FILENAME, from anywhere in the source path.
+Completion is available."
+ (interactive
+ (list (completing-read "File: " 'ada-do-file-completion)))
+ (let ((file (ada-find-src-file-in-dir filename)))
+ (if file
+ (find-file file)
+ (error (concat filename " not found in src_dir")))))
-;; ----- Menus --------------------------------------------------------------
-(defun ada-add-ada-menu ()
- "Add some items to the standard Ada mode menu.
-The items are added to the menu called NAME, which should be the same
-name as was passed to `ada-create-menu'."
- (interactive)
- (if ada-xemacs
- (let* ((menu-list '("Ada"))
- (goto-menu '("Ada" "Goto"))
- (edit-menu '("Ada" "Edit"))
- (help-menu '("Ada" "Help"))
- (options-menu (list "Ada" "Options")))
- (funcall (symbol-function 'add-menu-button)
- menu-list ["Check file" ada-check-current
- (string= mode-name "Ada")] "Goto")
- (funcall (symbol-function 'add-menu-button)
- menu-list ["Compile file" ada-compile-current
- (string= mode-name "Ada")] "Goto")
- (funcall (symbol-function 'add-menu-button)
- menu-list ["Build" ada-compile-application t] "Goto")
- (funcall (symbol-function 'add-menu-button)
- menu-list ["Run" ada-run-application t] "Goto")
- (funcall (symbol-function 'add-menu-button)
- menu-list ["Debug" ada-gdb-application t] "Goto")
- (funcall (symbol-function 'add-menu-button)
- menu-list ["--" nil t] "Goto")
- (funcall (symbol-function 'add-submenu)
- menu-list '("Project"
- ["Associate" ada-change-prj t]
- ["Set Default..." ada-set-default-project-file t]
- ["List" ada-buffer-list t])
- "Goto")
- (funcall (symbol-function 'add-menu-button)
- goto-menu ["Goto Parent Unit" ada-goto-parent t]
- "Next compilation error")
- (funcall (symbol-function 'add-menu-button)
- goto-menu ["Goto References to any entity"
- ada-find-any-references t]
- "Next compilation error")
- (funcall (symbol-function 'add-menu-button)
- goto-menu ["List References" ada-find-references t]
- "Next compilation error")
- (funcall (symbol-function 'add-menu-button)
- goto-menu ["Goto Declaration Other Frame"
- ada-goto-declaration-other-frame t]
- "Next compilation error")
- (funcall (symbol-function 'add-menu-button)
- goto-menu ["Goto Declaration/Body"
- ada-goto-declaration t]
- "Next compilation error")
- (funcall (symbol-function 'add-menu-button)
- goto-menu ["Goto Previous Reference"
- ada-xref-goto-previous-reference t]
- "Next compilation error")
- (funcall (symbol-function 'add-menu-button)
- goto-menu ["--" nil t] "Next compilation error")
- (funcall (symbol-function 'add-menu-button)
- edit-menu ["Complete Identifier"
- ada-complete-identifier t]
- "Indent Line")
- (funcall (symbol-function 'add-menu-button)
- edit-menu ["--------" nil t] "Indent Line")
- (funcall (symbol-function 'add-menu-button)
- help-menu ["Gnat User Guide" (info "gnat_ug")])
- (funcall (symbol-function 'add-menu-button)
- help-menu ["Gnat Reference Manual" (info "gnat_rm")])
- (funcall (symbol-function 'add-menu-button)
- help-menu ["Gcc Documentation" (info "gcc")])
- (funcall (symbol-function 'add-menu-button)
- help-menu ["Gdb Documentation" (info "gdb")])
- (funcall (symbol-function 'add-menu-button)
- help-menu ["Ada95 Reference Manual" (info "arm95")])
- (funcall (symbol-function 'add-menu-button)
- options-menu
- ["Show Cross-References in Other Buffer"
- (setq ada-xref-other-buffer
- (not ada-xref-other-buffer))
- :style toggle :selected ada-xref-other-buffer])
- (funcall (symbol-function 'add-menu-button)
- options-menu
- ["Automatically Recompile for Cross-References"
- (setq ada-xref-create-ali (not ada-xref-create-ali))
- :style toggle :selected ada-xref-create-ali])
- (funcall (symbol-function 'add-menu-button)
- options-menu
- ["Confirm Commands"
- (setq ada-xref-confirm-compile
- (not ada-xref-confirm-compile))
- :style toggle :selected ada-xref-confirm-compile])
- )
-
- ;; for Emacs
- (let* ((menu (lookup-key ada-mode-map [menu-bar Ada]))
- (edit-menu (lookup-key ada-mode-map [menu-bar Ada Edit]))
- (help-menu (lookup-key ada-mode-map [menu-bar Ada Help]))
- (goto-menu (lookup-key ada-mode-map [menu-bar Ada Goto]))
- (options-menu (lookup-key ada-mode-map [menu-bar Ada Options])))
-
- (define-key-after menu [Check] '("Check file" . ada-check-current)
- 'Customize)
- (define-key-after menu [Compile] '("Compile file" . ada-compile-current)
- 'Check)
- (define-key-after menu [Build] '("Build" . ada-compile-application)
- 'Compile)
- (define-key-after menu [Run] '("Run" . ada-run-application) 'Build)
- (define-key-after menu [Debug] '("Debug" . ada-gdb-application) 'Run)
- (define-key-after menu [rem] '("--" . nil) 'Debug)
- (define-key-after menu [Project]
- (cons "Project"
- (funcall (symbol-function 'easy-menu-create-menu)
- "Project"
- '(["Associate..." ada-change-prj t
- :included (string= mode-name "Ada")]
- ["Set Default..." ada-set-default-project-file t]
- ["List" ada-buffer-list t])))
- 'rem)
-
- (define-key help-menu [Gnat_ug]
- '("Gnat User Guide" . (lambda() (interactive) (info "gnat_ug"))))
- (define-key help-menu [Gnat_rm]
- '("Gnat Reference Manual" . (lambda() (interactive) (info "gnat_rm"))))
- (define-key help-menu [Gcc]
- '("Gcc Documentation" . (lambda() (interactive) (info "gcc"))))
- (define-key help-menu [gdb]
- '("Gdb Documentation" . (lambda() (interactive) (info "gdb"))))
- (define-key help-menu [gdb]
- '("Ada95 Reference Manual" . (lambda() (interactive) (info "arm95"))))
-
- (define-key goto-menu [rem] '("----" . nil))
- (define-key goto-menu [Parent] '("Goto Parent Unit"
- . ada-goto-parent))
- (define-key goto-menu [References-any]
- '("Goto References to any entity" . ada-find-any-references))
- (define-key goto-menu [References]
- '("List References" . ada-find-references))
- (define-key goto-menu [Prev]
- '("Goto Previous Reference" . ada-xref-goto-previous-reference))
- (define-key goto-menu [Decl-other]
- '("Goto Declaration Other Frame" . ada-goto-declaration-other-frame))
- (define-key goto-menu [Decl]
- '("Goto Declaration/Body" . ada-goto-declaration))
-
- (define-key edit-menu [rem] '("----" . nil))
- (define-key edit-menu [Complete] '("Complete Identifier"
- . ada-complete-identifier))
-
- (define-key-after options-menu [xrefrecompile]
- '(menu-item "Automatically Recompile for Cross-References"
- (lambda()(interactive)
- (setq ada-xref-create-ali (not ada-xref-create-ali)))
- :button (:toggle . ada-xref-create-ali)) t)
- (define-key-after options-menu [xrefconfirm]
- '(menu-item "Confirm Commands"
- (lambda()(interactive)
- (setq ada-xref-confirm-compile
- (not ada-xref-confirm-compile)))
- :button (:toggle . ada-xref-confirm-compile)) t)
- (define-key-after options-menu [xrefother]
- '(menu-item "Show Cross-References in Other Buffer"
- (lambda()(interactive)
- (setq ada-xref-other-buffer (not ada-xref-other-buffer)))
- :button (:toggle . ada-xref-other-buffer)) t)
- )
- )
- )
;; ----- Utilities -------------------------------------------------
(defun ada-require-project-file ()
- "If no project file is assigned to this buffer, load one."
- (if (not (my-local-variable-if-set-p 'ada-prj-prj-file (current-buffer)))
+ "If no project file is currently active, load a default one."
+ (if (or (not ada-prj-default-project-file)
+ (not ada-xref-project-files)
+ (string= ada-prj-default-project-file ""))
(ada-reread-prj-file)))
-
+
(defun ada-xref-push-pos (filename position)
"Push (FILENAME, POSITION) on the position ring for cross-references."
(setq ada-xref-pos-ring (cons (list position filename) ada-xref-pos-ring))
(goto-char (car pos)))))
(defun ada-convert-file-name (name)
- "Converts from NAME to a name that can be used by the compilation commands.
+ "Convert from NAME to a name that can be used by the compilation commands.
This is overriden on VMS to convert from VMS filenames to Unix filenames."
name)
+;; FIXME: use convert-standard-filename instead
-(defun ada-set-default-project-file (name)
- "Set the file whose name is NAME as the default project file."
+(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."
(interactive "fProject file:")
-
- ;; All the directories should use this file as the default from now on,
- ;; even if they were already associated with a file.
- (set 'ada-xref-default-prj-file nil)
-
- (set 'ada-prj-default-project-file name)
-
- ;; Make sure that all the buffers see the new project file, even if they
- ;; are not Ada buffers (for instance if we want to display the current
- ;; project file in the frame title).
- (setq-default ada-prj-prj-file name)
-
- (ada-reread-prj-file name)
- )
+ (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))))
;; ------ Handling the project file -----------------------------
-(defun ada-prj-find-prj-file (&optional no-user-question)
- "Find the prj file associated with the current buffer.
+(defun ada-prj-find-prj-file (&optional file no-user-question)
+ "Find the prj file associated with FILE (or the current buffer if nil).
If NO-USER-QUESTION is non-nil, use a default file if not project file was
found, and do not ask the user.
If the buffer is not an Ada buffer, associate it with the default project
-file. If none is set, return nil."
+file. If none is set, return nil."
(let (selected)
- ;; If we don't have an ada buffer, or the current buffer is not
- ;; a real file (for instance an emerge buffer)
-
+ ;; Use the active project file if there is one.
+ ;; This is also valid if we don't currently have an Ada buffer, or if
+ ;; the current buffer is not a real file (for instance an emerge buffer)
+
(if (or (not (string= mode-name "Ada"))
(not (buffer-file-name)))
- ;; 1st case: not an Ada buffer
(if (and ada-prj-default-project-file
(not (string= ada-prj-default-project-file "")))
- (set 'selected ada-prj-default-project-file))
-
- ;; 2nd case: If the buffer already has a project file, use it
- (if (my-local-variable-if-set-p 'ada-prj-prj-file (current-buffer))
- (set 'selected ada-prj-prj-file)
-
- (let* ((current-file (buffer-file-name))
- (first-choice (concat
- (file-name-sans-extension current-file)
- ada-project-file-extension))
- (dir (file-name-directory current-file))
-
- ;; on Emacs 20.2, directory-files does not work if
- ;; parse-sexp-lookup-properties is set
- (parse-sexp-lookup-properties nil)
- (prj-files (directory-files
- dir t
- (concat ".*" (regexp-quote ada-project-file-extension) "$")))
- (choice nil)
- (default (assoc dir ada-xref-default-prj-file)))
-
- (cond
-
- ;; 3rd case: a project file is already associated with the directory
- (default
- (set 'selected (cdr default)))
-
- ;; 4th case: the user has set a default project file for every file
- ((and ada-prj-default-project-file
- (not (string= ada-prj-default-project-file "")))
- (set 'selected ada-prj-default-project-file))
-
- ;; 5th case: there is a project file with the same name as the Ada file,
- ;; but not the same extension.
- ((file-exists-p first-choice)
- (set 'selected first-choice))
-
- ;; 6th case: only one project file was found in the current directory
- ((= (length prj-files) 1)
- (set 'selected (car prj-files)))
-
- ;; 7th case: if there are multiple files, ask the user
- ((and (> (length prj-files) 1) (not no-user-question))
- (save-window-excursion
- (with-output-to-temp-buffer "*choice list*"
- (princ "There are more than one possible project file. Which one should\n")
- (princ "be used ?\n\n")
- (princ " no. file name \n")
- (princ " --- ------------------------\n")
- (let ((counter 1))
- (while (<= counter (length prj-files))
- (princ (format " %2d) %s\n"
- counter
- (nth (1- counter) prj-files)))
- (setq counter (1+ counter))
- ))) ; end of with-output-to ...
- (setq choice nil)
- (while (or
- (not choice)
- (not (integerp choice))
- (< choice 1)
- (> choice (length prj-files)))
- (setq choice (string-to-int
- (read-from-minibuffer "Enter No. of your choice: "))))
- (set 'selected (nth (1- choice) prj-files))))
-
- ;; 8th case: no project file was found in the directory, ask a name to the
- ;; user, using as a default value the last one entered by the user
- ((= (length prj-files) 0)
- (unless (or no-user-question (not ada-always-ask-project))
- (setq ada-last-prj-file
- (read-file-name "project file:" nil ada-last-prj-file))
- (unless (string= ada-last-prj-file "")
- (set 'selected ada-last-prj-file))))
- ))))
- selected
+ (setq selected ada-prj-default-project-file)
+ (setq selected nil))
+
+ ;; other cases: use a more complex algorithm
+
+ (let* ((current-file (or file (buffer-file-name)))
+ (first-choice (concat
+ (file-name-sans-extension current-file)
+ ada-prj-file-extension))
+ (dir (file-name-directory current-file))
+
+ ;; on Emacs 20.2, directory-files does not work if
+ ;; parse-sexp-lookup-properties is set
+ (parse-sexp-lookup-properties nil)
+ (prj-files (directory-files
+ dir t
+ (concat ".*" (regexp-quote
+ ada-prj-file-extension) "$")))
+ (choice nil))
+
+ (cond
+
+ ;; Else if there is a project file with the same name as the Ada
+ ;; file, but not the same extension.
+ ((file-exists-p first-choice)
+ (set 'selected first-choice))
+
+ ;; Else if only one project file was found in the current directory
+ ((= (length prj-files) 1)
+ (set 'selected (car prj-files)))
+
+ ;; Else if there are multiple files, ask the user
+ ((and (> (length prj-files) 1) (not no-user-question))
+ (save-window-excursion
+ (with-output-to-temp-buffer "*choice list*"
+ (princ "There are more than one possible project file.\n")
+ (princ "Which one should we use ?\n\n")
+ (princ " no. file name \n")
+ (princ " --- ------------------------\n")
+ (let ((counter 1))
+ (while (<= counter (length prj-files))
+ (princ (format " %2d) %s\n"
+ counter
+ (nth (1- counter) prj-files)))
+ (setq counter (1+ counter))
+
+ ))) ; end of with-output-to ...
+ (setq choice nil)
+ (while (or
+ (not choice)
+ (not (integerp choice))
+ (< choice 1)
+ (> choice (length prj-files)))
+ (setq choice (string-to-number
+ (read-from-minibuffer "Enter No. of your choice: "))))
+ (set 'selected (nth (1- choice) prj-files))))
+
+ ;; Else if no project file was found in the directory, ask a name
+ ;; to the user, using as a default value the last one entered by
+ ;; the user
+ ((= (length prj-files) 0)
+ (unless (or no-user-question (not ada-always-ask-project))
+ (setq ada-last-prj-file
+ (read-file-name
+ (concat "project file [" ada-last-prj-file "]:")
+ nil ada-last-prj-file))
+ (unless (string= ada-last-prj-file "")
+ (set 'selected ada-last-prj-file))))
+ )))
+
+ (or selected "default.adp")
))
(defun ada-parse-prj-file (prj-file)
- "Reads and parses the PRJ-FILE file if it was found.
-The current buffer should be the ada-file buffer."
+ "Read PRJ-FILE, set it as the active project."
+ ;; FIXME: doc nil, search, etc.
(if prj-file
- (let (project src_dir obj_dir casing
- (ada-buffer (current-buffer)))
- (set 'prj-file (expand-file-name 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
+ ;; 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.
- (set-buffer (find-file-noselect prj-file))
-
- (widen)
- (goto-char (point-min))
-
- ;; Now overrides these values with the project file
- (while (not (eobp))
- (if (looking-at "^\\([^=]+\\)=\\(.*\\)")
- (cond
- ((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)))))
- (t
- (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 casing)))
+ (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))))
+
+ ;; Kill the project buffer
+ (kill-buffer nil)
+ (set-buffer ada-buffer)
+ )
+
+ ;; 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))))
+ )
+
+
+ ;; 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))
;; 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)))
-
+
;; 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-get-absolute-dir-list
- (plist-get project 'src_dir)
- (plist-get project 'build_dir)))
-
- ;; Associate each source directory in the project file with this file
- (mapcar (lambda (x)
- (if (not (assoc (expand-file-name x)
- ada-xref-default-prj-file))
- (setq ada-xref-default-prj-file
- (cons (cons (expand-file-name x) prj-file)
- ada-xref-default-prj-file))))
- compilation-search-path)
-
+ (setq compilation-search-path (ada-xref-get-src-dir-field))
+
+ ;; Set the casing exceptions file list
+ (if casing
+ (progn
+ (setq ada-case-exception-file (reverse casing))
+ (ada-case-read-exceptions)))
+
;; Add the directories to the search path for ff-find-other-file
;; Do not add the '/' or '\' at the end
- (set (make-local-variable 'ff-search-directories)
+ (setq ada-search-directories-internal
(append (mapcar 'directory-file-name compilation-search-path)
ada-search-directories))
-
- ;; Kill the .ali buffer
- (kill-buffer nil)
- (set-buffer ada-buffer)
-
- ;; Setup the project file for the current buffer
- (set (make-local-variable 'ada-prj-prj-file) prj-file)
+ (ada-xref-update-project-menu)
)
+
+ ;; 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))
))
-
-
-(defun ada-find-references (&optional pos)
+
+
+(defun ada-find-references (&optional pos arg local-only)
"Find all references to the entity under POS.
-Calls gnatfind to find the references."
- (interactive "")
- (unless pos
- (set 'pos (point)))
+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."
+ (interactive "d\nP")
(ada-require-project-file)
(let* ((identlist (ada-read-identifier pos))
- (alifile (ada-get-ali-file-name (ada-file-of identlist)))
+ (alifile (ada-get-ali-file-name (ada-file-of identlist)))
(process-environment (ada-set-environment)))
(set-buffer (get-file-buffer (ada-file-of identlist)))
;; if the file is more recent than the executable
(if (or (buffer-modified-p (current-buffer))
- (file-newer-than-file-p (ada-file-of identlist) alifile))
- (ada-find-any-references (ada-name-of identlist)
- (ada-file-of identlist)
- nil nil)
+ (file-newer-than-file-p (ada-file-of identlist) alifile))
+ (ada-find-any-references (ada-name-of identlist)
+ (ada-file-of identlist)
+ nil nil local-only arg)
(ada-find-any-references (ada-name-of identlist)
- (ada-file-of identlist)
- (ada-line-of identlist)
- (ada-column-of identlist))))
+ (ada-file-of identlist)
+ (ada-line-of identlist)
+ (ada-column-of identlist) local-only arg)))
)
-(defun ada-find-any-references (entity &optional file line column)
+(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."
+ (interactive "d\nP")
+ (ada-find-references pos arg t))
+
+(defun ada-find-any-references
+ (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."
+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."
(interactive "sEntity name: ")
(ada-require-project-file)
- (let* ((command (concat "gnatfind -rf " entity
- (if file (concat ":" (file-name-nondirectory file)))
- (if line (concat ":" line))
- (if column (concat ":" column)))))
+ ;; Prepare the gnatfind command. Note that we must protect the quotes
+ ;; around operators, so that they are correctly handled and can be
+ ;; processed (gnatfind \"+\":...).
+ (let* ((quote-entity
+ (if (= (aref entity 0) ?\")
+ (if is-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 " "
+ quote-entity
+ (if file (concat ":" (file-name-nondirectory file)))
+ (if line (concat ":" line))
+ (if column (concat ":" column))
+ (if local-only (concat " " (file-name-nondirectory file)))
+ ))
+ old-contents)
;; If a project file is defined, use it
- (if (my-local-variable-if-set-p 'ada-prj-prj-file (current-buffer))
- (setq command (concat command " -p" ada-prj-prj-file)))
+ (if (and ada-prj-default-project-file
+ (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))))
+
+ (if (and append (get-buffer "*gnatfind*"))
+ (save-excursion
+ (set-buffer "*gnatfind*")
+ (setq old-contents (buffer-string))))
- (compile-internal command "No more references" "gnatfind")
+ (let ((compilation-error "reference"))
+ (compilation-start command))
;; Hide the "Compilation" menu
(save-excursion
(set-buffer "*gnatfind*")
- (local-unset-key [menu-bar compilation-menu]))
- )
- )
-
-(defun ada-buffer-list ()
- "Display a buffer with all the Ada buffers and their associated project."
- (interactive)
- (save-excursion
- (set-buffer (get-buffer-create "*Buffer List*"))
- (setq buffer-read-only nil)
- (erase-buffer)
- (setq standard-output (current-buffer))
- (princ "The following line is a list showing the associations between
-directories and project file. It has the format : ((directory_1 . project_file1)
-(directory2 . project_file2)...)\n\n")
- (princ ada-xref-default-prj-file)
- (princ "\n
- Buffer Mode Project file
- ------ ---- ------------
-\n")
- (let ((bl (buffer-list)))
- (while bl
- (let* ((buffer (car bl))
- (buffer-name (buffer-name buffer))
- this-buffer-mode-name
- this-buffer-project-file)
- (save-excursion
- (set-buffer buffer)
- (setq this-buffer-mode-name
- (if (eq buffer standard-output)
- "Buffer Menu" mode-name))
- (if (string= this-buffer-mode-name
- "Ada")
- (setq this-buffer-project-file
- (if ( my-local-variable-if-set-p 'ada-prj-prj-file
- (current-buffer))
- (expand-file-name ada-prj-prj-file)
- ""))))
- (if (string= this-buffer-mode-name
- "Ada")
- (progn
- (princ (format "%-19s " buffer-name))
- (princ (format "%-6s " this-buffer-mode-name))
- (princ this-buffer-project-file)
- (princ "\n")
- ))
- ) ;; end let*
- (setq bl (cdr bl))
- ) ;; end while
- );; end let
- ) ;; end save-excursion
- (display-buffer "*Buffer List*")
- (other-window 1)
- )
+ (local-unset-key [menu-bar compilation-menu])
-(defun ada-change-prj (filename)
- "Set FILENAME to be the project file for current buffer."
- (interactive "fproject file:")
-
- ;; make sure we are using an Ada file
- (if (not (string= mode-name "Ada"))
- (error "You must be in ada-mode to use this function"))
-
- (set (make-local-variable 'ada-prj-prj-file) filename)
- (ada-parse-prj-file filename)
+ (if old-contents
+ (progn
+ (goto-char 1)
+ (insert old-contents)
+ (goto-char (point-max)))))
+ )
)
-(defun ada-change-default-prj (filename)
- "Set FILENAME to be the default project file for the current directory."
- (interactive "ffile name:")
- (let ((dir (file-name-directory (buffer-file-name)))
- (prj (expand-file-name filename)))
-
- ;; Associate the directory with a project file
- (if (assoc dir ada-xref-default-prj-file)
- (setcdr (assoc dir ada-xref-default-prj-file) prj)
- (add-to-list 'ada-xref-default-prj-file (list dir prj)))
-
- ;; Reparse the project file
- (ada-parse-prj-file filename)))
-
-
-;; ----- Identlist manipulation -------------------------------------------
-;; An identlist is a vector that is used internally to reference an identifier
-;; To facilitate its use, we provide the following macros
-
-(defmacro ada-make-identlist () (make-vector 8 nil))
-(defmacro ada-name-of (identlist) (list 'aref identlist 0))
-(defmacro ada-line-of (identlist) (list 'aref identlist 1))
-(defmacro ada-column-of (identlist) (list 'aref identlist 2))
-(defmacro ada-file-of (identlist) (list 'aref identlist 3))
-(defmacro ada-ali-index-of (identlist) (list 'aref identlist 4))
-(defmacro ada-declare-file-of (identlist) (list 'aref identlist 5))
-(defmacro ada-references-of (identlist) (list 'aref identlist 6))
-(defmacro ada-on-declaration (identlist) (list 'aref identlist 7))
-
-(defmacro ada-set-name (identlist name) (list 'aset identlist 0 name))
-(defmacro ada-set-line (identlist line) (list 'aset identlist 1 line))
-(defmacro ada-set-column (identlist col) (list 'aset identlist 2 col))
-(defmacro ada-set-file (identlist file) (list 'aset identlist 3 file))
-(defmacro ada-set-ali-index (identlist index) (list 'aset identlist 4 index))
-(defmacro ada-set-declare-file (identlist file) (list 'aset identlist 5 file))
-(defmacro ada-set-references (identlist ref) (list 'aset identlist 6 ref))
-(defmacro ada-set-on-declaration (ident value) (list 'aset ident 7 value))
-
-(defsubst ada-get-ali-buffer (file)
- "Reads the ali file into a new buffer, and returns this buffer's name"
- (find-file-noselect (ada-get-ali-file-name file)))
-
-
+(defalias 'ada-change-prj (symbol-function 'ada-set-default-project-file))
;; ----- Identifier Completion --------------------------------------------
(defun ada-complete-identifier (pos)
- "Tries to complete the identifier around POS.
-The feature is only available if the files where compiled not using the -gnatx
-option."
+ "Try to complete the identifier around POS, using compiler cross-reference information."
(interactive "d")
(ada-require-project-file)
;; Initialize function-local variables and jump to the .ali buffer
;; Note that for regexp search is case insensitive too
(let* ((curbuf (current-buffer))
- (identlist (ada-read-identifier pos))
- (sofar (concat "^[0-9]+[a-zA-Z][0-9]+[ *]\\("
- (regexp-quote (ada-name-of identlist))
- "[a-zA-Z0-9_]*\\)"))
- (completed nil)
- (symalist nil))
+ (identlist (ada-read-identifier pos))
+ (sofar (concat "^[0-9]+[a-zA-Z][0-9]+[ *]\\("
+ (regexp-quote (ada-name-of identlist))
+ "[a-zA-Z0-9_]*\\)"))
+ (completed nil)
+ (symalist nil))
;; Open the .ali file
(set-buffer (ada-get-ali-buffer (buffer-file-name)))
;; ----- Cross-referencing ----------------------------------------
(defun ada-point-and-xref ()
- "Calls `mouse-set-point' and then `ada-goto-declaration'."
+ "Jump to the declaration of the entity below the cursor."
(interactive)
(mouse-set-point last-input-event)
(ada-goto-declaration (point)))
-(defun ada-goto-declaration (pos)
+(defun ada-point-and-xref-body ()
+ "Jump to the body of the entity under the cursor."
+ (interactive)
+ (mouse-set-point last-input-event)
+ (ada-goto-body (point)))
+
+(defun ada-goto-body (pos &optional other-frame)
+ "Display the body of the entity around POS.
+OTHER-FRAME non-nil means display in another frame.
+If the entity doesn't have a body, display its declaration.
+As a side effect, the buffer for the declaration is also open."
+ (interactive "d")
+ (ada-goto-declaration pos other-frame)
+
+ ;; Temporarily force the display in the same buffer, since we
+ ;; already changed previously
+ (let ((ada-xref-other-buffer nil))
+ (ada-goto-declaration (point) nil)))
+
+(defun ada-goto-declaration (pos &optional other-frame)
"Display the declaration of the identifier around POS.
The declaration is shown in another buffer if `ada-xref-other-buffer' is
-non-nil."
+non-nil.
+If OTHER-FRAME is non-nil, display the cross-reference in another frame."
(interactive "d")
(ada-require-project-file)
(push-mark pos)
(ada-xref-push-pos (buffer-file-name) pos)
- (ada-find-in-ali (ada-read-identifier pos)))
+
+ ;; First try the standard algorithm by looking into the .ali file, but if
+ ;; that file was too old or even did not exist, try to look in the whole
+ ;; object path for a possible location.
+ (let ((identlist (ada-read-identifier pos)))
+ (condition-case err
+ (ada-find-in-ali identlist other-frame)
+ ;; File not found: print explicit error message
+ (error-file-not-found
+ (message (concat (error-message-string err)
+ (nthcdr 1 err))))
+
+ (error
+ (let ((ali-file (ada-get-ali-file-name (ada-file-of identlist))))
+
+ ;; If the ALI file was up-to-date, then we probably have a predefined
+ ;; entity, whose references are not given by GNAT
+ (if (and (file-exists-p ali-file)
+ (file-newer-than-file-p ali-file (ada-file-of identlist)))
+ (message "No cross-reference found -- may be a predefined entity.")
+
+ ;; Else, look in every ALI file, except if the user doesn't want that
+ (if ada-xref-search-with-egrep
+ (ada-find-in-src-path identlist other-frame)
+ (message "Cross-referencing information is not up-to-date; please recompile.")
+ )))))))
(defun ada-goto-declaration-other-frame (pos)
"Display the declaration of the identifier around POS.
The declation is shown in another frame if `ada-xref-other-buffer' is non-nil."
(interactive "d")
- (ada-require-project-file)
- (push-mark pos)
- (ada-xref-push-pos (buffer-file-name) pos)
- (ada-find-in-ali (ada-read-identifier pos) t))
+ (ada-goto-declaration pos t))
(defun ada-remote (command)
"Return the remote version of COMMAND, or COMMAND if remote_machine is nil."
machine
command))))
-(defun ada-get-absolute-dir (dir root-dir)
- "Returns the absolute directory corresponding to DIR.
-If DIR is a relative directory, the value of ROOT-DIR is added in front."
- (if (= (string-to-char dir) ?/)
- dir
- (concat root-dir dir)))
-
(defun ada-get-absolute-dir-list (dir-list root-dir)
- "Returns the list of absolute directories found in dir-list.
-If a directory is a relative directory, the value of ROOT-DIR is added in
-front."
- (mapcar (lambda (x) (ada-get-absolute-dir x root-dir)) dir-list))
+ "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))
(defun ada-set-environment ()
- "Return the new value for process-environment.
+ "Prepare an environment for Ada compilation.
+This returns a new value to use for `process-environment',
+but does not actually put it into use.
It modifies the source path and object path with the values found in the
project file."
(let ((include (getenv "ADA_INCLUDE_PATH"))
(objects (getenv "ADA_OBJECTS_PATH"))
(build-dir (ada-xref-get-project-field 'build_dir)))
(if include
- (set 'include (concat include path-separator)))
+ (set 'include (concat path-separator include)))
(if objects
- (set 'objects (concat objects path-separator)))
+ (set 'objects (concat path-separator objects)))
(cons
(concat "ADA_INCLUDE_PATH="
- include
- (mapconcat (lambda(x) (ada-get-absolute-dir x build-dir))
+ (mapconcat (lambda(x) (expand-file-name x build-dir))
(ada-xref-get-project-field 'src_dir)
- path-separator))
+ path-separator)
+ include)
(cons
(concat "ADA_OBJECTS_PATH="
- objects
- (mapconcat (lambda(x) (ada-get-absolute-dir x build-dir))
+ (mapconcat (lambda(x) (expand-file-name x build-dir))
(ada-xref-get-project-field 'obj_dir)
- path-separator))
+ path-separator)
+ objects)
process-environment))))
(defun ada-compile-application (&optional arg)
- "Compiles the application, using the command found in the project file.
+ "Compile the application, using the command found in the project file.
If ARG is not nil, ask for user confirmation."
(interactive "P")
(ada-require-project-file)
(process-environment (ada-set-environment))
(compilation-scroll-output t))
- (set 'compilation-search-path
- (ada-get-absolute-dir-list (ada-xref-get-project-field 'src_dir)
- (ada-xref-get-project-field 'build_dir)))
+ (setq compilation-search-path (ada-xref-get-src-dir-field))
;; If no project file was found, ask the user
(unless cmd
- (setq cmd "" arg t))
+ (setq cmd '("") arg t))
- (compile (ada-remote
- (if (or ada-xref-confirm-compile arg)
- (read-from-minibuffer "enter command to compile: " cmd)
- cmd)))
- ))
+ ;; Make a single command from the list of commands, including the
+ ;; commands to run it on a remote machine.
+ (setq cmd (ada-remote (mapconcat 'identity cmd ada-command-separator)))
+
+ (if (or ada-xref-confirm-compile arg)
+ (setq cmd (read-from-minibuffer "enter command to compile: " cmd)))
+
+ ;; Insert newlines so as to separate the name of the commands to run
+ ;; and the output of the commands. This doesn't work with cmdproxy.exe,
+ ;; which gets confused by newline characters.
+ (if (not (string-match ".exe" shell-file-name))
+ (setq cmd (concat cmd "\n\n")))
+
+ (compile (ada-quote-cmd cmd))))
(defun ada-compile-current (&optional arg prj-field)
"Recompile the current file.
(cmd (ada-xref-get-project-field field))
(process-environment (ada-set-environment))
(compilation-scroll-output t))
-
- (set 'compilation-search-path
- (ada-get-absolute-dir-list (ada-xref-get-project-field 'src_dir)
- (ada-xref-get-project-field 'build_dir)))
+
+ (setq compilation-search-path (ada-xref-get-src-dir-field))
+
+ (unless cmd
+ (setq cmd '("") arg t))
+
+ ;; Make a single command from the list of commands, including the
+ ;; commands to run it on a remote machine.
+ (setq cmd (ada-remote (mapconcat 'identity cmd ada-command-separator)))
;; If no project file was found, ask the user
- (if cmd
- (set 'cmd (concat cmd " " (ada-convert-file-name (buffer-file-name))))
- (setq cmd "" arg t))
-
- (compile (ada-remote
- (if (or ada-xref-confirm-compile arg)
- (read-from-minibuffer "enter command to compile: " cmd)
- cmd)))))
+ (if (or ada-xref-confirm-compile arg)
+ (setq cmd (read-from-minibuffer "enter command to compile: " cmd)))
+
+ (compile (ada-quote-cmd cmd))))
(defun ada-check-current (&optional arg)
"Recompile the current file.
(defun ada-run-application (&optional arg)
"Run the application.
-if ARG is not-nil, asks for user confirmation."
+if ARG is not-nil, ask for user confirmation."
(interactive)
(ada-require-project-file)
(let ((command (ada-xref-get-project-field 'run_cmd)))
;; Guess the command if it wasn't specified
- (if (or (not command) (string= command ""))
- (set 'command (file-name-sans-extension (buffer-name))))
+ (if (not command)
+ (set 'command (list (file-name-sans-extension (buffer-name)))))
+
+ ;; Modify the command to run remotely
+ (setq command (ada-remote (mapconcat 'identity command
+ ada-command-separator)))
;; Ask for the arguments to the command if required
(if (or ada-xref-confirm-compile arg)
- (set 'command (read-from-minibuffer "Enter command to execute: " command)))
-
- ;; Modify the command to run remotely
- (setq command (ada-remote command))
+ (setq command (read-from-minibuffer "Enter command to execute: "
+ command)))
;; Run the command
(save-excursion
(set-buffer (get-buffer-create "*run*"))
(set 'buffer-read-only nil)
+
(erase-buffer)
- (goto-char (point-min))
- (insert "\nRunning " command "\n\n")
- (start-process "run" (current-buffer) shell-file-name "-c" command)
+ (start-process "run" (current-buffer) shell-file-name
+ "-c" command)
+ (comint-mode)
+ ;; Set these two variables to their default values, since otherwise
+ ;; the output buffer is scrolled so that only the last output line
+ ;; is visible at the top of the buffer.
+ (set (make-local-variable 'scroll-step) 0)
+ (set (make-local-variable 'scroll-conservatively) 0)
)
(display-buffer "*run*")
(switch-to-buffer "*run*")
))
-
-(defun ada-gdb-application (&optional arg)
+(defun ada-gdb-application (&optional arg executable-name)
"Start the debugger on the application.
-If ARG is non-nil, ask the user to confirm the command."
+If ARG is non-nil, ask the user to confirm the command.
+EXECUTABLE-NAME, if non-nil, is debugged instead of the file specified in the
+project file."
(interactive "P")
(let ((buffer (current-buffer))
- gdb-buffer
- cmd)
+ cmd pre-cmd post-cmd)
(ada-require-project-file)
- (set 'cmd (ada-xref-get-project-field 'debug_cmd))
- (let ((machine (ada-xref-get-project-field 'remote_machine)))
- (if (and machine (not (string= machine "")))
- (error "This feature is not supported yet for remote environments")))
+ (setq cmd (if executable-name
+ (concat ada-prj-default-debugger " " executable-name)
+ (ada-xref-get-project-field 'debug_cmd))
+ pre-cmd (ada-xref-get-project-field 'debug_pre_cmd)
+ post-cmd (ada-xref-get-project-field 'debug_post_cmd))
;; If the command was not given in the project file, start a bare gdb
(if (not cmd)
(set 'cmd (concat ada-prj-default-debugger
" "
- (file-name-sans-extension (buffer-file-name)))))
+ (or executable-name
+ (file-name-sans-extension (buffer-file-name))))))
+
+ ;; For gvd, add an extra switch so that the Emacs window is completly
+ ;; swallowed inside the Gvd one
+ (if (and ada-tight-gvd-integration
+ (string-match "^[^ \t]*gvd" cmd))
+ ;; Start a new frame, so that when gvd exists we do not kill Emacs
+ ;; We make sure that gvd swallows the new frame, not the one the
+ ;; user has been using until now
+ ;; The frame is made invisible initially, so that GtkPlug gets a
+ ;; chance to fully manage it. Then it works fine with Enlightenment
+ ;; as well
+ (let ((frame (make-frame '((visibility . nil)))))
+ (set 'cmd (concat
+ cmd " --editor-window="
+ (cdr (assoc 'outer-window-id (frame-parameters frame)))))
+ (select-frame frame)))
+
+ ;; Add a -fullname switch
+ ;; Use the remote machine
+ (set 'cmd (ada-remote (concat cmd " -fullname ")))
+
+ ;; Ask for confirmation if required
(if (or arg ada-xref-confirm-compile)
(set 'cmd (read-from-minibuffer "enter command to debug: " cmd)))
- ;; Set the variable gud-last-last-frame so that glide-debug can find
- ;; the name of the Ada file, and thus of the project file if needed.
- (if ada-prj-prj-file
- (set 'gud-last-last-frame (cons ada-prj-prj-file 1)))
-
- (if (and (string-match "jdb" (comint-arguments cmd 0 0))
- (boundp 'jdb))
- (funcall (symbol-function 'jdb) cmd)
- (gdb cmd))
-
- (set 'gdb-buffer (symbol-value 'gud-comint-buffer))
-
- ;; Switch back to the source buffer
- ;; and Activate the debug part in the contextual menu
- (switch-to-buffer buffer)
-
- (if (functionp 'gud-make-debug-menu)
- (funcall (symbol-function 'gud-make-debug-menu)))
-
- ;; Warning: on Emacs >= 20.3.8, same-window-regexps includes gud-*,
- ;; so the following call to display buffer will select the
- ;; buffer instead of displaying it in another window
- ;; This is why the second argument to display-buffer is 't'
- (display-buffer gdb-buffer t)
- ))
-
+ (let ((old-comint-exec (symbol-function 'comint-exec)))
+
+ ;; Do not add -fullname, since we can have a 'rsh' command in front.
+ ;; FIXME: This is evil but luckily a nop under Emacs-21.3.50 ! -stef
+ (fset 'gud-gdb-massage-args (lambda (file args) args))
+
+ (set 'pre-cmd (mapconcat 'identity pre-cmd ada-command-separator))
+ (if (not (equal pre-cmd ""))
+ (setq pre-cmd (concat pre-cmd ada-command-separator)))
+
+ (set 'post-cmd (mapconcat 'identity post-cmd "\n"))
+ (if post-cmd
+ (set 'post-cmd (concat post-cmd "\n")))
+
+
+ ;; Temporarily replaces the definition of `comint-exec' so that we
+ ;; can execute commands before running gdb.
+ ;; FIXME: This is evil and not temporary !!! -stef
+ (fset 'comint-exec
+ `(lambda (buffer name command startfile switches)
+ (let (compilation-buffer-name-function)
+ (save-excursion
+ (set 'compilation-buffer-name-function
+ (lambda(x) (buffer-name buffer)))
+ (compile (ada-quote-cmd
+ (concat ,pre-cmd
+ command " "
+ (mapconcat 'identity switches " "))))))
+ ))
+
+ ;; Tight integration should force the tty mode
+ (if (and (string-match "gvd" (comint-arguments cmd 0 0))
+ ada-tight-gvd-integration
+ (not (string-match "--tty" cmd)))
+ (setq cmd (concat cmd "--tty")))
+
+ (if (and (string-match "jdb" (comint-arguments cmd 0 0))
+ (boundp 'jdb))
+ (funcall (symbol-function 'jdb) cmd)
+ (gdb cmd))
+
+ ;; Restore the standard fset command (or for instance C-U M-x shell
+ ;; wouldn't work anymore
+
+ (fset 'comint-exec old-comint-exec)
+
+ ;; Send post-commands to the debugger
+ (process-send-string (get-buffer-process (current-buffer)) post-cmd)
+
+ ;; Move to the end of the debugger buffer, so that it is automatically
+ ;; scrolled from then on.
+ (goto-char (point-max))
+
+ ;; Display both the source window and the debugger window (the former
+ ;; above the latter). No need to show the debugger window unless it
+ ;; is going to have some relevant information.
+ (if (or (not (string-match "gvd" (comint-arguments cmd 0 0)))
+ (string-match "--tty" cmd))
+ (split-window-vertically))
+ (switch-to-buffer buffer)
+ )))
(defun ada-reread-prj-file (&optional filename)
- "Forces Emacs to read either FILENAME or the project file associated
-with the current buffer.
-Otherwise, this file is only read once, and never read again.
-Since the information in the project file is shared between all buffers, this
-automatically modifies the setup for all the Ada buffer that use this file."
+ "Reread either the current project, or FILENAME if non-nil."
(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) ""))
+ )
;; ------ Private routines
(defun ada-xref-current (file &optional ali-file-name)
"Update the cross-references for FILE.
-This in fact recompiles FILE to create ALI-FILE-NAME."
+This in fact recompiles FILE to create ALI-FILE-NAME.
+This function returns the name of the file that was recompiled to generate
+the cross-reference information. Note that the ali file can then be deduced by
+replacing the file extension with `.ali'."
;; kill old buffer
(if (and ali-file-name
- (get-file-buffer ali-file-name))
+ (get-file-buffer ali-file-name))
(kill-buffer (get-file-buffer ali-file-name)))
- ;; read the project file
- (ada-require-project-file)
- (let* ((cmd (ada-xref-get-project-field 'comp_cmd))
- (process-environment (ada-set-environment))
- (compilation-scroll-output t)
- (name (ada-convert-file-name (buffer-file-name)))
- (body-name (ada-get-body-name name)))
- ;; Always recompile the body when we can
- (set 'body-name (or body-name name))
+ (let* ((name (ada-convert-file-name file))
+ (body-name (or (ada-get-body-name name) name)))
- ;; prompt for command to execute
- (set 'cmd (concat cmd " " body-name))
- (compile (ada-remote
- (if ada-xref-confirm-compile
- (read-from-minibuffer "enter command to compile: " cmd)
- cmd)))))
+ ;; Always recompile the body when we can. We thus temporarily switch to a
+ ;; buffer than contains the body of the unit
+ (save-excursion
+ (let ((body-visible (find-buffer-visiting body-name))
+ process)
+ (if body-visible
+ (set-buffer body-visible)
+ (find-file body-name))
+
+ ;; Execute the compilation. Note that we must wait for the end of the
+ ;; process, or the ALI file would still not be available.
+ ;; Unfortunately, the underlying `compile' command that we use is
+ ;; asynchronous.
+ (ada-compile-current)
+ (setq process (get-buffer-process "*compilation*"))
+
+ (while (and process
+ (not (equal (process-status process) 'exit)))
+ (sit-for 1))
+
+ ;; remove the buffer for the body if it wasn't there before
+ (unless body-visible
+ (kill-buffer (find-buffer-visiting body-name)))
+ ))
+ body-name))
(defun ada-find-file-in-dir (file dir-list)
"Search for FILE in DIR-LIST."
(while (and (not found) dir-list)
(set 'found (concat (file-name-as-directory (car dir-list))
(file-name-nondirectory file)))
-
+
(unless (file-exists-p found)
(set 'found nil))
(set 'dir-list (cdr dir-list)))
found))
(defun ada-find-ali-file-in-dir (file)
- "Find an .ali file in obj_dir. The current buffer must be the Ada file.
+ "Find the ali file FILE, searching obj_dir for the current project.
Adds build_dir in front of the search path to conform to gnatmake's behavior,
and the standard runtime location at the end."
- (ada-find-file-in-dir file
- (append
-
- ;; Add ${build_dir} in front of the path
- (list (ada-xref-get-project-field 'build_dir))
-
- (ada-get-absolute-dir-list
- (ada-xref-get-project-field 'obj_dir)
- (ada-xref-get-project-field 'build_dir))
-
- ;; Add the standard runtime at the end
- ada-xref-runtime-library-ali-path)))
+ (ada-find-file-in-dir file (ada-xref-get-obj-dir-field)))
(defun ada-find-src-file-in-dir (file)
- "Find a source file in src_dir. The current buffer must be the Ada file.
-Adds src_dir in front of the search path to conform to gnatmake's behavior,
-and the standard runtime location at the end."
- (ada-find-file-in-dir file
- (append
-
- ;; Add ${build_dir} in front of the path
- (list (ada-xref-get-project-field 'build_dir))
-
- (ada-get-absolute-dir-list
- (ada-xref-get-project-field 'src_dir)
- (ada-xref-get-project-field 'build_dir))
-
- ;; Add the standard runtime at the end
- ada-xref-runtime-library-specs-path)))
-
+ "Find the source file FILE, searching src_dir for the current project.
+Adds the standard runtime location at the end of the search path to conform
+to gnatmake's behavior."
+ (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.
;; and look for this file
;; 2- If this file is found:
;; grep the "^U" lines, and make sure we are not reading the
- ;; .ali file for a spec file. If we are, go to step 3.
+ ;; .ali file for a spec file. If we are, go to step 3.
;; 3- If the file is not found or step 2 failed:
;; find the name of the "other file", ie the body, and look
;; for its associated .ali file by subtituing the extension
+ ;;
+ ;; We must also handle the case of separate packages and subprograms:
+ ;; 4- If no ali file was found, we try to modify the file name by removing
+ ;; everything after the last '-' or '.' character, so as to get the
+ ;; ali file for the parent unit. If we found an ali file, we check that
+ ;; it indeed contains the definition for the separate entity by checking
+ ;; the 'D' lines. This is done repeatedly, in case the direct parent is
+ ;; also a separate.
(save-excursion
(set-buffer (get-file-buffer file))
(let ((short-ali-file-name
- (concat (file-name-sans-extension (file-name-nondirectory file))
- ".ali"))
- ali-file-name)
- ;; First step
- ;; we take the first possible completion
- (setq ali-file-name (ada-find-ali-file-in-dir short-ali-file-name))
-
- ;; If we have found the .ali file, but the source file was a spec
- ;; with a non-standard name, search the .ali file for the body if any,
- ;; since the xref information is more complete in that one
- (unless ali-file-name
- (if (not (string= (file-name-extension file) "ads"))
- (let ((is-spec nil)
- (specs ada-spec-suffixes)
- body-ali)
- (while specs
- (if (string-match (concat (regexp-quote (car specs)) "$")
- file)
- (set 'is-spec t))
- (set 'specs (cdr specs)))
-
- (if is-spec
- (set 'body-ali
- (ada-find-ali-file-in-dir
- (concat (file-name-sans-extension
- (file-name-nondirectory
- (ada-other-file-name)))
- ".ali"))))
- (if body-ali
- (set 'ali-file-name body-ali))))
-
- ;; else we did not find the .ali file
- ;; Second chance: in case the files do not have standard names (such
- ;; as for instance file_s.ada and file_b.ada), try to go to the
- ;; other file and look for its ali file
- (setq short-ali-file-name
- (concat (file-name-sans-extension
- (file-name-nondirectory (ada-other-file-name)))
- ".ali"))
- (setq ali-file-name (ada-find-ali-file-in-dir short-ali-file-name))
-
- ;; If still not found, try to recompile the file
- (if (not ali-file-name)
- (progn
- ;; recompile only if the user asked for this
- (if ada-xref-create-ali
- (ada-xref-current file ali-file-name))
- (error "Ali file not found. Recompile your file")))
- )
-
- ;; same if the .ali file is too old and we must recompile it
- (if (and (file-newer-than-file-p file ali-file-name)
- ada-xref-create-ali)
- (ada-xref-current file ali-file-name))
-
- ;; else returns the correct absolute file name
+ (concat (file-name-sans-extension (file-name-nondirectory file))
+ ".ali"))
+ ali-file-name
+ is-spec)
+
+ ;; If we have a non-standard file name, and this is a spec, we first
+ ;; look for the .ali file of the body, since this is the one that
+ ;; contains the most complete information. If not found, we will do what
+ ;; we can with the .ali file for the spec...
+
+ (if (not (string= (file-name-extension file) "ads"))
+ (let ((specs ada-spec-suffixes))
+ (while specs
+ (if (string-match (concat (regexp-quote (car specs)) "$")
+ file)
+ (set 'is-spec t))
+ (set 'specs (cdr specs)))))
+
+ (if is-spec
+ (set 'ali-file-name
+ (ada-find-ali-file-in-dir
+ (concat (file-name-sans-extension
+ (file-name-nondirectory
+ (ada-other-file-name)))
+ ".ali"))))
+
+
+ (setq ali-file-name
+ (or ali-file-name
+
+ ;; Else we take the .ali file associated with the unit
+ (ada-find-ali-file-in-dir short-ali-file-name)
+
+
+ ;; else we did not find the .ali file Second chance: in case
+ ;; the files do not have standard names (such as for instance
+ ;; file_s.ada and file_b.ada), try to go to the other file
+ ;; and look for its ali file
+ (ada-find-ali-file-in-dir
+ (concat (file-name-sans-extension
+ (file-name-nondirectory (ada-other-file-name)))
+ ".ali"))
+
+
+ ;; If we still don't have an ali file, try to get the one
+ ;; from the parent unit, in case we have a separate entity.
+ (let ((parent-name (file-name-sans-extension
+ (file-name-nondirectory file))))
+
+ (while (and (not ali-file-name)
+ (string-match "^\\(.*\\)[.-][^.-]*" parent-name))
+
+ (set 'parent-name (match-string 1 parent-name))
+ (set 'ali-file-name (ada-find-ali-file-in-dir
+ (concat parent-name ".ali")))
+ )
+ ali-file-name)))
+
+ ;; If still not found, try to recompile the file
+ (if (not ali-file-name)
+ ;; Recompile only if the user asked for this, and search the ali
+ ;; filename again. We avoid a possible infinite recursion by
+ ;; temporarily disabling the automatic compilation.
+
+ (if ada-xref-create-ali
+ (setq ali-file-name
+ (concat (file-name-sans-extension (ada-xref-current file))
+ ".ali"))
+
+ (error "`.ali' file not found; recompile your source file"))
+
+
+ ;; same if the .ali file is too old and we must recompile it
+ (if (and (file-newer-than-file-p file ali-file-name)
+ ada-xref-create-ali)
+ (ada-xref-current file ali-file-name)))
+
+ ;; Always return the correct absolute file name
(expand-file-name ali-file-name))
- ))
+ ))
(defun ada-get-ada-file-name (file original-file)
"Create the complete file name (+directory) for FILE.
-The original file (where the user was) is ORIGINAL-FILE. Search in project
+The original file (where the user was) is ORIGINAL-FILE. Search in project
file for possible paths."
(save-excursion
(set-buffer buffer)
(find-file original-file)
(ada-require-project-file)))
-
+
;; we choose the first possible completion and we
;; return the absolute file name
(let ((filename (ada-find-src-file-in-dir file)))
(if filename
- (expand-file-name filename)
- (error (concat
- (file-name-nondirectory file)
- " not found in src_dir. Please check your project file")))
-
+ (expand-file-name filename)
+ (signal 'error-file-not-found (file-name-nondirectory file)))
)))
(defun ada-find-file-number-in-ali (file)
- "Returns the file number for FILE in the associated ali file."
+ "Return the file number for FILE in the associated ali file."
(set-buffer (ada-get-ali-buffer file))
(goto-char (point-min))
(count-lines begin (point))))
(defun ada-read-identifier (pos)
- "Returns the identlist around POS and switch to the .ali buffer."
-
- ;; If there's a compilation in progress, it's probably because the
- ;; .ali file didn't exist. So we should wait...
- (if compilation-in-progress
- (progn
- (message "Compilation in progress. Try again when it is finished")
- (set 'quit-flag t)))
+ "Return the identlist around POS and switch to the .ali buffer.
+The returned list represents the entity, and can be manipulated through the
+macros `ada-name-of', `ada-line-of', `ada-column-of', `ada-file-of',..."
;; If at end of buffer (e.g the buffer is empty), error
(if (>= (point) (point-max))
(error "No identifier on point"))
-
+
;; goto first character of the identifier/operator (skip backward < and >
;; since they are part of multiple character operators
(goto-char pos)
;; Just in front of a string => we could have an operator declaration,
;; as in "+", "-", ..
(if (= (char-after) ?\")
- (forward-char 1))
+ (forward-char 1))
;; if looking at an operator
;; This is only true if:
(or (not (= (char-syntax (char-after)) ?w))
(not (or (= (char-syntax (char-after (match-end 0))) ?w)
(= (char-after (match-end 0)) ?_)))))
- (progn
- (if (and (= (char-before) ?\")
- (= (char-after (+ (length (match-string 0)) (point))) ?\"))
- (forward-char -1))
- (set 'identifier (regexp-quote (concat "\"" (match-string 0) "\""))))
+ (progn
+ (if (and (= (char-before) ?\")
+ (= (char-after (+ (length (match-string 0)) (point))) ?\"))
+ (forward-char -1))
+ (set 'identifier (regexp-quote (concat "\"" (match-string 0) "\""))))
(if (ada-in-string-p)
- (error "Inside string or character constant"))
+ (error "Inside string or character constant"))
(if (looking-at (concat ada-keywords "[^a-zA-Z_]"))
- (error "No cross-reference available for reserved keyword"))
+ (error "No cross-reference available for reserved keyword"))
(if (looking-at "[a-zA-Z0-9_]+")
- (set 'identifier (match-string 0))
- (error "No identifier around")))
-
+ (set 'identifier (match-string 0))
+ (error "No identifier around")))
+
;; Build the identlist
(set 'identlist (ada-make-identlist))
(ada-set-name identlist (downcase identifier))
(ada-set-line identlist
- (number-to-string (count-lines (point-min) (point))))
+ (number-to-string (count-lines 1 (point))))
(ada-set-column identlist
(number-to-string (1+ (current-column))))
(ada-set-file identlist (buffer-file-name))
))
(defun ada-get-all-references (identlist)
- "Completes and returns IDENTLIST with the information extracted
-from the ali file (definition file and places where it is referenced)."
-
+ "Complete IDENTLIST with definition file and places where it is referenced.
+Information is extracted from the ali file."
+
(let ((ali-buffer (ada-get-ali-buffer (ada-file-of identlist)))
declaration-found)
(set-buffer ali-buffer)
;; First attempt: we might already be on the declaration of the identifier
;; We want to look for the declaration only in a definite interval (after
;; the "^X ..." line for the current file, and before the next "^X" line
-
+
(if (re-search-forward
(concat "^X [0-9]+ " (file-name-nondirectory (ada-file-of identlist)))
nil t)
- (let ((bound (save-excursion (re-search-forward "^X " nil t))))
- (set 'declaration-found
+ (let ((bound (save-excursion (re-search-forward "^X " nil t))))
+ (set 'declaration-found
(re-search-forward
(concat "^" (ada-line-of identlist)
"." (ada-column-of identlist)
"[ *]" (ada-name-of identlist)
- " \\(.*\\)$") bound t))
+ "[{\[\(<= ]?\\(.*\\)$") bound t))
(if declaration-found
(ada-set-on-declaration identlist t))
))
;; have to fall back on other algorithms
(unless declaration-found
-
+
;; Since we alread know the number of the file, search for a direct
;; reference to it
(goto-char (point-min))
(number-to-string (ada-find-file-number-in-ali
(ada-file-of identlist))))
(unless (re-search-forward (concat (ada-ali-index-of identlist)
- "|\\([0-9]+.[0-9]+ \\)*"
+ "|\\([0-9]+[^0-9][0-9]+\\(\n\\.\\)? \\)*"
(ada-line-of identlist)
- "[^0-9]"
- (ada-column-of identlist))
+ "[^etpzkd<>=^]"
+ (ada-column-of identlist) "\\>")
nil t)
- ;; if we did not find it, it may be because the first reference
- ;; is not required to have a 'unit_number|' item included.
- ;; Or maybe we are already on the declaration...
- (unless (re-search-forward (concat "^\\([a-zA-Z0-9_.\"]+[ *]\\)*"
- (ada-line-of identlist)
- "[^0-9]"
- (ada-column-of identlist))
- nil t)
-
+ ;; if we did not find it, it may be because the first reference
+ ;; is not required to have a 'unit_number|' item included.
+ ;; Or maybe we are already on the declaration...
+ (unless (re-search-forward
+ (concat
+ "^[0-9]+.[0-9]+[ *]"
+ (ada-name-of identlist)
+ "[ <{=\(\[]\\(.\\|\n\\.\\)*\\<"
+ (ada-line-of identlist)
+ "[^0-9]"
+ (ada-column-of identlist) "\\>")
+ nil t)
+
;; If still not found, then either the declaration is unknown
;; or the source file has been modified since the ali file was
;; created
(set 'declaration-found nil)
- )
+ )
)
;; Last check to be completly sure we have found the correct line (the
(beginning-of-line)
;; while we have a continuation line, go up one line
(while (looking-at "^\\.")
- (previous-line 1))
+ (previous-line 1)
+ (beginning-of-line))
(unless (looking-at (concat "[0-9]+.[0-9]+[ *]"
- (ada-name-of identlist) "[ <]"))
+ (ada-name-of identlist) "[ <{=\(\[]"))
(set 'declaration-found nil))))
;; Still no success ! The ali file must be too old, and we need to
- ;; use a basic algorithm based on guesses. Note that this only happens
+ ;; use a basic algorithm based on guesses. Note that this only happens
;; if the user does not want us to automatically recompile files
;; automatically
(unless declaration-found
(if (ada-xref-find-in-modified-ali identlist)
(set 'declaration-found t)
- ;; no more idea to find the declaration. Give up
+ ;; No more idea to find the declaration. Give up
(progn
(kill-buffer ali-buffer)
(error (concat "No declaration of " (ada-name-of identlist)
)))
)
-
+
;; Now that we have found a suitable line in the .ali file, get the
;; information available
(beginning-of-line)
(if declaration-found
- (let ((current-line (buffer-substring
+ (let ((current-line (buffer-substring
(point) (save-excursion (end-of-line) (point)))))
- (save-excursion
- (next-line 1)
- (beginning-of-line)
- (while (looking-at "^\\.\\(.*\\)")
- (set 'current-line (concat current-line (match-string 1)))
- (next-line 1))
- )
+ (save-excursion
+ (next-line 1)
+ (beginning-of-line)
+ (while (looking-at "^\\.\\(.*\\)")
+ (set 'current-line (concat current-line (match-string 1)))
+ (next-line 1))
+ )
(if (re-search-backward "^X [0-9]+ \\([a-zA-Z0-9_.-]+\\)" nil t)
- (ada-set-declare-file
- identlist
- (ada-get-ada-file-name (match-string 1)
- (ada-file-of identlist))))
-
+
+ ;; If we can find the file
+ (condition-case err
+ (ada-set-declare-file
+ identlist
+ (ada-get-ada-file-name (match-string 1)
+ (ada-file-of identlist)))
+
+ ;; Else clean up the ali file
+ (error-file-not-found
+ (signal (car err) (cdr err)))
+ (error
+ (kill-buffer ali-buffer)
+ (error (error-message-string err)))
+ ))
+
(ada-set-references identlist current-line)
))
))
(unless (= (string-to-char (ada-name-of identlist)) ?\")
(progn
- (let ((declist '()) ;;; ( (line_in_ali_file line_in_ada) ( ... ))
+ (let ((declist '()) ;;; ( (line_in_ali_file line_in_ada) ( ... ))
(my-regexp (concat "[ *]"
(regexp-quote (ada-name-of identlist)) " "))
(line-ada "--")
(choice 0)
(ali-buffer (current-buffer)))
- (goto-char (point-max))
- (while (re-search-backward my-regexp nil t)
- (save-excursion
- (set 'line-ali (count-lines (point-min) (point)))
- (beginning-of-line)
- ;; have a look at the line and column numbers
- (if (looking-at "^\\([0-9]+\\).\\([0-9]+\\)[ *]")
- (progn
- (setq line-ada (match-string 1))
- (setq col-ada (match-string 2)))
- (setq line-ada "--")
- (setq col-ada "--")
- )
- ;; construct a list with the file names and the positions within
- (if (re-search-backward "^X [0-9]+ \\([a-zA-Z0-9._-]+\\)" nil t)
+ (goto-char (point-max))
+ (while (re-search-backward my-regexp nil t)
+ (save-excursion
+ (set 'line-ali (count-lines 1 (point)))
+ (beginning-of-line)
+ ;; have a look at the line and column numbers
+ (if (looking-at "^\\([0-9]+\\).\\([0-9]+\\)[ *]")
+ (progn
+ (setq line-ada (match-string 1))
+ (setq col-ada (match-string 2)))
+ (setq line-ada "--")
+ (setq col-ada "--")
+ )
+ ;; construct a list with the file names and the positions within
+ (if (re-search-backward "^X [0-9]+ \\([a-zA-Z0-9._-]+\\)" nil t)
(add-to-list
'declist (list line-ali (match-string 1) line-ada col-ada))
- )
- )
- )
-
- ;; how many possible declarations have we found ?
- (setq len (length declist))
- (cond
- ;; none => error
- ((= len 0)
- (kill-buffer (current-buffer))
- (error (concat "No declaration of "
- (ada-name-of identlist)
- " recorded in .ali file")))
-
- ;; one => should be the right one
- ((= len 1)
- (goto-line (caar declist)))
-
- ;; more than one => display choice list
- (t
- (with-output-to-temp-buffer "*choice list*"
-
- (princ "Identifier is overloaded and Xref information is not up to date.\n")
- (princ "Possible declarations are:\n\n")
- (princ " no. in file at line col\n")
- (princ " --- --------------------- ---- ----\n")
- (let ((counter 1))
- (while (<= counter len)
- (princ (format " %2d) %-21s %4s %4s\n"
- counter
+ )
+ )
+ )
+
+ ;; how many possible declarations have we found ?
+ (setq len (length declist))
+ (cond
+ ;; none => error
+ ((= len 0)
+ (kill-buffer (current-buffer))
+ (error (concat "No declaration of "
+ (ada-name-of identlist)
+ " recorded in .ali file")))
+
+ ;; one => should be the right one
+ ((= len 1)
+ (goto-line (caar declist)))
+
+ ;; more than one => display choice list
+ (t
+ (save-window-excursion
+ (with-output-to-temp-buffer "*choice list*"
+
+ (princ "Identifier is overloaded and Xref information is not up to date.\n")
+ (princ "Possible declarations are:\n\n")
+ (princ " no. in file at line col\n")
+ (princ " --- --------------------- ---- ----\n")
+ (let ((counter 0))
+ (while (< counter len)
+ (princ (format " %2d) %-21s %4s %4s\n"
+ (1+ counter)
(ada-get-ada-file-name
- (nth 1 (nth (1- counter) declist))
+ (nth 1 (nth counter declist))
(ada-file-of identlist))
- (nth 2 (nth (1- counter) declist))
- (nth 3 (nth (1- counter) declist))
- ))
- (setq counter (1+ counter))
- ) ; end of while
- ) ; end of let
- ) ; end of with-output-to ...
- (setq choice nil)
- (while (or
- (not choice)
- (not (integerp choice))
- (< choice 1)
- (> choice len))
- (setq choice (string-to-int
- (read-from-minibuffer "Enter No. of your choice: "))))
+ (nth 2 (nth counter declist))
+ (nth 3 (nth counter declist))
+ ))
+ (setq counter (1+ counter))
+ ) ; end of while
+ ) ; end of let
+ ) ; end of with-output-to ...
+ (setq choice nil)
+ (while (or
+ (not choice)
+ (not (integerp choice))
+ (< choice 1)
+ (> choice len))
+ (setq choice
+ (string-to-number
+ (read-from-minibuffer "Enter No. of your choice: "))))
+ )
(set-buffer ali-buffer)
- (goto-line (car (nth (1- choice) declist)))
- ))))))
+ (goto-line (car (nth (1- choice) declist)))
+ ))))))
(defun ada-find-in-ali (identlist &optional other-frame)
"Look in the .ali file for the definition of the identifier in IDENTLIST.
-If OTHER-FRAME is non nil, and `ada-xref-other-buffer' is non nil,
+If OTHER-FRAME is non-nil, and `ada-xref-other-buffer' is non-nil,
opens a new window to show the declaration."
(ada-get-all-references identlist)
(let ((ali-line (ada-references-of identlist))
+ (locations nil)
+ (start 0)
file line col)
-
- ;; If we were on a declaration, go to the body
- (if (ada-on-declaration identlist)
- (if (string-match "\\([0-9]+\\)[bc]\\([0-9]+\\)" ali-line)
- (progn
- (setq line (match-string 1 ali-line)
- col (match-string 2 ali-line))
- ;; it there was a file number in the same line
- (if (string-match "\\([0-9]+\\)|\\([^|bc]+\\)?[bc]" ali-line)
- (let ((file-number (match-string 1 ali-line)))
- (goto-char (point-min))
- (re-search-forward "^D \\([a-zA-Z0-9_.-]+\\)" nil t
- (string-to-number file-number))
- (set 'file (match-string 1))
- )
- ;; Else get the nearest file
- (set 'file (ada-declare-file-of identlist))
- )
- )
- (error "No body found"))
-
- ;; Else we were not on the declaration, find the place for it
- (string-match "\\([0-9]+\\)[a-zA-Z+]\\([0-9]+\\)[ *]" ali-line)
- (setq line (match-string 1 ali-line)
- col (match-string 2 ali-line)
- file (ada-declare-file-of identlist))
- )
+
+ ;; Note: in some cases, an entity can have multiple references to the
+ ;; bodies (this is for instance the case for a separate subprogram, that
+ ;; has a reference both to the stub and to the real body).
+ ;; In that case, we simply go to each one in turn.
+
+ ;; Get all the possible locations
+ (string-match "^\\([0-9]+\\)[a-zA-Z+*]\\([0-9]+\\)[ *]" ali-line)
+ (set 'locations (list (list (match-string 1 ali-line) ;; line
+ (match-string 2 ali-line) ;; column
+ (ada-declare-file-of identlist))))
+ (while (string-match "\\([0-9]+\\)[bc]\\(<[^>]+>\\)?\\([0-9]+\\)"
+ ali-line start)
+ (setq line (match-string 1 ali-line)
+ col (match-string 3 ali-line)
+ start (match-end 3))
+
+ ;; it there was a file number in the same line
+ ;; Make sure we correctly handle the case where the first file reference
+ ;; on the line is the type reference.
+ ;; 1U2 T(2|2r3) 34r23
+ (if (string-match (concat "[^{(<0-9]\\([0-9]+\\)|\\([^|bc]+\\)?"
+ (match-string 0 ali-line))
+ ali-line)
+ (let ((file-number (match-string 1 ali-line)))
+ (goto-char (point-min))
+ (re-search-forward "^D \\([a-zA-Z0-9_.-]+\\)" nil t
+ (string-to-number file-number))
+ (set 'file (match-string 1))
+ )
+ ;; Else get the nearest file
+ (set 'file (ada-declare-file-of identlist)))
+
+ (set 'locations (append locations (list (list line col file)))))
+
+ ;; Add the specs at the end again, so that from the last body we go to
+ ;; the specs
+ (set 'locations (append locations (list (car locations))))
+
+ ;; Find the new location we want to go to.
+ ;; If we are on none of the locations listed, we simply go to the specs.
+
+ (setq line (caar locations)
+ col (nth 1 (car locations))
+ file (nth 2 (car locations)))
+
+ (while locations
+ (if (and (string= (caar locations) (ada-line-of identlist))
+ (string= (nth 1 (car locations)) (ada-column-of identlist))
+ (string= (file-name-nondirectory (nth 2 (car locations)))
+ (file-name-nondirectory (ada-file-of identlist))))
+ (setq locations (cadr locations)
+ line (car locations)
+ col (nth 1 locations)
+ file (nth 2 locations)
+ locations nil)
+ (set 'locations (cdr locations))))
+
+ ;; Find the file in the source path
+ (set 'file (ada-get-ada-file-name file (ada-file-of identlist)))
+
+ ;; Kill the .ali buffer
+ (kill-buffer (current-buffer))
;; Now go to the buffer
- (ada-xref-change-buffer
- (ada-get-ada-file-name file (ada-file-of identlist))
- (string-to-number line)
- (1- (string-to-number col))
- identlist
- other-frame)
+ (ada-xref-change-buffer file
+ (string-to-number line)
+ (1- (string-to-number col))
+ identlist
+ other-frame)
))
+(defun ada-find-in-src-path (identlist &optional other-frame)
+ "More general function for cross-references.
+This function should be used when the standard algorithm that parses the
+.ali file has failed, either because that file was too old or even did not
+exist.
+This function attempts to find the possible declarations for the identifier
+anywhere in the object path.
+This command requires the external `egrep' program to be available.
+
+This works well when one is using an external librarie and wants
+to find the declaration and documentation of the subprograms one is
+is using."
+;; FIXME: what does this function do?
+ (let (list
+ (dirs (ada-xref-get-obj-dir-field))
+ (regexp (concat "[ *]" (ada-name-of identlist)))
+ line column
+ 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.
+
+ (set-buffer (get-buffer-create "*grep*"))
+ (while dirs
+ (insert (shell-command-to-string
+ (concat
+ "grep -E -i -h "
+ (shell-quote-argument (concat "^X|" regexp "( |$)"))
+ " "
+ (shell-quote-argument (file-name-as-directory (car dirs)))
+ "*.ali")))
+ (set 'dirs (cdr dirs)))
+
+ ;; Now parse the output
+ (set 'case-fold-search t)
+ (goto-char (point-min))
+ (while (re-search-forward regexp nil t)
+ (save-excursion
+ (beginning-of-line)
+ (if (not (= (char-after) ?X))
+ (progn
+ (looking-at "\\([0-9]+\\).\\([0-9]+\\)")
+ (setq line (match-string 1)
+ column (match-string 2))
+ (re-search-backward "^X [0-9]+ \\(.*\\)$")
+ (set 'file (list (match-string 1) line column))
+
+ ;; There could be duplicate choices, because of the structure
+ ;; of the .ali files
+ (unless (member file list)
+ (set 'list (append list (list file))))))))
+
+ ;; Current buffer is still "*grep*"
+ (kill-buffer "*grep*")
+ )
+
+ ;; Now display the list of possible matches
+ (cond
+
+ ;; No choice found => Error
+ ((null list)
+ (error "No cross-reference found, please recompile your file"))
+
+ ;; Only one choice => Do the cross-reference
+ ((= (length list) 1)
+ (set 'file (ada-find-src-file-in-dir (caar list)))
+ (if file
+ (ada-xref-change-buffer file
+ (string-to-number (nth 1 (car list)))
+ (string-to-number (nth 2 (car list)))
+ identlist
+ other-frame)
+ (error (concat (caar list) " not found in src_dir")))
+ (message "This is only a (good) guess at the cross-reference.")
+ )
+
+ ;; Else, ask the user
+ (t
+ (save-window-excursion
+ (with-output-to-temp-buffer "*choice list*"
+
+ (princ "Identifier is overloaded and Xref information is not up to date.\n")
+ (princ "Possible declarations are:\n\n")
+ (princ " no. in file at line col\n")
+ (princ " --- --------------------- ---- ----\n")
+ (let ((counter 0))
+ (while (< counter (length list))
+ (princ (format " %2d) %-21s %4s %4s\n"
+ (1+ counter)
+ (nth 0 (nth counter list))
+ (nth 1 (nth counter list))
+ (nth 2 (nth counter list))
+ ))
+ (setq counter (1+ counter))
+ )))
+ (setq choice nil)
+ (while (or (not choice)
+ (not (integerp choice))
+ (< choice 1)
+ (> choice (length list)))
+ (setq choice
+ (string-to-number
+ (read-from-minibuffer "Enter No. of your choice: "))))
+ )
+ (set 'choice (1- choice))
+ (kill-buffer "*choice list*")
+
+ (set 'file (ada-find-src-file-in-dir (car (nth choice list))))
+ (if file
+ (ada-xref-change-buffer file
+ (string-to-number (nth 1 (nth choice list)))
+ (string-to-number (nth 2 (nth choice list)))
+ identlist
+ other-frame)
+ (signal 'error-file-not-found (car (nth choice list))))
+ (message "This is only a (good) guess at the cross-reference.")
+ ))))
+
(defun ada-xref-change-buffer
(file line column identlist &optional other-frame)
- "Select and display FILE, at LINE and COLUMN. The new file is
-associated with the same project file as the one for IDENTLIST.
+ "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.
+match. Kills the .ali buffer at the end.
If OTHER-FRAME is non-nil, creates a new frame to show the file."
- (let (prj-file
- declaration-buffer
- (ali-buffer (current-buffer)))
-
- ;; get the current project file for the source ada file
- (save-excursion
- (set-buffer (get-file-buffer (ada-file-of identlist)))
- (set 'prj-file ada-prj-prj-file))
+ (let (declaration-buffer)
;; Select and display the destination buffer
(if ada-xref-other-buffer
- (if other-frame
- (find-file-other-frame file)
- (set 'declaration-buffer (find-file-noselect file))
- (set-buffer declaration-buffer)
- (switch-to-buffer-other-window declaration-buffer)
- )
+ (if other-frame
+ (find-file-other-frame file)
+ (set 'declaration-buffer (find-file-noselect file))
+ (set-buffer declaration-buffer)
+ (switch-to-buffer-other-window declaration-buffer)
+ )
(find-file file)
)
- ;; If the new buffer is not already associated with a project file, do it
- (unless (my-local-variable-if-set-p 'ada-prj-prj-file (current-buffer))
- (set (make-local-variable 'ada-prj-prj-file) prj-file))
-
;; move the cursor to the correct position
(push-mark)
(goto-line line)
;; this is probably the right one.
(unless (looking-at (ada-name-of identlist))
(ada-xref-search-nearest (ada-name-of identlist)))
-
- (kill-buffer ali-buffer)))
+ ))
(defun ada-xref-search-nearest (name)
- "Searches for NAME nearest to the position recorded in the Xref file.
-It returns the position of the declaration in the buffer or nil if not found."
+ "Search for NAME nearest to the position recorded in the Xref file.
+Return the position of the declaration in the buffer, or nil if not found."
(let ((orgpos (point))
- (newpos nil)
- (diff nil))
+ (newpos nil)
+ (diff nil))
(goto-char (point-max))
;; check if it really is a complete Ada identifier
(if (and
- (not (save-excursion
- (goto-char (match-end 0))
- (looking-at "_")))
- (not (ada-in-string-or-comment-p))
- (or
- ;; variable declaration ?
- (save-excursion
- (skip-chars-forward "a-zA-Z_0-9" )
- (ada-goto-next-non-ws)
- (looking-at ":[^=]"))
- ;; procedure, function, task or package declaration ?
- (save-excursion
- (ada-goto-previous-word)
- (looking-at "\\<[pP][rR][oO][cC][eE][dD][uU][rR][eE]\\>\\|\\<[fF][uU][nN][cC][tT][iI][oO][nN]\\>\\|\\<[tT][yY][pP][eE]\\>\\|\\<[tT][aA][sS][kK]\\>\\|\\<[pP][aA][cC][kK][aA][gG][eE]\\>\\|\\<[bB][oO][dD][yY]\\>"))))
-
- ;; check if it is nearer than the ones before if any
- (if (or (not diff)
- (< (abs (- (point) orgpos)) diff))
- (progn
- (setq newpos (point)
+ (not (save-excursion
+ (goto-char (match-end 0))
+ (looking-at "_")))
+ (not (ada-in-string-or-comment-p))
+ (or
+ ;; variable declaration ?
+ (save-excursion
+ (skip-chars-forward "a-zA-Z_0-9" )
+ (ada-goto-next-non-ws)
+ (looking-at ":[^=]"))
+ ;; procedure, function, task or package declaration ?
+ (save-excursion
+ (ada-goto-previous-word)
+ (looking-at "\\<[pP][rR][oO][cC][eE][dD][uU][rR][eE]\\>\\|\\<[fF][uU][nN][cC][tT][iI][oO][nN]\\>\\|\\<[tT][yY][pP][eE]\\>\\|\\<[tT][aA][sS][kK]\\>\\|\\<[pP][aA][cC][kK][aA][gG][eE]\\>\\|\\<[bB][oO][dD][yY]\\>"))))
+
+ ;; check if it is nearer than the ones before if any
+ (if (or (not diff)
+ (< (abs (- (point) orgpos)) diff))
+ (progn
+ (setq newpos (point)
diff (abs (- newpos orgpos))))))
)
(if newpos
- (progn
- (message "ATTENTION: this declaration is only a (good) guess ...")
- (goto-char newpos))
+ (progn
+ (message "ATTENTION: this declaration is only a (good) guess ...")
+ (goto-char newpos))
nil)))
(ada-require-project-file)
(let ((buffer (ada-get-ali-buffer (buffer-file-name)))
- (unit-name nil)
- (body-name nil)
- (ali-name nil))
+ (unit-name nil)
+ (body-name nil)
+ (ali-name nil))
(save-excursion
(set-buffer buffer)
(goto-char (point-min))
(re-search-forward "^U \\([^ \t%]+\\)%[bs][ \t]+\\([^ \t]+\\)")
(setq unit-name (match-string 1))
(if (not (string-match "\\(.*\\)\\.[^.]+" unit-name))
- (progn
- (kill-buffer buffer)
- (error "No parent unit !"))
- (setq unit-name (match-string 1 unit-name))
- )
+ (progn
+ (kill-buffer buffer)
+ (error "No parent unit !"))
+ (setq unit-name (match-string 1 unit-name))
+ )
;; look for the file name for the parent unit specification
(goto-char (point-min))
(re-search-forward (concat "^W " unit-name
- "%s[ \t]+\\([^ \t]+\\)[ \t]+"
- "\\([^ \t\n]+\\)"))
+ "%s[ \t]+\\([^ \t]+\\)[ \t]+"
+ "\\([^ \t\n]+\\)"))
(setq body-name (match-string 1))
(setq ali-name (match-string 2))
(kill-buffer buffer)
(save-excursion
;; Tries to open the new ali file to find the spec file
(if ali-name
- (progn
- (find-file ali-name)
- (goto-char (point-min))
- (re-search-forward (concat "^U " unit-name "%s[ \t]+"
- "\\([^ \t]+\\)"))
- (setq body-name (match-string 1))
- (kill-buffer (current-buffer))
- )
- )
+ (progn
+ (find-file ali-name)
+ (goto-char (point-min))
+ (re-search-forward (concat "^U " unit-name "%s[ \t]+"
+ "\\([^ \t]+\\)"))
+ (setq body-name (match-string 1))
+ (kill-buffer (current-buffer))
+ )
+ )
)
(find-file body-name)
(save-excursion
(set-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
- adaname ada-krunch-args)
+ (concat adaname ".adb") ada-krunch-args)
;; fetch output of that process
(setq adaname (buffer-substring
- (point-min)
- (progn
- (goto-char (point-min))
- (end-of-line)
- (point))))
+ (point-min)
+ (progn
+ (goto-char (point-min))
+ (end-of-line)
+ (point))))
+ ;; Remove the extra extension we added above
+ (setq adaname (substring adaname 0 -4))
+
(kill-buffer krunch-buf)))
adaname
)
-(defun ada-make-body-gnatstub ()
+(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.
This function typically is to be hooked into `ff-file-created-hooks'."
- (interactive)
+ (interactive "p")
(save-some-buffers nil nil)
- (ada-require-project-file)
+ ;; If the current buffer is the body (as is the case when calling this
+ ;; function from ff-file-created-hooks), then kill this temporary buffer
+ (unless interactive
+ (progn
+ (set-buffer-modified-p nil)
+ (kill-buffer (current-buffer))))
+
+
+ ;; 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)
- (delete-region (point-min) (point-max))
+ (unless (buffer-file-name (car (buffer-list)))
+ (set-buffer (cadr (buffer-list))))
+
+ ;; Make sure we have a project file (for parameters to gnatstub). Note that
+ ;; this might have already been done if we have been called from the hook,
+ ;; but this is not an expensive call)
+ (ada-require-project-file)
;; Call the external process gnatstub
(let* ((gnatstub-opts (ada-treat-cmd-string ada-gnatstub-opts))
- (filename (buffer-file-name (car (cdr (buffer-list)))))
- (output (concat (file-name-sans-extension filename) ".adb"))
- (gnatstub-cmd (concat "gnatstub " gnatstub-opts " " filename))
- (buffer (get-buffer-create "*gnatstub*")))
+ (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)
(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))
+ (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))
;; Else clean up the output
- ;; Kill the temporary buffer created by find-file
- (set-buffer-modified-p nil)
- (kill-buffer (current-buffer))
-
(if (file-exists-p output)
- (progn
- (find-file output)
- (kill-buffer buffer))
+ (progn
+ (find-file output)
+ (kill-buffer buffer))
- ;; display the error buffer
- (display-buffer buffer)
- )
+ ;; display the error buffer
+ (display-buffer buffer)
+ )
)))
-
(defun ada-xref-initialize ()
- "Function called by ada-mode-hook to initialize the ada-xref.el package.
-For instance, it creates the gnat-specific menus, set some hooks for
+ "Function called by `ada-mode-hook' to initialize the ada-xref.el package.
+For instance, it creates the gnat-specific menus, sets some hooks for
find-file...."
- (make-local-hook 'ff-file-created-hooks)
- (setq ff-file-created-hooks 'ada-make-body-gnatstub)
-
- ;; Read the project file and update the search path
- ;; before looking for the other file
- (make-local-hook 'ff-pre-find-hooks)
- (add-hook 'ff-pre-find-hooks 'ada-require-project-file)
+ ;; This should really be an `add-hook'. -stef
+ (setq ff-file-created-hook 'ada-make-body-gnatstub)
;; Completion for file names in the mini buffer should ignore .ali files
(add-to-list 'completion-ignored-extensions ".ali")
- )
+ (ada-xref-update-project-menu)
+ )
;; ----- Add to ada-mode-hook ---------------------------------------------
-;; Set the keymap once and for all, so that the keys set by the user in his
-;; config file are not overwritten every time we open a new file.
-(ada-add-ada-menu)
-(ada-add-keymap)
-
+;; This must be done before initializing the Ada menu.
(add-hook 'ada-mode-hook 'ada-xref-initialize)
-;; Use ddd as the default debugger if it was found
-(if (ada-find-file-in-dir "ddd" exec-path)
- (set 'ada-prj-default-debugger "ddd --tty -fullname -toolbar"))
+;; Define a new error type
+(put 'error-file-not-found
+ 'error-conditions
+ '(error ada-mode-errors error-file-not-found))
+(put 'error-file-not-found
+ 'error-message
+ "File not found in src-dir (check project file): ")
;; Initializes the cross references to the runtime library
-(ada-initialize-runtime-library)
+(ada-initialize-runtime-library "")
;; Add these standard directories to the search path
-(set 'ada-search-directories
+(set 'ada-search-directories-internal
(append (mapcar 'directory-file-name ada-xref-runtime-library-specs-path)
ada-search-directories))
-;; Make sure that the files are always associated with a project file. Since
-;; the project file has some fields that are used for the editor (like the
-;; casing exceptions), it has to be read before the user edits a file).
-(add-hook 'ada-mode-hook
- (lambda()
- (let ((file (ada-prj-find-prj-file t)))
- (if file (ada-reread-prj-file file)))))
-
(provide 'ada-xref)
+;;; arch-tag: 415a39fe-577b-4676-b3b1-6ff6db7ca24e
;;; ada-xref.el ends here