comparison lisp/progmodes/ada-xref.el @ 56766:e8b5658b7aac

Many doc and style fixes. (ada-find-any-references): Use compilation-start. (ada-get-ali-file-name): Improve error msg. (ada-get-ada-file-name): Likewise.

56765:3c6aa215e03f

;;; 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:

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 will never run gcc."
  :type 'boolean :group 'ada)

(defcustom ada-xref-confirm-compile nil
  "*If non-nil, always ask for user confirmation before compiling or running
the application."
  :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 when the location of the runtime is searched.
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."

(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} "

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.

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 ""

(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 when sending 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.")

;; -----------------------------------------------------------------------

(defun ada-quote-cmd (cmd)
  "Duplicates all \\ characters in CMD so that it can be passed to `compile'"
  (mapconcat 'identity (split-string cmd "\\\\") "\\\\"))

(defun ada-initialize-runtime-library (cross-prefix)
  "Initializes 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)

  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 ""))

(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

	;;  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

	      )

	  ;;  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

	(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
P")
  (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)))

                               (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
P")
  (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 only the references in file will be listed, which
is much faster.
If APPEND is t, then the output of the command will be append to the existing
buffer *gnatfind* if it exists."
  (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

    (if (and append (get-buffer "*gnatfind*"))
	(save-excursion
	  (set-buffer "*gnatfind*")
	  (setq old-contents (buffer-string))))

    (compile-internal command "No more references" "gnatfind")

    ;;  Hide the "Compilation" menu
    (save-excursion
      (set-buffer "*gnatfind*")
      (local-unset-key [menu-bar compilation-menu])

(defalias 'ada-change-prj (symbol-function 'ada-set-default-project-file))

;; ----- Identifier Completion --------------------------------------------
(defun ada-complete-identifier (pos)
  "Tries to complete the identifier around POS.
The feature is only available if the files where compiled not using the -gnatx
option."
  (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

	 ;; 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. It might 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."

	      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, the value of ROOT-DIR is added in
front."
  (mapcar (lambda (x) (expand-file-name x root-dir)) dir-list))

(defun ada-set-environment ()
  "Return the new value for process-environment.
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)))

			 path-separator)
	      objects)
      process-environment))))

(defun ada-compile-application (&optional arg)
  "Compiles 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))

    (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))))

    ;;  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))))

  (interactive "P")
  (ada-compile-current arg 'check_cmd))

(defun ada-run-application (&optional arg)
  "Run the application.
if ARG is not-nil, asks for user confirmation."
  (interactive)
  (ada-require-project-file)

  (let ((machine (ada-xref-get-project-field 'cross_prefix)))
    (if (and machine (not (string= machine "")))

	     (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)))))

      ;;  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-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*"))

	  (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)

  ;; 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

          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

		    )
		  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 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)

      (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

    (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."

	    (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."))
	    )))

	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

(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 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

;; ----- 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 ")

56766:e8b5658b7aac

;;; 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:

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."

(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} "

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.

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 ""

(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.")

;; -----------------------------------------------------------------------

(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)

  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 ""))

(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

	;;  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

	      )

	  ;;  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

	(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)))

                               (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

    (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])

(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

	 ;; 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."

	      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)))

			 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))

    (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))))

    ;;  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))))

  (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 "")))

	     (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)))))

      ;;  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-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*"))

	  (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)

  ;; 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

          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

		    )
		  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)

      (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

    (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."

	    (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."))
	    )))

	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

(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 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

;; ----- 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 ")