emacs-diffs
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Emacs-diffs] Changes to emacs/lisp/progmodes/ada-xref.el [gnus-5_10-bra


From: Miles Bader
Subject: [Emacs-diffs] Changes to emacs/lisp/progmodes/ada-xref.el [gnus-5_10-branch]
Date: Sat, 04 Sep 2004 08:15:06 -0400

Index: emacs/lisp/progmodes/ada-xref.el
diff -c /dev/null emacs/lisp/progmodes/ada-xref.el:1.18.2.1
*** /dev/null   Sat Sep  4 12:02:09 2004
--- emacs/lisp/progmodes/ada-xref.el    Sat Sep  4 12:01:10 2004
***************
*** 0 ****
--- 1,2265 ----
+ ;;; ada-xref.el --- for lookup and completion in Ada mode
+ 
+ ;; Copyright (C) 1994, 95, 96, 97, 98, 99, 2000, 2001, 2002, 2003
+ ;;    Free Software Foundation, Inc.
+ 
+ ;; Author: Markus Heritsch <address@hidden>
+ ;;      Rolf Ebert <address@hidden>
+ ;;      Emmanuel Briot <address@hidden>
+ ;; Maintainer: Emmanuel Briot <address@hidden>
+ ;; Ada Core Technologies's version:   Revision: 1.181
+ ;; Keywords: languages ada xref
+ 
+ ;; This file is part of GNU Emacs.
+ 
+ ;; GNU Emacs is free software; you can redistribute it and/or modify
+ ;; it under the terms of the GNU General Public License as published by
+ ;; the Free Software Foundation; either version 2, or (at your option)
+ ;; any later version.
+ 
+ ;; GNU Emacs is distributed in the hope that it will be useful,
+ ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ ;; GNU General Public License for more details.
+ 
+ ;; You should have received a copy of the GNU General Public License
+ ;; along with GNU Emacs; see the file COPYING.  If not, write to the
+ ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+ ;; Boston, MA 02111-1307, 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.
+ ;;;
+ ;;; If a file *.`adp' exists in the ada-file directory, then it is
+ ;;; 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
+ 
+ ;;; Code:
+ 
+ ;; ----- Requirements -----------------------------------------------------
+ 
+ (require 'compile)
+ (require 'comint)
+ (require 'find-file)
+ (require 'ada-mode)
+ 
+ ;; ------ Use 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 nil
+   "*If non-nil, run gcc whenever the cross-references are not up-to-date.
+ If nil, the cross-reference mode never runs gcc."
+   :type 'boolean :group 'ada)
+ 
+ (defcustom ada-xref-confirm-compile nil
+   "*If non-nil, 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."
+   :type 'string :group 'ada)
+ 
+ (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)
+ 
+ (defcustom ada-prj-default-bind-opt ""
+   "Default binder options."
+   :type 'string :group 'ada)
+ 
+ (defcustom ada-prj-default-link-opt ""
+   "Default linker options."
+   :type 'string :group 'ada)
+ 
+ (defcustom ada-prj-default-gnatmake-opt "-g"
+   "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-comp-cmd
+   (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."
+   :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'."
+   :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}")
+   "*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."
+   :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.
+ This has the same syntax as in the project file (with variable substitution)."
+   :type 'string :group 'ada)
+ 
+ (defcustom ada-always-ask-project nil
+   "*If nil, use default values when no project file was found.
+ 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.")
+ 
+ (defconst ada-project-file-extension ".adp"
+   "The extension used for project files.")
+ 
+ (defvar ada-xref-runtime-library-specs-path '()
+   "Directories where the specs for the standard library is found.
+ This is used for cross-references.")
+ 
+ (defvar ada-xref-runtime-library-ali-path '()
+   "Directories where the ali for the standard library is found.
+ This is used for cross-references.")
+ 
+ (defvar ada-xref-pos-ring '()
+   "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.")
+ 
+ (defvar ada-operator-re
+   
"\\+\\|-\\|/\\|\\*\\*\\|\\*\\|=\\|&\\|abs\\|mod\\|rem\\|and\\|not\\|or\\|xor\\|<=\\|<\\|>=\\|>"
+   "Regexp to match for operators.")
+ 
+ (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.")
+ 
+ 
+ ;; ----- 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)))
+ 
+ 
+ ;; -----------------------------------------------------------------------
+ 
+ (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-initialize-runtime-library (cross-prefix)
+   "Initialize the variables for the runtime library location.
+ CROSS-PREFIX is the prefix to use for the gnatls command."
+   (save-excursion
+     (setq ada-xref-runtime-library-specs-path '()
+         ada-xref-runtime-library-ali-path   '())
+     (set-buffer (get-buffer-create "*gnatls*"))
+     (widen)
+     (erase-buffer)
+     ;;  Catch any error in the following form (i.e gnatls was not found)
+     (condition-case nil
+       ;;  Even if we get an error, delete the *gnatls* buffer
+       (unwind-protect
+           (progn
+             (apply 'call-process (concat cross-prefix "gnatls")
+                    (append '(nil t nil) ada-gnatls-args))
+             (goto-char (point-min))
+ 
+             ;;  Source path
+ 
+             (search-forward "Source Search Path:")
+             (forward-line 1)
+             (while (not (looking-at "^$"))
+               (back-to-indentation)
+               (if (looking-at "<Current_Directory>")
+                   (add-to-list 'ada-xref-runtime-library-specs-path  ".")
+                 (add-to-list 'ada-xref-runtime-library-specs-path
+                              (buffer-substring-no-properties
+                               (point)
+                                 (save-excursion (end-of-line) (point)))))
+               (forward-line 1))
+ 
+             ;;  Object path
+ 
+             (search-forward "Object Search Path:")
+             (forward-line 1)
+             (while (not (looking-at "^$"))
+               (back-to-indentation)
+               (if (looking-at "<Current_Directory>")
+                   (add-to-list 'ada-xref-runtime-library-ali-path ".")
+                 (add-to-list 'ada-xref-runtime-library-ali-path
+                              (buffer-substring-no-properties
+                               (point)
+                               (save-excursion (end-of-line) (point)))))
+               (forward-line 1))
+             )
+           (kill-buffer nil))
+       (error nil))
+     (set 'ada-xref-runtime-library-specs-path
+        (reverse ada-xref-runtime-library-specs-path))
+     (set 'ada-xref-runtime-library-ali-path
+        (reverse ada-xref-runtime-library-ali-path))
+     ))
+ 
+ 
+ (defun ada-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, and ${full_current} is
+ replaced by the name including the extension."
+ 
+   (while (string-match "\\(-[^-\$IO]*[IO]\\)?\${\\([^}]+\\)}" cmd-string)
+     (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
+         (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 (concat "No environment variable " name " found"))))
+ 
+       (cond
+        ((null value)
+       (setq cmd-string (replace-match "" t t cmd-string)))
+        ((stringp value)
+       (setq cmd-string (replace-match value t t cmd-string)))
+        ((listp value)
+       (let ((prefix (match-string 1 cmd-string)))
+         (setq cmd-string (replace-match
+                           (mapconcat (lambda(x) (concat prefix x)) value " ")
+                           t t cmd-string)))))
+       ))
+   cmd-string)
+ 
+ (defun ada-xref-set-default-prj-values (symbol ada-buffer)
+   "Reset the properties in SYMBOL to the default values for ADA-BUFFER."
+ 
+   (let ((file      (buffer-file-name ada-buffer))
+       plist)
+     (save-excursion
+       (set-buffer ada-buffer)
+ 
+       (set 'plist
+          ;;  Try hard to find a 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 (expand-file-name
+                           (cond
+                            (ada-prj-default-project-file
+                             ada-prj-default-project-file)
+                            (file (ada-prj-find-prj-file file t))
+                            (t
+                             (message (concat "Not editing an Ada file,"
+                                              "and no default project "
+                                              "file specified!"))
+                             "")))
+                'build_dir       (file-name-as-directory (expand-file-name 
"."))
+                'src_dir         (list ".")
+                'obj_dir         (list ".")
+                'casing          (if (listp ada-case-exception-file)
+                                     ada-case-exception-file
+                                   (list ada-case-exception-file))
+                'comp_opt        ada-prj-default-comp-opt
+                'bind_opt        ada-prj-default-bind-opt
+                'link_opt        ada-prj-default-link-opt
+                'gnatmake_opt    ada-prj-default-gnatmake-opt
+                'gnatfind_opt    ada-prj-gnatfind-switches
+                'main            (if file
+                                     (file-name-nondirectory
+                                      (file-name-sans-extension file))
+                                   "")
+                'main_unit       (if file
+                                     (file-name-nondirectory
+                                      (file-name-sans-extension file))
+                                   "")
+                'cross_prefix    ""
+                'remote_machine  ""
+                'comp_cmd        (list (concat ada-cd-command " ${build_dir}")
+                                       ada-prj-default-comp-cmd)
+                'check_cmd       (list (concat ada-prj-default-comp-cmd " "
+                                               ada-check-switch))
+                'make_cmd        (list (concat ada-cd-command " ${build_dir}")
+                                       ada-prj-default-make-cmd)
+                'run_cmd         (list (concat ada-cd-command " ${build_dir}")
+                                       (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}"))
+                'debug_post_cmd  (list nil)))
+       )
+     (set symbol plist)))
+ 
+ (defun ada-xref-get-project-field (field)
+   "Extract the value of FIELD from the current project file.
+ The project file must have been loaded first.
+ A default value is returned if the file was not found.
+ 
+ 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-default-project-file)
+       file value)
+ 
+     ;;  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
+       (set 'value (plist-get (cdr file) field))
+ 
+       ;; 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))
+       )
+ 
+     ;;  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-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-project-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."
+   (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 a file 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")))))
+ 
+ 
+ ;; ----- Utilities -------------------------------------------------
+ 
+ (defun ada-require-project-file ()
+   "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))
+   (if (> (length ada-xref-pos-ring) ada-xref-pos-ring-max)
+       (setcdr (nthcdr (1- ada-xref-pos-ring-max) ada-xref-pos-ring) nil)))
+ 
+ (defun ada-xref-goto-previous-reference ()
+   "Go to the previous cross-reference we were on."
+   (interactive)
+   (if ada-xref-pos-ring
+       (let ((pos (car ada-xref-pos-ring)))
+       (setq ada-xref-pos-ring (cdr ada-xref-pos-ring))
+       (find-file (car (cdr pos)))
+       (goto-char (car pos)))))
+ 
+ (defun ada-convert-file-name (name)
+   "Converts 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)
+ 
+ (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:")
+   (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 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."
+ 
+   (let (selected)
+ 
+     ;;  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)))
+ 
+       (if (and ada-prj-default-project-file
+                (not (string= ada-prj-default-project-file "")))
+           (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-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))
+ 
+       (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-int
+                           (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."
+   (if prj-file
+       (let (project src_dir obj_dir make_cmd comp_cmd check_cmd casing
+                   run_cmd debug_pre_cmd debug_post_cmd
+             (ada-buffer (current-buffer)))
+       (setq prj-file (expand-file-name prj-file))
+ 
+       ;;  Set the project file as the active one.
+       (setq ada-prj-default-project-file prj-file)
+ 
+       ;;  Initialize the project with the default values
+       (ada-xref-set-default-prj-values 'project (current-buffer))
+ 
+       ;;  Do not use find-file below, since we don't want to show this
+       ;;  buffer.  If the file is open through speedbar, we can't use
+       ;;  find-file anyway, since the speedbar frame is special and does not
+       ;;  allow the selection of a file in it.
+ 
+       (if (file-exists-p prj-file)
+           (progn
+             (let* ((buffer (run-hook-with-args-until-success
+                             'ada-load-project-hook prj-file)))
+               (unless buffer
+                 (setq buffer (find-file-noselect prj-file nil)))
+               (set-buffer buffer))
+ 
+             (widen)
+             (goto-char (point-min))
+ 
+             ;;  Now overrides these values with the project file
+             (while (not (eobp))
+               (if (looking-at "^\\([^=]+\\)=\\(.*\\)")
+                   (cond
+                    ((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
+                     (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))))
+             (set 'project (plist-put project 'debug_post_cmd
+                                      (reverse debug_post_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-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
+       (setq ada-search-directories-internal
+            (append (mapcar 'directory-file-name compilation-search-path)
+                    ada-search-directories))
+ 
+       (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 arg local-only)
+   "Find all references to the entity under POS.
+ Calls gnatfind to find the references.
+ If ARG is t, the contents of the old *gnatfind* buffer is preserved.
+ If LOCAL-ONLY is t, only the declarations in the current file are returned."
+   (interactive "d\nP")
+   (ada-require-project-file)
+ 
+   (let* ((identlist (ada-read-identifier pos))
+          (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 local-only arg)
+       (ada-find-any-references (ada-name-of identlist)
+                                (ada-file-of identlist)
+                                (ada-line-of identlist)
+                                (ada-column-of identlist) local-only arg)))
+   )
+ 
+ (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.
+ 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)
+ 
+   ;;  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 (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))))
+ 
+     (let ((compilation-error "reference"))
+       (compilation-start command))
+ 
+     ;;  Hide the "Compilation" menu
+     (save-excursion
+       (set-buffer "*gnatfind*")
+       (local-unset-key [menu-bar compilation-menu])
+ 
+       (if old-contents
+         (progn
+           (goto-char 1)
+           (insert old-contents)
+           (goto-char (point-max)))))
+     )
+   )
+ 
+ (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 without
+ the option `-gnatx'."
+   (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))
+ 
+     ;; Open the .ali file
+     (set-buffer (ada-get-ali-buffer (buffer-file-name)))
+     (goto-char (point-max))
+ 
+     ;; build an alist of possible completions
+     (while (re-search-backward sofar nil t)
+       (setq symalist (cons (cons (match-string 1) nil) symalist)))
+ 
+     (setq completed  (try-completion "" symalist))
+ 
+     ;; kills .ali buffer
+     (kill-buffer nil)
+ 
+     ;; deletes the incomplete identifier in the buffer
+     (set-buffer curbuf)
+     (looking-at "[a-zA-Z0-9_]+")
+     (replace-match "")
+     ;; inserts the completed symbol
+     (insert completed)
+     ))
+ 
+ ;; ----- Cross-referencing ----------------------------------------
+ 
+ (defun ada-point-and-xref ()
+   "Jump to the declaration of the entity below the cursor."
+   (interactive)
+   (mouse-set-point last-input-event)
+   (ada-goto-declaration (point)))
+ 
+ (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.
+ 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.
+ 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)
+ 
+   ;;  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 nil
+       (ada-find-in-ali identlist other-frame)
+       (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-goto-declaration pos t))
+ 
+ (defun ada-remote (command)
+   "Return the remote version of COMMAND, or COMMAND if remote_machine is nil."
+   (let ((machine (ada-xref-get-project-field 'remote_machine)))
+     (if (or (not machine) (string= machine ""))
+       command
+       (format "%s %s '(%s)'"
+             remote-shell-program
+             machine
+             command))))
+ 
+ (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, add the value of ROOT-DIR in front."
+   (mapcar (lambda (x) (expand-file-name x root-dir)) dir-list))
+ 
+ (defun ada-set-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 path-separator include)))
+     (if objects
+       (set 'objects (concat path-separator objects)))
+     (cons
+      (concat "ADA_INCLUDE_PATH="
+            (mapconcat (lambda(x) (expand-file-name x build-dir))
+                       (ada-xref-get-project-field 'src_dir)
+                       path-separator)
+            include)
+      (cons
+       (concat "ADA_OBJECTS_PATH="
+             (mapconcat (lambda(x) (expand-file-name x build-dir))
+                        (ada-xref-get-project-field 'obj_dir)
+                        path-separator)
+             objects)
+       process-environment))))
+ 
+ (defun ada-compile-application (&optional arg)
+   "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)
+   (let ((cmd (ada-xref-get-project-field 'make_cmd))
+       (process-environment (ada-set-environment))
+       (compilation-scroll-output t))
+ 
+     (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))
+ 
+     ;;  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.
+ If ARG is not nil, ask for user confirmation of the command.
+ PRJ-FIELD is the name of the field to use in the project file to get the
+ command, and should be either comp_cmd (default) or check_cmd."
+   (interactive "P")
+   (ada-require-project-file)
+   (let* ((field (if prj-field prj-field 'comp_cmd))
+        (cmd (ada-xref-get-project-field field))
+        (process-environment (ada-set-environment))
+        (compilation-scroll-output t))
+ 
+     (setq compilation-search-path (ada-xref-get-src-dir-field))
+ 
+     (unless cmd
+       (setq cmd '("") arg t))
+ 
+     ;;  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 (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-check-current (&optional arg)
+   "Recompile the current file.
+ If ARG is not nil, ask for user confirmation of the command."
+   (interactive "P")
+   (ada-compile-current arg 'check_cmd))
+ 
+ (defun ada-run-application (&optional arg)
+   "Run the application.
+ if ARG is not-nil, ask for user confirmation."
+   (interactive)
+   (ada-require-project-file)
+ 
+   (let ((machine (ada-xref-get-project-field 'cross_prefix)))
+     (if (and machine (not (string= machine "")))
+       (error "This feature is not supported yet for cross environments")))
+ 
+   (let ((command (ada-xref-get-project-field 'run_cmd)))
+ 
+     ;;  Guess the command if it wasn't specified
+     (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)
+       (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)
+       (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*")
+ 
+     ;;  change to buffer *run* for interactive programs
+     (other-window 1)
+     (switch-to-buffer "*run*")
+     ))
+ 
+ (defun ada-gdb-application (&optional arg executable-name)
+   "Start the debugger on the application.
+ EXECUTABLE-NAME, if non-nil, is debugged instead of the file specified in the
+ project file.
+ If ARG is non-nil, ask the user to confirm the command."
+   (interactive "P")
+   (let ((buffer (current-buffer))
+       cmd pre-cmd post-cmd)
+     (ada-require-project-file)
+     (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
+                         " "
+                         (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)))
+ 
+     (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.
+       (end-of-buffer)
+ 
+       ;;  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."
+   (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 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))
+       (kill-buffer (get-file-buffer ali-file-name)))
+ 
+   (let* ((name      (ada-convert-file-name file))
+        (body-name (or (ada-get-body-name name) name)))
+ 
+     ;; 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."
+   (let (found)
+     (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.
+ 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 (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 (ada-xref-get-src-dir-field)))
+ 
+ (defun ada-get-ali-file-name (file)
+   "Create the ali file name for the ada-file FILE.
+ The file is searched for in every directory shown in the obj_dir lines of
+ the project file."
+ 
+   ;; This function has to handle the special case of non-standard
+   ;; file names (i.e. not .adb or .ads)
+   ;; The trick is the following:
+   ;;   1- replace the extension of the current file with .ali,
+   ;;      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.
+   ;;   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
+         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
+ file for possible paths."
+ 
+   (save-excursion
+ 
+     ;; If the buffer for original-file, use it to get the values from the
+     ;; project file, otherwise load the file and its project file
+     (let ((buffer (get-file-buffer original-file)))
+       (if buffer
+         (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")))
+ 
+       )))
+ 
+ (defun ada-find-file-number-in-ali (file)
+   "Returns the file number for FILE in the associated ali file."
+   (set-buffer (ada-get-ali-buffer file))
+   (goto-char (point-min))
+ 
+   (let ((begin (re-search-forward "^D")))
+     (beginning-of-line)
+     (re-search-forward (concat "^D " (file-name-nondirectory file)))
+     (count-lines begin (point))))
+ 
+ (defun ada-read-identifier (pos)
+   "Returns 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)
+   (skip-chars-backward "a-zA-Z0-9_<>")
+ 
+   ;; check if it really is an identifier
+   (if (ada-in-comment-p)
+       (error "Inside comment"))
+ 
+   (let (identifier identlist)
+     ;; Just in front of a string => we could have an operator declaration,
+     ;; as in "+", "-", ..
+     (if (= (char-after) ?\")
+         (forward-char 1))
+ 
+     ;; if looking at an operator
+     ;; This is only true if:
+     ;;   - the symbol is +, -, ...
+     ;;   - the symbol is made of letters, and not followed by _ or a letter
+     (if (and (looking-at ada-operator-re)
+            (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) 
"\""))))
+ 
+       (if (ada-in-string-p)
+           (error "Inside string or character constant"))
+       (if (looking-at (concat ada-keywords "[^a-zA-Z_]"))
+           (error "No cross-reference available for reserved keyword"))
+       (if (looking-at "[a-zA-Z0-9_]+")
+           (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 1 (point))))
+     (ada-set-column    identlist
+                      (number-to-string (1+ (current-column))))
+     (ada-set-file      identlist (buffer-file-name))
+     identlist
+     ))
+ 
+ (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)."
+ 
+   (let ((ali-buffer (ada-get-ali-buffer (ada-file-of identlist)))
+       declaration-found)
+     (set-buffer ali-buffer)
+     (goto-char (point-min))
+     (ada-set-on-declaration identlist nil)
+ 
+     ;; 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
+              (re-search-forward
+               (concat "^"    (ada-line-of identlist)
+                       "."    (ada-column-of identlist)
+                       "[ *]" (ada-name-of identlist)
+                       "[{\(<= ]?\\(.*\\)$") bound t))
+         (if declaration-found
+             (ada-set-on-declaration identlist t))
+         ))
+ 
+     ;; If declaration is still nil, then we were not on a declaration, and
+     ;; 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))
+       (set 'declaration-found t)
+       (ada-set-ali-index
+        identlist
+        (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]+\\(\n\\.\\)? 
\\)*"
+                                        (ada-line-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
+                   "^[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
+       ;; ali might not be up to date for instance)
+       (if declaration-found
+         (progn
+           (beginning-of-line)
+           ;; while we have a continuation line, go up one line
+           (while (looking-at "^\\.")
+             (previous-line 1))
+           (unless (looking-at (concat "[0-9]+.[0-9]+[ *]"
+                                       (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
+       ;; 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
+         (progn
+           (kill-buffer ali-buffer)
+           (error (concat "No declaration of " (ada-name-of identlist)
+                          " found."))
+           )))
+       )
+ 
+ 
+     ;; 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
+                            (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))
+             )
+ 
+         (if (re-search-backward "^X [0-9]+ \\([a-zA-Z0-9_.-]+\\)" nil t)
+ 
+             ;;  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
+                (kill-buffer ali-buffer)
+                (error (error-message-string err)))
+               ))
+ 
+         (ada-set-references   identlist current-line)
+         ))
+   ))
+ 
+ (defun ada-xref-find-in-modified-ali (identlist)
+   "Find the matching position for IDENTLIST in the current ali buffer.
+ This function is only called when the file was not up-to-date, so we need
+ to make some guesses.
+ This function is disabled for operators, and only works for identifiers."
+ 
+   (unless (= (string-to-char (ada-name-of identlist)) ?\")
+       (progn
+         (let ((declist '()) ;;; ( (line_in_ali_file line_in_ada) ( ... ))
+             (my-regexp  (concat "[ *]"
+                                 (regexp-quote (ada-name-of identlist)) " "))
+             (line-ada "--")
+             (col-ada  "--")
+             (line-ali 0)
+             (len 0)
+             (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 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
+           (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 counter declist))
+                                 (ada-file-of identlist))
+                                  (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-int
+                      (read-from-minibuffer "Enter No. of your choice: "))))
+             )
+           (set-buffer ali-buffer)
+             (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,
+ 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)
+ 
+     ;; 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
+       (if (string-match (concat "[^{(<]\\([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 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."
+ 
+   (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 "egrep -i -h '^X|" regexp "( |$)' "
+                        (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-int
+                (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)
+       (error (concat (car (nth choice list)) " not found in src_dir")))
+       (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.
+ If we do not end on the same identifier as IDENTLIST, find the closest
+ match.  Kills the .ali buffer at the end.
+ If OTHER-FRAME is non-nil, creates a new frame to show the file."
+ 
+   (let (declaration-buffer)
+ 
+     ;; 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)
+           )
+       (find-file file)
+       )
+ 
+     ;; move the cursor to the correct position
+     (push-mark)
+     (goto-line line)
+     (move-to-column column)
+ 
+     ;; If we are not on the identifier, the ali file was not up-to-date.
+     ;; Try to find the nearest position where the identifier is found,
+     ;; this is probably the right one.
+     (unless (looking-at (ada-name-of identlist))
+       (ada-xref-search-nearest (ada-name-of identlist)))
+     ))
+ 
+ 
+ (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."
+   (let ((orgpos (point))
+         (newpos nil)
+         (diff nil))
+ 
+     (goto-char (point-max))
+ 
+     ;; loop - look for all declarations of name in this file
+     (while (search-backward name nil t)
+ 
+       ;; 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)
+                     diff (abs (- newpos orgpos))))))
+       )
+ 
+     (if newpos
+         (progn
+           (message "ATTENTION: this declaration is only a (good) guess ...")
+           (goto-char newpos))
+       nil)))
+ 
+ 
+ ;; Find the parent library file of the current file
+ (defun ada-goto-parent ()
+   "Go to the parent library file."
+   (interactive)
+   (ada-require-project-file)
+ 
+   (let ((buffer (ada-get-ali-buffer (buffer-file-name)))
+         (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))
+         )
+ 
+       ;; 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]+\\)"))
+       (setq body-name (match-string 1))
+       (setq ali-name (match-string 2))
+       (kill-buffer buffer)
+       )
+ 
+     (setq ali-name (ada-find-ali-file-in-dir ali-name))
+ 
+     (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))
+             )
+         )
+       )
+ 
+     (find-file body-name)
+     ))
+ 
+ (defun ada-make-filename-from-adaname (adaname)
+   "Determine the filename in which ADANAME is found.
+ This is a GNAT specific function that uses gnatkrunch."
+   (let (krunch-buf)
+     (setq krunch-buf (generate-new-buffer "*gkrunch*"))
+     (save-excursion
+       (set-buffer krunch-buf)
+       ;; send adaname to external process `gnatkr'.
+       (call-process "gnatkr" nil krunch-buf nil
+                     adaname ada-krunch-args)
+       ;; fetch output of that process
+       (setq adaname (buffer-substring
+                      (point-min)
+                      (progn
+                        (goto-char (point-min))
+                        (end-of-line)
+                        (point))))
+       (kill-buffer krunch-buf)))
+   adaname
+   )
+ 
+ (defun ada-make-body-gnatstub ()
+   "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)
+ 
+   (save-some-buffers nil nil)
+ 
+   ;; 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-p)
+     (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)
+ 
+   (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 (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)
+       (compilation-minor-mode 1)
+       (erase-buffer)
+       (insert gnatstub-cmd)
+       (newline)
+       )
+     ;; call gnatstub to create the body file
+     (call-process shell-file-name nil buffer nil "-c" gnatstub-cmd)
+ 
+     (if (save-excursion
+           (set-buffer buffer)
+           (goto-char (point-min))
+           (search-forward "command not found" nil t))
+         (progn
+           (message "gnatstub was not found -- using the basic algorithm")
+           (sleep-for 2)
+           (kill-buffer buffer)
+           (ada-make-body))
+ 
+       ;; Else clean up the output
+ 
+       (if (file-exists-p output)
+           (progn
+             (find-file output)
+             (kill-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, sets some hooks for
+ find-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 ---------------------------------------------
+ 
+ ;;  Use gvd or ddd as the default debugger if it was found
+ ;;  On windows, do not use the --tty switch for GVD, since this is
+ ;;  not supported.  Actually, we do not use this on Unix either,
+ ;;  since otherwise there is no console window left in GVD,
+ ;;  and people have to use the Emacs one.
+ ;;  This must be done before initializing the Ada menu.
+ (if (ada-find-file-in-dir "gvd" exec-path)
+     (set 'ada-prj-default-debugger "gvd ")
+   (if (ada-find-file-in-dir "gvd.exe" exec-path)
+      (set 'ada-prj-default-debugger "gvd ")
+   (if (ada-find-file-in-dir "ddd" exec-path)
+       (set 'ada-prj-default-debugger "ddd --tty -fullname -toolbar"))))
+ 
+ (add-hook 'ada-mode-hook 'ada-xref-initialize)
+ 
+ ;;  Initializes the cross references to the runtime library
+ (ada-initialize-runtime-library "")
+ 
+ ;;  Add these standard directories to the search path
+ (set 'ada-search-directories-internal
+      (append (mapcar 'directory-file-name ada-xref-runtime-library-specs-path)
+            ada-search-directories))
+ 
+ (provide 'ada-xref)
+ 
+ ;;; arch-tag: 415a39fe-577b-4676-b3b1-6ff6db7ca24e
+ ;;; ada-xref.el ends here




reply via email to

[Prev in Thread] Current Thread [Next in Thread]