(byte-compile-from-buffer): Call byte-compile-warn-about-unresolved-functions
[bpt/emacs.git] / lisp / progmodes / ada-xref.el
CommitLineData
417451fe 1;; ada-xref.el --- for lookup and completion in Ada mode
797aab3c 2
034babe1 3;; Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
d7a0267c 4;; 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
797aab3c
GM
5
6;; Author: Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de>
7;; Rolf Ebert <ebert@inf.enst.fr>
8;; Emmanuel Briot <briot@gnat.com>
417451fe 9;; Maintainer: Stephen Leake <stephen_leake@stephe-leake.org>
797aab3c
GM
10;; Keywords: languages ada xref
11
874d7995 12;; This file is part of GNU Emacs.
797aab3c 13
2be7dabc 14;; GNU Emacs is free software; you can redistribute it and/or modify
797aab3c 15;; it under the terms of the GNU General Public License as published by
1a484753 16;; the Free Software Foundation; either version 3, or (at your option)
797aab3c
GM
17;; any later version.
18
2be7dabc 19;; GNU Emacs is distributed in the hope that it will be useful,
797aab3c
GM
20;; but WITHOUT ANY WARRANTY; without even the implied warranty of
21;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22;; GNU General Public License for more details.
23
24;; You should have received a copy of the GNU General Public License
2be7dabc 25;; along with GNU Emacs; see the file COPYING. If not, write to the
3a35cf56
LK
26;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
27;; Boston, MA 02110-1301, USA.
797aab3c
GM
28
29;;; Commentary:
30;;; This Package provides a set of functions to use the output of the
31;;; cross reference capabilities of the GNAT Ada compiler
32;;; for lookup and completion in Ada mode.
33;;;
797aab3c 34;;; If a file *.`adp' exists in the ada-file directory, then it is
ced16f5d 35;;; read for configuration informations. It is read only the first
797aab3c
GM
36;;; time a cross-reference is asked for, and is not read later.
37
38;;; You need Emacs >= 20.2 to run this package
39
417451fe
JB
40
41;;; History:
42;;
43
3afbc435
PJ
44;;; Code:
45
797aab3c
GM
46;; ----- Requirements -----------------------------------------------------
47
48(require 'compile)
49(require 'comint)
7abe197c
JB
50(require 'find-file)
51(require 'ada-mode)
797aab3c 52
417451fe 53;; ------ User variables
797aab3c 54(defcustom ada-xref-other-buffer t
eec3232e
GM
55 "*If nil, always display the cross-references in the same buffer.
56Otherwise create either a new buffer or a new frame."
797aab3c
GM
57 :type 'boolean :group 'ada)
58
93cdce20 59(defcustom ada-xref-create-ali nil
eec3232e 60 "*If non-nil, run gcc whenever the cross-references are not up-to-date.
ced16f5d 61If nil, the cross-reference mode never runs gcc."
797aab3c
GM
62 :type 'boolean :group 'ada)
63
64(defcustom ada-xref-confirm-compile nil
417451fe 65 "*Non-nil means ask for confirmation before compiling or running the application."
797aab3c
GM
66 :type 'boolean :group 'ada)
67
68(defcustom ada-krunch-args "0"
ced16f5d
RS
69 "*Maximum number of characters for filenames created by `gnatkr'.
70Set to 0, if you don't use crunched filenames. This should be a string."
797aab3c
GM
71 :type 'string :group 'ada)
72
c94ca9e0 73(defcustom ada-gnatls-args '("-v")
f020b5c9 74 "*Arguments to pass to `gnatls' to find location of the runtime.
ced16f5d 75Typical use is to pass `--RTS=soft-floats' on some systems that support it.
c94ca9e0 76
ced16f5d 77You can also add `-I-' if you do not want the current directory to be included.
c94ca9e0 78Otherwise, going from specs to bodies and back will first look for files in the
ced16f5d 79current directory. This only has an impact if you are not using project files,
c94ca9e0
JB
80but only ADA_INCLUDE_PATH."
81 :type '(repeat string) :group 'ada)
82
4884c50b 83(defcustom ada-prj-default-comp-opt "-gnatq -gnatQ"
15ea3b67
GM
84 "Default compilation options."
85 :type 'string :group 'ada)
86
87(defcustom ada-prj-default-bind-opt ""
88 "Default binder options."
89 :type 'string :group 'ada)
90
91(defcustom ada-prj-default-link-opt ""
92 "Default linker options."
93 :type 'string :group 'ada)
94
95(defcustom ada-prj-default-gnatmake-opt "-g"
ced16f5d 96 "Default options for `gnatmake'."
15ea3b67
GM
97 :type 'string :group 'ada)
98
4884c50b 99(defcustom ada-prj-gnatfind-switches "-rf"
ced16f5d
RS
100 "Default switches to use for `gnatfind'.
101You should modify this variable, for instance to add `-a', if you are working
4884c50b 102in an environment where most ALI files are write-protected.
ced16f5d 103The command `gnatfind' is used every time you choose the menu
4884c50b
SM
104\"Show all references\"."
105 :type 'string :group 'ada)
106
0262d5e1
JB
107(defcustom ada-prj-default-check-cmd
108 (concat "${cross_prefix}gnatmake -u -c -gnatc ${gnatmake_opt} ${full_current}"
109 " -cargs ${comp_opt}")
110 "*Default command to be used to compile a single file.
111Emacs will substitute the current filename for ${full_current}, or add
112the filename at the end. This is the same syntax as in the project file."
113 :type 'string :group 'ada)
114
eec3232e 115(defcustom ada-prj-default-comp-cmd
93cdce20
SM
116 (concat "${cross_prefix}gnatmake -u -c ${gnatmake_opt} ${full_current} -cargs"
117 " ${comp_opt}")
797aab3c 118 "*Default command to be used to compile a single file.
417451fe 119Emacs will substitute the current filename for ${full_current}, or add
7977c946 120the filename at the end. This is the same syntax as in the project file."
15ea3b67
GM
121 :type 'string :group 'ada)
122
123(defcustom ada-prj-default-debugger "${cross_prefix}gdb"
417451fe 124 "*Default name of the debugger."
797aab3c
GM
125 :type 'string :group 'ada)
126
127(defcustom ada-prj-default-make-cmd
15ea3b67 128 (concat "${cross_prefix}gnatmake -o ${main} ${main_unit} ${gnatmake_opt} "
417451fe 129 "-cargs ${comp_opt} -bargs ${bind_opt} -largs ${link_opt}")
797aab3c
GM
130 "*Default command to be used to compile the application.
131This is the same syntax as in the project file."
132 :type 'string :group 'ada)
133
134(defcustom ada-prj-default-project-file ""
417451fe
JB
135 "*Name of the current project file.
136Emacs will not try to use the search algorithm to find the project file if
137this string is not empty. It is set whenever a project file is found."
797aab3c
GM
138 :type '(file :must-match t) :group 'ada)
139
140(defcustom ada-gnatstub-opts "-q -I${src_dir}"
ced16f5d 141 "*List of the options to pass to `gnatsub' to generate the body of a package.
eec3232e 142This has the same syntax as in the project file (with variable substitution)."
797aab3c
GM
143 :type 'string :group 'ada)
144
145(defcustom ada-always-ask-project nil
eec3232e 146 "*If nil, use default values when no project file was found.
15ea3b67
GM
147Otherwise, ask the user for the name of the project file to use."
148 :type 'boolean :group 'ada)
797aab3c 149
4884c50b 150(defconst is-windows (memq system-type (quote (windows-nt)))
7977c946 151 "True if we are running on Windows.")
4884c50b
SM
152
153(defcustom ada-tight-gvd-integration nil
154 "*If non-nil, a new Emacs frame will be swallowed in GVD when debugging.
75497862
KS
155If GVD is not the debugger used, nothing happens."
156 :type 'boolean :group 'ada)
4884c50b 157
93cdce20
SM
158(defcustom ada-xref-search-with-egrep t
159 "*If non-nil, use egrep to find the possible declarations for an entity.
160This alternate method is used when the exact location was not found in the
ced16f5d 161information provided by GNAT. However, it might be expensive if you have a lot
93cdce20
SM
162of sources, since it will search in all the files in your project."
163 :type 'boolean :group 'ada)
164
165(defvar ada-load-project-hook nil
166 "Hook that is run when loading a project file.
167Each function in this hook takes one argument FILENAME, that is the name of
168the project file to load.
169This hook should be used to support new formats for the project files.
170
171If the function can load the file with the given filename, it should create a
172buffer that contains a conversion of the file to the standard format of the
ced16f5d
RS
173project files, and return that buffer. (The usual \"src_dir=\" or \"obj_dir=\"
174lines.) It should return nil if it doesn't know how to convert that project
93cdce20
SM
175file.")
176
177
797aab3c
GM
178;; ------- Nothing to be modified by the user below this
179(defvar ada-last-prj-file ""
eec3232e 180 "Name of the last project file entered by the user.")
797aab3c 181
0262d5e1 182(defconst ada-prj-file-extension ".adp"
eec3232e 183 "The extension used for project files.")
797aab3c 184
15ea3b67
GM
185(defvar ada-xref-runtime-library-specs-path '()
186 "Directories where the specs for the standard library is found.
187This is used for cross-references.")
188
189(defvar ada-xref-runtime-library-ali-path '()
190 "Directories where the ali for the standard library is found.
191This is used for cross-references.")
192
797aab3c 193(defvar ada-xref-pos-ring '()
eec3232e
GM
194 "List of positions selected by the cross-references functions.
195Used to go back to these positions.")
797aab3c 196
4884c50b
SM
197(defvar ada-cd-command
198 (if (string-match "cmdproxy.exe" shell-file-name)
199 "cd /d"
200 "cd")
ced16f5d
RS
201 "Command to use to change to a specific directory.
202On Windows systems using `cmdproxy.exe' as the shell,
203we need to use `/d' or the drive is never changed.")
4884c50b
SM
204
205(defvar ada-command-separator (if is-windows " && " "\n")
ced16f5d
RS
206 "Separator to use between multiple commands to `compile' or `start-process'.
207`cmdproxy.exe' doesn't recognize multiple-line commands, so we have to use
4884c50b
SM
208\"&&\" for now.")
209
797aab3c 210(defconst ada-xref-pos-ring-max 16
7977c946 211 "Number of positions kept in the list `ada-xref-pos-ring'.")
797aab3c
GM
212
213(defvar ada-operator-re
15ea3b67 214 "\\+\\|-\\|/\\|\\*\\*\\|\\*\\|=\\|&\\|abs\\|mod\\|rem\\|and\\|not\\|or\\|xor\\|<=\\|<\\|>=\\|>"
eec3232e 215 "Regexp to match for operators.")
797aab3c 216
15ea3b67 217(defvar ada-xref-project-files '()
0262d5e1
JB
218 "Associative list of project files with properties.
219It has the format: (project project ...)
220A project has the format: (project-file . project-plist)
7977c946
JB
221\(See 'apropos plist' for operations on property lists).
222See `ada-xref-set-default-prj-values' for the list of valid properties.
223The current project is retrieved with `ada-xref-current-project'.
224Properties are retrieved with `ada-xref-get-project-field', set with
225`ada-xref-set-project-field'. If project properties are accessed with no
0262d5e1 226project file, a (nil . default-properties) entry is created.")
15ea3b67 227
c94ca9e0
JB
228
229;; ----- Identlist manipulation -------------------------------------------
230;; An identlist is a vector that is used internally to reference an identifier
231;; To facilitate its use, we provide the following macros
232
233(defmacro ada-make-identlist () (make-vector 8 nil))
234(defmacro ada-name-of (identlist) (list 'aref identlist 0))
235(defmacro ada-line-of (identlist) (list 'aref identlist 1))
236(defmacro ada-column-of (identlist) (list 'aref identlist 2))
237(defmacro ada-file-of (identlist) (list 'aref identlist 3))
238(defmacro ada-ali-index-of (identlist) (list 'aref identlist 4))
239(defmacro ada-declare-file-of (identlist) (list 'aref identlist 5))
240(defmacro ada-references-of (identlist) (list 'aref identlist 6))
241(defmacro ada-on-declaration (identlist) (list 'aref identlist 7))
242
243(defmacro ada-set-name (identlist name) (list 'aset identlist 0 name))
244(defmacro ada-set-line (identlist line) (list 'aset identlist 1 line))
245(defmacro ada-set-column (identlist col) (list 'aset identlist 2 col))
246(defmacro ada-set-file (identlist file) (list 'aset identlist 3 file))
247(defmacro ada-set-ali-index (identlist index) (list 'aset identlist 4 index))
248(defmacro ada-set-declare-file (identlist file) (list 'aset identlist 5 file))
249(defmacro ada-set-references (identlist ref) (list 'aset identlist 6 ref))
250(defmacro ada-set-on-declaration (ident value) (list 'aset ident 7 value))
251
252(defsubst ada-get-ali-buffer (file)
417451fe 253 "Read the ali file FILE into a new buffer, and return the buffer's name."
c94ca9e0
JB
254 (find-file-noselect (ada-get-ali-file-name file)))
255
256
257;; -----------------------------------------------------------------------
258
4884c50b 259(defun ada-quote-cmd (cmd)
7977c946 260 "Duplicate all `\\' characters in CMD so that it can be passed to `compile'."
4884c50b 261 (mapconcat 'identity (split-string cmd "\\\\") "\\\\"))
15ea3b67 262
0262d5e1
JB
263(defun ada-find-executable (exec-name)
264 "Find the full path to the executable file EXEC-NAME.
265On Windows systems, this will properly handle .exe extension as well"
266 (or (ada-find-file-in-dir exec-name exec-path)
267 (ada-find-file-in-dir (concat exec-name ".exe") exec-path)
268 exec-name))
269
4884c50b 270(defun ada-initialize-runtime-library (cross-prefix)
ced16f5d 271 "Initialize the variables for the runtime library location.
417451fe 272CROSS-PREFIX is the prefix to use for the `gnatls' command."
15ea3b67 273 (save-excursion
4884c50b
SM
274 (setq ada-xref-runtime-library-specs-path '()
275 ada-xref-runtime-library-ali-path '())
15ea3b67
GM
276 (set-buffer (get-buffer-create "*gnatls*"))
277 (widen)
278 (erase-buffer)
279 ;; Catch any error in the following form (i.e gnatls was not found)
280 (condition-case nil
281 ;; Even if we get an error, delete the *gnatls* buffer
282 (unwind-protect
283 (progn
0262d5e1
JB
284 (let ((gnatls
285 (ada-find-executable (concat cross-prefix "gnatls"))))
286 (apply 'call-process gnatls (append '(nil t nil) ada-gnatls-args)))
15ea3b67
GM
287 (goto-char (point-min))
288
289 ;; Source path
a1506d29 290
15ea3b67
GM
291 (search-forward "Source Search Path:")
292 (forward-line 1)
293 (while (not (looking-at "^$"))
294 (back-to-indentation)
c94ca9e0
JB
295 (if (looking-at "<Current_Directory>")
296 (add-to-list 'ada-xref-runtime-library-specs-path ".")
15ea3b67
GM
297 (add-to-list 'ada-xref-runtime-library-specs-path
298 (buffer-substring-no-properties
299 (point)
300 (save-excursion (end-of-line) (point)))))
301 (forward-line 1))
302
303 ;; Object path
a1506d29 304
15ea3b67
GM
305 (search-forward "Object Search Path:")
306 (forward-line 1)
307 (while (not (looking-at "^$"))
308 (back-to-indentation)
c94ca9e0
JB
309 (if (looking-at "<Current_Directory>")
310 (add-to-list 'ada-xref-runtime-library-ali-path ".")
15ea3b67
GM
311 (add-to-list 'ada-xref-runtime-library-ali-path
312 (buffer-substring-no-properties
313 (point)
314 (save-excursion (end-of-line) (point)))))
315 (forward-line 1))
316 )
317 (kill-buffer nil))
318 (error nil))
319 (set 'ada-xref-runtime-library-specs-path
320 (reverse ada-xref-runtime-library-specs-path))
321 (set 'ada-xref-runtime-library-ali-path
322 (reverse ada-xref-runtime-library-ali-path))
323 ))
324
15ea3b67
GM
325(defun ada-treat-cmd-string (cmd-string)
326 "Replace meta-sequences like ${...} in CMD-STRING with the appropriate value.
417451fe
JB
327Assumes project exists.
328As a special case, ${current} is replaced with the name of the current
329file, minus extension but with directory, and ${full_current} is
4884c50b 330replaced by the name including the extension."
15ea3b67
GM
331
332 (while (string-match "\\(-[^-\$IO]*[IO]\\)?\${\\([^}]+\\)}" cmd-string)
4884c50b
SM
333 (let (value
334 (name (match-string 2 cmd-string)))
335 (cond
336 ((string= name "current")
337 (setq value (file-name-sans-extension (buffer-file-name))))
338 ((string= name "full_current")
339 (setq value (buffer-file-name)))
340 (t
15ea3b67 341 (save-match-data
4884c50b
SM
342 (setq value (ada-xref-get-project-field (intern name))))))
343
344 ;; Check if there is an environment variable with the same name
345 (if (null value)
346 (if (not (setq value (getenv name)))
f020b5c9 347 (message "%s" (concat "No project or environment variable " name " found"))))
a1506d29 348
15ea3b67
GM
349 (cond
350 ((null value)
4884c50b 351 (setq cmd-string (replace-match "" t t cmd-string)))
15ea3b67 352 ((stringp value)
4884c50b 353 (setq cmd-string (replace-match value t t cmd-string)))
15ea3b67
GM
354 ((listp value)
355 (let ((prefix (match-string 1 cmd-string)))
4884c50b 356 (setq cmd-string (replace-match
15ea3b67
GM
357 (mapconcat (lambda(x) (concat prefix x)) value " ")
358 t t cmd-string)))))
359 ))
360 cmd-string)
361
362(defun ada-xref-set-default-prj-values (symbol ada-buffer)
363 "Reset the properties in SYMBOL to the default values for ADA-BUFFER."
364
365 (let ((file (buffer-file-name ada-buffer))
366 plist)
367 (save-excursion
368 (set-buffer ada-buffer)
a1506d29 369
15ea3b67 370 (set 'plist
417451fe
JB
371 ;; Try hard to find a project file, even if the current
372 ;; buffer is not an Ada file or not associated with a file
4884c50b
SM
373 (list 'filename (expand-file-name
374 (cond
4884c50b
SM
375 (ada-prj-default-project-file
376 ada-prj-default-project-file)
c94ca9e0 377 (file (ada-prj-find-prj-file file t))
4884c50b
SM
378 (t
379 (message (concat "Not editing an Ada file,"
380 "and no default project "
381 "file specified!"))
382 "")))
15ea3b67
GM
383 'build_dir (file-name-as-directory (expand-file-name "."))
384 'src_dir (list ".")
385 'obj_dir (list ".")
386 'casing (if (listp ada-case-exception-file)
387 ada-case-exception-file
388 (list ada-case-exception-file))
389 'comp_opt ada-prj-default-comp-opt
390 'bind_opt ada-prj-default-bind-opt
391 'link_opt ada-prj-default-link-opt
392 'gnatmake_opt ada-prj-default-gnatmake-opt
4884c50b 393 'gnatfind_opt ada-prj-gnatfind-switches
15ea3b67 394 'main (if file
4884c50b
SM
395 (file-name-nondirectory
396 (file-name-sans-extension file))
15ea3b67
GM
397 "")
398 'main_unit (if file
399 (file-name-nondirectory
400 (file-name-sans-extension file))
401 "")
402 'cross_prefix ""
403 'remote_machine ""
0262d5e1
JB
404 'comp_cmd (list ada-prj-default-comp-cmd)
405 'check_cmd (list ada-prj-default-check-cmd)
406 'make_cmd (list ada-prj-default-make-cmd)
407 'run_cmd (list (concat "./${main}" (if is-windows ".exe")))
408 'debug_pre_cmd (list (concat ada-cd-command " ${build_dir}"))
15ea3b67 409 'debug_cmd (concat ada-prj-default-debugger
0262d5e1 410 " ${main}" (if is-windows ".exe"))
4884c50b 411 'debug_post_cmd (list nil)))
15ea3b67
GM
412 )
413 (set symbol plist)))
a1506d29 414
15ea3b67 415(defun ada-xref-get-project-field (field)
4884c50b 416 "Extract the value of FIELD from the current project file.
417451fe 417Project variables are substituted.
4884c50b
SM
418
419Note that for src_dir and obj_dir, you should rather use
7977c946
JB
420`ada-xref-get-src-dir-field' or `ada-xref-get-obj-dir-field'
421which will in addition return the default paths."
15ea3b67 422
85187d83
JB
423 (let* ((project-plist (cdr (ada-xref-current-project)))
424 value)
15ea3b67 425
85187d83 426 (set 'value (plist-get project-plist field))
4884c50b
SM
427
428 ;; Substitute the ${...} constructs in all the strings, including
429 ;; inside lists
430 (cond
431 ((stringp value)
432 (ada-treat-cmd-string value))
433 ((null value)
434 nil)
435 ((listp value)
436 (mapcar (lambda(x) (if x (ada-treat-cmd-string x) x)) value))
437 (t
438 value)
439 )
440 ))
441
4884c50b
SM
442(defun ada-xref-get-src-dir-field ()
443 "Return the full value for src_dir, including the default directories.
444All the directories are returned as absolute directories."
445
446 (let ((build-dir (ada-xref-get-project-field 'build_dir)))
447 (append
448 ;; Add ${build_dir} in front of the path
449 (list build-dir)
a1506d29 450
4884c50b
SM
451 (ada-get-absolute-dir-list (ada-xref-get-project-field 'src_dir)
452 build-dir)
a1506d29 453
4884c50b
SM
454 ;; Add the standard runtime at the end
455 ada-xref-runtime-library-specs-path)))
456
457(defun ada-xref-get-obj-dir-field ()
458 "Return the full value for obj_dir, including the default directories.
459All the directories are returned as absolute directories."
460
461 (let ((build-dir (ada-xref-get-project-field 'build_dir)))
462 (append
463 ;; Add ${build_dir} in front of the path
464 (list build-dir)
a1506d29 465
4884c50b
SM
466 (ada-get-absolute-dir-list (ada-xref-get-project-field 'obj_dir)
467 build-dir)
a1506d29 468
4884c50b
SM
469 ;; Add the standard runtime at the end
470 ada-xref-runtime-library-ali-path)))
471
85187d83
JB
472(defun ada-xref-set-project-field (field value)
473 "Set FIELD to VALUE in current project. Assumes project exists."
474 ;; same algorithm to find project-plist as ada-xref-current-project
475 (let* ((file-name (ada-xref-current-project-file))
476 (project-plist (cdr (assoc file-name ada-xref-project-files))))
477
478 (setq project-plist (plist-put project-plist field value))
479 (setcdr (assoc file-name ada-xref-project-files) project-plist)))
480
4884c50b
SM
481(defun ada-xref-update-project-menu ()
482 "Update the menu Ada->Project, with the list of available project files."
96a483d9
SM
483 ;; Create the standard items.
484 (let ((submenu
485 `("Project"
486 ["Load..." ada-set-default-project-file t]
487 ["New..." ada-prj-new t]
488 ["Edit..." ada-prj-edit t]
489 "---"
490 ;; Add the new items
491 ,@(mapcar
492 (lambda (x)
493 (let ((name (or (car x) "<default>"))
494 (command `(lambda ()
495 "Change the active project file."
496 (interactive)
497 (ada-parse-prj-file ,(car x))
498 (set 'ada-prj-default-project-file ,(car x))
499 (ada-xref-update-project-menu))))
500 (vector
501 (if (string= (file-name-extension name)
0262d5e1 502 ada-prj-file-extension)
96a483d9
SM
503 (file-name-sans-extension
504 (file-name-nondirectory name))
505 (file-name-nondirectory name))
506 command
507 :button (cons
508 :toggle
509 (equal ada-prj-default-project-file
510 (car x))
511 ))))
75497862 512
96a483d9
SM
513 ;; Parses all the known project files, and insert at
514 ;; least the default one (in case
515 ;; ada-xref-project-files is nil)
516 (or ada-xref-project-files '(nil))))))
75497862 517
96a483d9 518 (easy-menu-add-item ada-mode-menu '() submenu)))
4884c50b
SM
519
520
521;;-------------------------------------------------------------
522;;-- Searching a file anywhere on the source path.
523;;--
524;;-- The following functions provide support for finding a file anywhere
525;;-- on the source path, without providing an explicit directory.
526;;-- They also provide file name completion in the minibuffer.
527;;--
528;;-- Public subprograms: ada-find-file
529;;--
530;;-------------------------------------------------------------
531
532(defun ada-do-file-completion (string predicate flag)
533 "Completion function when reading a file from the minibuffer.
534Completion is attempted in all the directories in the source path, as
535defined in the project file."
417451fe 536 ;; FIXME: doc arguments
f020b5c9
JB
537
538 ;; This function is not itself interactive, but it is called as part
539 ;; of the prompt of interactive functions, so we require a project
540 ;; file.
541 (ada-require-project-file)
4884c50b
SM
542 (let (list
543 (dirs (ada-xref-get-src-dir-field)))
544
545 (while dirs
546 (if (file-directory-p (car dirs))
547 (set 'list (append list (file-name-all-completions string (car dirs)))))
548 (set 'dirs (cdr dirs)))
549 (cond ((equal flag 'lambda)
550 (assoc string list))
551 (flag
552 list)
553 (t
554 (try-completion string
555 (mapcar (lambda (x) (cons x 1)) list)
556 predicate)))))
557
558;;;###autoload
559(defun ada-find-file (filename)
417451fe 560 "Open FILENAME, from anywhere in the source path.
4884c50b
SM
561Completion is available."
562 (interactive
563 (list (completing-read "File: " 'ada-do-file-completion)))
564 (let ((file (ada-find-src-file-in-dir filename)))
565 (if file
566 (find-file file)
a867ead0 567 (error "%s not found in src_dir" filename))))
4884c50b 568
797aab3c 569
797aab3c
GM
570;; ----- Utilities -------------------------------------------------
571
572(defun ada-require-project-file ()
85187d83
JB
573 "If the current project does not exist, load or create a default one.
574Should only be called from interactive functions."
575 (if (not (ada-xref-current-project t))
15ea3b67 576 (ada-reread-prj-file)))
a1506d29 577
85187d83
JB
578(defun ada-xref-current-project-file (&optional no-user-question)
579 "Return the current project file name; never nil unless NO-USER-QUESTION.
580If NO-USER-QUESTION, don't prompt user for file. Call
581`ada-require-project-file' first if a project must exist."
582 (if (not (string= "" ada-prj-default-project-file))
583 ada-prj-default-project-file
584 (ada-prj-find-prj-file nil no-user-question)))
585
586(defun ada-xref-current-project (&optional no-user-question)
587 "Return the current project; nil if none.
588If NO-USER-QUESTION, don't prompt user for file. Call
589`ada-require-project-file' first if a project must exist."
590 (let* ((file-name (ada-xref-current-project-file no-user-question)))
591 (assoc file-name ada-xref-project-files)))
592
593(defun ada-show-current-project ()
594 "Display current project file name in message buffer."
595 (interactive)
596 (message (ada-xref-current-project-file)))
597
598(defun ada-show-current-main ()
599 "Display current main unit name in message buffer."
600 (interactive)
601 (message "ada-mode main_unit: %s" (ada-xref-get-project-field 'main_unit)))
602
797aab3c 603(defun ada-xref-push-pos (filename position)
eec3232e 604 "Push (FILENAME, POSITION) on the position ring for cross-references."
797aab3c
GM
605 (setq ada-xref-pos-ring (cons (list position filename) ada-xref-pos-ring))
606 (if (> (length ada-xref-pos-ring) ada-xref-pos-ring-max)
607 (setcdr (nthcdr (1- ada-xref-pos-ring-max) ada-xref-pos-ring) nil)))
608
609(defun ada-xref-goto-previous-reference ()
eec3232e 610 "Go to the previous cross-reference we were on."
797aab3c
GM
611 (interactive)
612 (if ada-xref-pos-ring
eec3232e
GM
613 (let ((pos (car ada-xref-pos-ring)))
614 (setq ada-xref-pos-ring (cdr ada-xref-pos-ring))
615 (find-file (car (cdr pos)))
616 (goto-char (car pos)))))
797aab3c
GM
617
618(defun ada-convert-file-name (name)
417451fe 619 "Convert from NAME to a name that can be used by the compilation commands.
eec3232e 620This is overriden on VMS to convert from VMS filenames to Unix filenames."
797aab3c 621 name)
417451fe 622;; FIXME: use convert-standard-filename instead
797aab3c 623
c94ca9e0
JB
624(defun ada-set-default-project-file (name &optional keep-existing)
625 "Set the file whose name is NAME as the default project file.
626If KEEP-EXISTING is true and a project file has already been loaded, nothing
ced16f5d 627is done. This is meant to be used from `ada-mode-hook', for instance, to force
c94ca9e0 628a project file unless the user has already loaded one."
eec3232e 629 (interactive "fProject file:")
c94ca9e0
JB
630 (if (or (not keep-existing)
631 (not ada-prj-default-project-file)
632 (equal ada-prj-default-project-file ""))
633 (progn
634 (setq ada-prj-default-project-file name)
635 (ada-reread-prj-file name))))
15ea3b67
GM
636
637;; ------ Handling the project file -----------------------------
797aab3c 638
c94ca9e0 639(defun ada-prj-find-prj-file (&optional file no-user-question)
85187d83
JB
640 "Find the project file associated with FILE (or the current buffer if nil).
641If the buffer is not in Ada mode, or not associated with a file,
642return `ada-prj-default-project-file'. Otherwise, search for a file with
643the same base name as the Ada file, but extension given by
644`ada-prj-file-extension' (default .adp). If not found, search for *.adp
645in the current directory; if several are found, and NO-USER-QUESTION
646is non-nil, prompt the user to select one. If none are found, return
647'default.adp'."
797aab3c 648
15ea3b67 649 (let (selected)
797aab3c 650
15ea3b67 651 (if (or (not (string= mode-name "Ada"))
c94ca9e0
JB
652 (not (buffer-file-name)))
653
85187d83
JB
654 ;; Not in an Ada buffer, or current buffer not associated
655 ;; with a file (for instance an emerge buffer)
656
c94ca9e0
JB
657 (if (and ada-prj-default-project-file
658 (not (string= ada-prj-default-project-file "")))
659 (setq selected ada-prj-default-project-file)
660 (setq selected nil))
a1506d29 661
4884c50b 662 ;; other cases: use a more complex algorithm
a1506d29 663
c94ca9e0 664 (let* ((current-file (or file (buffer-file-name)))
4884c50b
SM
665 (first-choice (concat
666 (file-name-sans-extension current-file)
0262d5e1 667 ada-prj-file-extension))
4884c50b 668 (dir (file-name-directory current-file))
a1506d29 669
4884c50b
SM
670 (prj-files (directory-files
671 dir t
672 (concat ".*" (regexp-quote
0262d5e1 673 ada-prj-file-extension) "$")))
4884c50b 674 (choice nil))
a1506d29 675
4884c50b 676 (cond
a1506d29 677
4884c50b 678 ((file-exists-p first-choice)
85187d83 679 ;; filename.adp
4884c50b 680 (set 'selected first-choice))
a1506d29 681
4884c50b 682 ((= (length prj-files) 1)
85187d83 683 ;; Exactly one project file was found in the current directory
4884c50b 684 (set 'selected (car prj-files)))
a1506d29 685
4884c50b 686 ((and (> (length prj-files) 1) (not no-user-question))
85187d83 687 ;; multiple project files in current directory, ask the user
4884c50b
SM
688 (save-window-excursion
689 (with-output-to-temp-buffer "*choice list*"
690 (princ "There are more than one possible project file.\n")
691 (princ "Which one should we use ?\n\n")
692 (princ " no. file name \n")
693 (princ " --- ------------------------\n")
694 (let ((counter 1))
695 (while (<= counter (length prj-files))
696 (princ (format " %2d) %s\n"
697 counter
698 (nth (1- counter) prj-files)))
699 (setq counter (1+ counter))
c94ca9e0 700
4884c50b
SM
701 ))) ; end of with-output-to ...
702 (setq choice nil)
703 (while (or
704 (not choice)
705 (not (integerp choice))
706 (< choice 1)
707 (> choice (length prj-files)))
027a4b6b 708 (setq choice (string-to-number
4884c50b
SM
709 (read-from-minibuffer "Enter No. of your choice: "))))
710 (set 'selected (nth (1- choice) prj-files))))
a1506d29 711
4884c50b 712 ((= (length prj-files) 0)
85187d83 713 ;; No project file in the current directory; ask user
4884c50b
SM
714 (unless (or no-user-question (not ada-always-ask-project))
715 (setq ada-last-prj-file
716 (read-file-name
717 (concat "project file [" ada-last-prj-file "]:")
718 nil ada-last-prj-file))
719 (unless (string= ada-last-prj-file "")
720 (set 'selected ada-last-prj-file))))
721 )))
c94ca9e0
JB
722
723 (or selected "default.adp")
797aab3c
GM
724 ))
725
726
15ea3b67 727(defun ada-parse-prj-file (prj-file)
417451fe
JB
728 "Read PRJ-FILE, set it as the active project."
729 ;; FIXME: doc nil, search, etc.
15ea3b67 730 (if prj-file
4884c50b
SM
731 (let (project src_dir obj_dir make_cmd comp_cmd check_cmd casing
732 run_cmd debug_pre_cmd debug_post_cmd
417451fe 733 (ada-buffer (current-buffer)))
4884c50b 734 (setq prj-file (expand-file-name prj-file))
15ea3b67 735
c94ca9e0
JB
736 ;; Set the project file as the active one.
737 (setq ada-prj-default-project-file prj-file)
738
15ea3b67
GM
739 ;; Initialize the project with the default values
740 (ada-xref-set-default-prj-values 'project (current-buffer))
741
742 ;; Do not use find-file below, since we don't want to show this
ced16f5d 743 ;; buffer. If the file is open through speedbar, we can't use
15ea3b67
GM
744 ;; find-file anyway, since the speedbar frame is special and does not
745 ;; allow the selection of a file in it.
746
c94ca9e0
JB
747 (if (file-exists-p prj-file)
748 (progn
749 (let* ((buffer (run-hook-with-args-until-success
750 'ada-load-project-hook prj-file)))
751 (unless buffer
7abe197c
JB
752 (setq buffer (find-file-noselect prj-file nil)))
753 (set-buffer buffer))
754
755 (widen)
756 (goto-char (point-min))
757
758 ;; Now overrides these values with the project file
759 (while (not (eobp))
760 (if (looking-at "^\\([^=]+\\)=\\(.*\\)")
761 (cond
417451fe
JB
762 ;; fields that are lists or paths require special processing
763 ;; FIXME: strip trailing spaces
7abe197c
JB
764 ((string= (match-string 1) "src_dir")
765 (add-to-list 'src_dir
766 (file-name-as-directory (match-string 2))))
767 ((string= (match-string 1) "obj_dir")
768 (add-to-list 'obj_dir
769 (file-name-as-directory (match-string 2))))
770 ((string= (match-string 1) "casing")
771 (set 'casing (cons (match-string 2) casing)))
772 ((string= (match-string 1) "build_dir")
773 (set 'project
774 (plist-put project 'build_dir
775 (file-name-as-directory (match-string 2)))))
776 ((string= (match-string 1) "make_cmd")
777 (add-to-list 'make_cmd (match-string 2)))
778 ((string= (match-string 1) "comp_cmd")
779 (add-to-list 'comp_cmd (match-string 2)))
780 ((string= (match-string 1) "check_cmd")
781 (add-to-list 'check_cmd (match-string 2)))
782 ((string= (match-string 1) "run_cmd")
783 (add-to-list 'run_cmd (match-string 2)))
784 ((string= (match-string 1) "debug_pre_cmd")
785 (add-to-list 'debug_pre_cmd (match-string 2)))
786 ((string= (match-string 1) "debug_post_cmd")
787 (add-to-list 'debug_post_cmd (match-string 2)))
788 (t
417451fe 789 ;; any other field in the file is just copied
7abe197c
JB
790 (set 'project (plist-put project (intern (match-string 1))
791 (match-string 2))))))
792 (forward-line 1))
793
794 (if src_dir (set 'project (plist-put project 'src_dir
795 (reverse src_dir))))
796 (if obj_dir (set 'project (plist-put project 'obj_dir
797 (reverse obj_dir))))
798 (if casing (set 'project (plist-put project 'casing
799 (reverse casing))))
800 (if make_cmd (set 'project (plist-put project 'make_cmd
801 (reverse make_cmd))))
802 (if comp_cmd (set 'project (plist-put project 'comp_cmd
803 (reverse comp_cmd))))
804 (if check_cmd (set 'project (plist-put project 'check_cmd
805 (reverse check_cmd))))
806 (if run_cmd (set 'project (plist-put project 'run_cmd
807 (reverse run_cmd))))
0262d5e1
JB
808 (if debug_post_cmd (set 'project (plist-put project 'debug_post_cmd
809 (reverse debug_post_cmd))))
810 (if debug_pre_cmd (set 'project (plist-put project 'debug_pre_cmd
811 (reverse debug_pre_cmd))))
c94ca9e0 812
c94ca9e0
JB
813 (set-buffer ada-buffer)
814 )
815
816 ;; Else the file wasn't readable (probably the default project).
817 ;; We initialize it with the current environment variables.
417451fe
JB
818 ;; We need to add the startup directory in front so that
819 ;; files locally redefined are properly found. We cannot
820 ;; add ".", which varies too much depending on what the
821 ;; current buffer is.
c94ca9e0
JB
822 (set 'project
823 (plist-put project 'src_dir
824 (append
417451fe 825 (list command-line-default-directory)
c94ca9e0
JB
826 (split-string (or (getenv "ADA_INCLUDE_PATH") "") ":")
827 (list "." default-directory))))
828 (set 'project
829 (plist-put project 'obj_dir
830 (append
417451fe 831 (list command-line-default-directory)
c94ca9e0
JB
832 (split-string (or (getenv "ADA_OBJECTS_PATH") "") ":")
833 (list "." default-directory))))
834 )
835
4884c50b
SM
836
837 ;; Delete the default project file from the list, if it is there.
838 ;; Note that in that case, this default project is the only one in
839 ;; the list
840 (if (assoc nil ada-xref-project-files)
841 (setq ada-xref-project-files nil))
a1506d29 842
15ea3b67
GM
843 ;; Memorize the newly read project file
844 (if (assoc prj-file ada-xref-project-files)
845 (setcdr (assoc prj-file ada-xref-project-files) project)
846 (add-to-list 'ada-xref-project-files (cons prj-file project)))
4884c50b 847
15ea3b67
GM
848 ;; Sets up the compilation-search-path so that Emacs is able to
849 ;; go to the source of the errors in a compilation buffer
4884c50b
SM
850 (setq compilation-search-path (ada-xref-get-src-dir-field))
851
417451fe
JB
852 ;; Set the casing exceptions file list
853 (if casing
854 (progn
855 (setq ada-case-exception-file (reverse casing))
856 (ada-case-read-exceptions)))
a1506d29 857
15ea3b67
GM
858 ;; Add the directories to the search path for ff-find-other-file
859 ;; Do not add the '/' or '\' at the end
7abe197c 860 (setq ada-search-directories-internal
15ea3b67
GM
861 (append (mapcar 'directory-file-name compilation-search-path)
862 ada-search-directories))
a1506d29 863
4884c50b 864 (ada-xref-update-project-menu)
15ea3b67 865 )
4884c50b
SM
866
867 ;; No prj file ? => Setup default values
868 ;; Note that nil means that all compilation modes will first look in the
ced16f5d 869 ;; current directory, and only then in the current file's directory. This
4884c50b
SM
870 ;; current file is assumed at this point to be in the common source
871 ;; directory.
872 (setq compilation-search-path (list nil default-directory))
15ea3b67 873 ))
a1506d29
JB
874
875
93cdce20 876(defun ada-find-references (&optional pos arg local-only)
eec3232e 877 "Find all references to the entity under POS.
93cdce20 878Calls gnatfind to find the references.
ced16f5d
RS
879If ARG is t, the contents of the old *gnatfind* buffer is preserved.
880If LOCAL-ONLY is t, only the declarations in the current file are returned."
881 (interactive "d\nP")
797aab3c
GM
882 (ada-require-project-file)
883
884 (let* ((identlist (ada-read-identifier pos))
417451fe 885 (alifile (ada-get-ali-file-name (ada-file-of identlist)))
15ea3b67 886 (process-environment (ada-set-environment)))
797aab3c
GM
887
888 (set-buffer (get-file-buffer (ada-file-of identlist)))
889
890 ;; if the file is more recent than the executable
891 (if (or (buffer-modified-p (current-buffer))
417451fe
JB
892 (file-newer-than-file-p (ada-file-of identlist) alifile))
893 (ada-find-any-references (ada-name-of identlist)
894 (ada-file-of identlist)
895 nil nil local-only arg)
797aab3c 896 (ada-find-any-references (ada-name-of identlist)
417451fe
JB
897 (ada-file-of identlist)
898 (ada-line-of identlist)
899 (ada-column-of identlist) local-only arg)))
797aab3c
GM
900 )
901
93cdce20
SM
902(defun ada-find-local-references (&optional pos arg)
903 "Find all references to the entity under POS.
ced16f5d
RS
904Calls `gnatfind' to find the references.
905If ARG is t, the contents of the old *gnatfind* buffer is preserved."
906 (interactive "d\nP")
93cdce20
SM
907 (ada-find-references pos arg t))
908
f020b5c9
JB
909(defconst ada-gnatfind-buffer-name "*gnatfind*")
910
93cdce20
SM
911(defun ada-find-any-references
912 (entity &optional file line column local-only append)
eec3232e 913 "Search for references to any entity whose name is ENTITY.
93cdce20 914ENTITY was first found the location given by FILE, LINE and COLUMN.
ced16f5d 915If LOCAL-ONLY is t, then list only the references in FILE, which
93cdce20 916is much faster.
ced16f5d
RS
917If APPEND is t, then append the output of the command to the existing
918buffer `*gnatfind*', if there is one."
797aab3c
GM
919 (interactive "sEntity name: ")
920 (ada-require-project-file)
921
ced16f5d 922 ;; Prepare the gnatfind command. Note that we must protect the quotes
4884c50b
SM
923 ;; around operators, so that they are correctly handled and can be
924 ;; processed (gnatfind \"+\":...).
925 (let* ((quote-entity
926 (if (= (aref entity 0) ?\")
927 (if is-windows
928 (concat "\\\"" (substring entity 1 -1) "\\\"")
929 (concat "'\"" (substring entity 1 -1) "\"'"))
930 entity))
931 (switches (ada-xref-get-project-field 'gnatfind_opt))
7abe197c 932 (command (concat "gnat find " switches " "
4884c50b 933 quote-entity
417451fe
JB
934 (if file (concat ":" (file-name-nondirectory file)))
935 (if line (concat ":" line))
936 (if column (concat ":" column))
93cdce20
SM
937 (if local-only (concat " " (file-name-nondirectory file)))
938 ))
939 old-contents)
797aab3c
GM
940
941 ;; If a project file is defined, use it
4884c50b
SM
942 (if (and ada-prj-default-project-file
943 (not (string= ada-prj-default-project-file "")))
417451fe
JB
944 (if (string-equal (file-name-extension ada-prj-default-project-file)
945 "gpr")
946 (setq command (concat command " -P" ada-prj-default-project-file))
947 (setq command (concat command " -p" ada-prj-default-project-file))))
797aab3c 948
f020b5c9 949 (if (and append (get-buffer ada-gnatfind-buffer-name))
93cdce20
SM
950 (save-excursion
951 (set-buffer "*gnatfind*")
952 (setq old-contents (buffer-string))))
a1506d29 953
ced16f5d 954 (let ((compilation-error "reference"))
f020b5c9 955 (compilation-start command 'compilation-mode (lambda (mode) ada-gnatfind-buffer-name)))
797aab3c
GM
956
957 ;; Hide the "Compilation" menu
958 (save-excursion
f020b5c9 959 (set-buffer ada-gnatfind-buffer-name)
93cdce20
SM
960 (local-unset-key [menu-bar compilation-menu])
961
962 (if old-contents
963 (progn
964 (goto-char 1)
f020b5c9 965 (set 'buffer-read-only nil)
93cdce20 966 (insert old-contents)
f020b5c9 967 (set 'buffer-read-only t)
93cdce20 968 (goto-char (point-max)))))
797aab3c
GM
969 )
970 )
971
4884c50b 972(defalias 'ada-change-prj (symbol-function 'ada-set-default-project-file))
797aab3c 973
797aab3c
GM
974;; ----- Identifier Completion --------------------------------------------
975(defun ada-complete-identifier (pos)
417451fe 976 "Try to complete the identifier around POS, using compiler cross-reference information."
797aab3c
GM
977 (interactive "d")
978 (ada-require-project-file)
979
15ea3b67 980 ;; Initialize function-local variables and jump to the .ali buffer
797aab3c
GM
981 ;; Note that for regexp search is case insensitive too
982 (let* ((curbuf (current-buffer))
417451fe
JB
983 (identlist (ada-read-identifier pos))
984 (sofar (concat "^[0-9]+[a-zA-Z][0-9]+[ *]\\("
985 (regexp-quote (ada-name-of identlist))
986 "[a-zA-Z0-9_]*\\)"))
987 (completed nil)
988 (symalist nil))
797aab3c 989
15ea3b67
GM
990 ;; Open the .ali file
991 (set-buffer (ada-get-ali-buffer (buffer-file-name)))
797aab3c
GM
992 (goto-char (point-max))
993
994 ;; build an alist of possible completions
995 (while (re-search-backward sofar nil t)
996 (setq symalist (cons (cons (match-string 1) nil) symalist)))
997
998 (setq completed (try-completion "" symalist))
999
1000 ;; kills .ali buffer
1001 (kill-buffer nil)
1002
1003 ;; deletes the incomplete identifier in the buffer
1004 (set-buffer curbuf)
1005 (looking-at "[a-zA-Z0-9_]+")
1006 (replace-match "")
1007 ;; inserts the completed symbol
1008 (insert completed)
1009 ))
1010
1011;; ----- Cross-referencing ----------------------------------------
1012
1013(defun ada-point-and-xref ()
c94ca9e0 1014 "Jump to the declaration of the entity below the cursor."
797aab3c
GM
1015 (interactive)
1016 (mouse-set-point last-input-event)
1017 (ada-goto-declaration (point)))
1018
c94ca9e0
JB
1019(defun ada-point-and-xref-body ()
1020 "Jump to the body of the entity under the cursor."
1021 (interactive)
1022 (mouse-set-point last-input-event)
1023 (ada-goto-body (point)))
1024
1025(defun ada-goto-body (pos &optional other-frame)
1026 "Display the body of the entity around POS.
417451fe 1027OTHER-FRAME non-nil means display in another frame.
c94ca9e0
JB
1028If the entity doesn't have a body, display its declaration.
1029As a side effect, the buffer for the declaration is also open."
1030 (interactive "d")
1031 (ada-goto-declaration pos other-frame)
1032
1033 ;; Temporarily force the display in the same buffer, since we
1034 ;; already changed previously
1035 (let ((ada-xref-other-buffer nil))
1036 (ada-goto-declaration (point) nil)))
1037
4884c50b 1038(defun ada-goto-declaration (pos &optional other-frame)
eec3232e
GM
1039 "Display the declaration of the identifier around POS.
1040The declaration is shown in another buffer if `ada-xref-other-buffer' is
4884c50b
SM
1041non-nil.
1042If OTHER-FRAME is non-nil, display the cross-reference in another frame."
797aab3c
GM
1043 (interactive "d")
1044 (ada-require-project-file)
1045 (push-mark pos)
1046 (ada-xref-push-pos (buffer-file-name) pos)
797aab3c 1047
4884c50b
SM
1048 ;; First try the standard algorithm by looking into the .ali file, but if
1049 ;; that file was too old or even did not exist, try to look in the whole
1050 ;; object path for a possible location.
1051 (let ((identlist (ada-read-identifier pos)))
0262d5e1 1052 (condition-case err
4884c50b 1053 (ada-find-in-ali identlist other-frame)
0262d5e1
JB
1054 ;; File not found: print explicit error message
1055 (error-file-not-found
1056 (message (concat (error-message-string err)
1057 (nthcdr 1 err))))
1058
93cdce20
SM
1059 (error
1060 (let ((ali-file (ada-get-ali-file-name (ada-file-of identlist))))
1061
1062 ;; If the ALI file was up-to-date, then we probably have a predefined
1063 ;; entity, whose references are not given by GNAT
1064 (if (and (file-exists-p ali-file)
1065 (file-newer-than-file-p ali-file (ada-file-of identlist)))
417451fe 1066 (message "No cross-reference found -- may be a predefined entity.")
93cdce20
SM
1067
1068 ;; Else, look in every ALI file, except if the user doesn't want that
1069 (if ada-xref-search-with-egrep
1070 (ada-find-in-src-path identlist other-frame)
ced16f5d 1071 (message "Cross-referencing information is not up-to-date; please recompile.")
93cdce20 1072 )))))))
4884c50b 1073
96a483d9 1074(defun ada-goto-declaration-other-frame (pos)
eec3232e
GM
1075 "Display the declaration of the identifier around POS.
1076The declation is shown in another frame if `ada-xref-other-buffer' is non-nil."
797aab3c 1077 (interactive "d")
4884c50b 1078 (ada-goto-declaration pos t))
797aab3c 1079
15ea3b67
GM
1080(defun ada-remote (command)
1081 "Return the remote version of COMMAND, or COMMAND if remote_machine is nil."
1082 (let ((machine (ada-xref-get-project-field 'remote_machine)))
1083 (if (or (not machine) (string= machine ""))
1084 command
1085 (format "%s %s '(%s)'"
1086 remote-shell-program
1087 machine
1088 command))))
1089
15ea3b67 1090(defun ada-get-absolute-dir-list (dir-list root-dir)
417451fe
JB
1091 "Return the list of absolute directories found in DIR-LIST.
1092If a directory is a relative directory, ROOT-DIR is prepended."
4884c50b 1093 (mapcar (lambda (x) (expand-file-name x root-dir)) dir-list))
15ea3b67
GM
1094
1095(defun ada-set-environment ()
ced16f5d
RS
1096 "Prepare an environment for Ada compilation.
1097This returns a new value to use for `process-environment',
1098but does not actually put it into use.
15ea3b67
GM
1099It modifies the source path and object path with the values found in the
1100project file."
1101 (let ((include (getenv "ADA_INCLUDE_PATH"))
1102 (objects (getenv "ADA_OBJECTS_PATH"))
1103 (build-dir (ada-xref-get-project-field 'build_dir)))
1104 (if include
4884c50b 1105 (set 'include (concat path-separator include)))
15ea3b67 1106 (if objects
4884c50b 1107 (set 'objects (concat path-separator objects)))
15ea3b67
GM
1108 (cons
1109 (concat "ADA_INCLUDE_PATH="
4884c50b 1110 (mapconcat (lambda(x) (expand-file-name x build-dir))
15ea3b67 1111 (ada-xref-get-project-field 'src_dir)
4884c50b
SM
1112 path-separator)
1113 include)
15ea3b67
GM
1114 (cons
1115 (concat "ADA_OBJECTS_PATH="
4884c50b 1116 (mapconcat (lambda(x) (expand-file-name x build-dir))
15ea3b67 1117 (ada-xref-get-project-field 'obj_dir)
4884c50b
SM
1118 path-separator)
1119 objects)
15ea3b67
GM
1120 process-environment))))
1121
1122(defun ada-compile-application (&optional arg)
ced16f5d 1123 "Compile the application, using the command found in the project file.
15ea3b67
GM
1124If ARG is not nil, ask for user confirmation."
1125 (interactive "P")
797aab3c 1126 (ada-require-project-file)
15ea3b67
GM
1127 (let ((cmd (ada-xref-get-project-field 'make_cmd))
1128 (process-environment (ada-set-environment))
1129 (compilation-scroll-output t))
1130
4884c50b 1131 (setq compilation-search-path (ada-xref-get-src-dir-field))
15ea3b67
GM
1132
1133 ;; If no project file was found, ask the user
1134 (unless cmd
4884c50b 1135 (setq cmd '("") arg t))
15ea3b67 1136
4884c50b
SM
1137 ;; Make a single command from the list of commands, including the
1138 ;; commands to run it on a remote machine.
1139 (setq cmd (ada-remote (mapconcat 'identity cmd ada-command-separator)))
a1506d29 1140
4884c50b
SM
1141 (if (or ada-xref-confirm-compile arg)
1142 (setq cmd (read-from-minibuffer "enter command to compile: " cmd)))
1143
1144 ;; Insert newlines so as to separate the name of the commands to run
ced16f5d 1145 ;; and the output of the commands. This doesn't work with cmdproxy.exe,
4884c50b 1146 ;; which gets confused by newline characters.
c94ca9e0 1147 (if (not (string-match ".exe" shell-file-name))
4884c50b 1148 (setq cmd (concat cmd "\n\n")))
a1506d29 1149
4884c50b 1150 (compile (ada-quote-cmd cmd))))
797aab3c 1151
85187d83
JB
1152(defun ada-set-main-compile-application ()
1153 "Set main_unit and main project variables to current buffer, build main."
1154 (interactive)
1155 (ada-require-project-file)
1156 (let* ((file (buffer-file-name (current-buffer)))
1157 main)
1158 (if (not file)
1159 (error "No file for current buffer")
1160
1161 (setq main
1162 (if file
1163 (file-name-nondirectory
1164 (file-name-sans-extension file))
1165 ""))
1166 (ada-xref-set-project-field 'main main)
1167 (ada-xref-set-project-field 'main_unit main)
1168 (ada-compile-application))))
1169
15ea3b67
GM
1170(defun ada-compile-current (&optional arg prj-field)
1171 "Recompile the current file.
1172If ARG is not nil, ask for user confirmation of the command.
1173PRJ-FIELD is the name of the field to use in the project file to get the
7977c946 1174command, and should be either `comp_cmd' (default) or `check_cmd'."
15ea3b67 1175 (interactive "P")
797aab3c 1176 (ada-require-project-file)
15ea3b67
GM
1177 (let* ((field (if prj-field prj-field 'comp_cmd))
1178 (cmd (ada-xref-get-project-field field))
1179 (process-environment (ada-set-environment))
1180 (compilation-scroll-output t))
a1506d29 1181
4884c50b 1182 (setq compilation-search-path (ada-xref-get-src-dir-field))
15ea3b67 1183
4884c50b
SM
1184 (unless cmd
1185 (setq cmd '("") arg t))
a1506d29 1186
4884c50b
SM
1187 ;; Make a single command from the list of commands, including the
1188 ;; commands to run it on a remote machine.
1189 (setq cmd (ada-remote (mapconcat 'identity cmd ada-command-separator)))
a1506d29 1190
15ea3b67 1191 ;; If no project file was found, ask the user
4884c50b
SM
1192 (if (or ada-xref-confirm-compile arg)
1193 (setq cmd (read-from-minibuffer "enter command to compile: " cmd)))
1194
4884c50b 1195 (compile (ada-quote-cmd cmd))))
15ea3b67
GM
1196
1197(defun ada-check-current (&optional arg)
ab074cb1 1198 "Check the current file for syntax errors.
15ea3b67
GM
1199If ARG is not nil, ask for user confirmation of the command."
1200 (interactive "P")
1201 (ada-compile-current arg 'check_cmd))
797aab3c 1202
15ea3b67
GM
1203(defun ada-run-application (&optional arg)
1204 "Run the application.
ced16f5d 1205if ARG is not-nil, ask for user confirmation."
797aab3c
GM
1206 (interactive)
1207 (ada-require-project-file)
1208
15ea3b67
GM
1209 (let ((machine (ada-xref-get-project-field 'cross_prefix)))
1210 (if (and machine (not (string= machine "")))
1211 (error "This feature is not supported yet for cross environments")))
797aab3c 1212
15ea3b67 1213 (let ((command (ada-xref-get-project-field 'run_cmd)))
797aab3c 1214
15ea3b67 1215 ;; Guess the command if it wasn't specified
4884c50b 1216 (if (not command)
417451fe 1217 (set 'command (list (file-name-sans-extension (buffer-name)))))
797aab3c 1218
4884c50b
SM
1219 ;; Modify the command to run remotely
1220 (setq command (ada-remote (mapconcat 'identity command
1221 ada-command-separator)))
a1506d29 1222
15ea3b67
GM
1223 ;; Ask for the arguments to the command if required
1224 (if (or ada-xref-confirm-compile arg)
4884c50b
SM
1225 (setq command (read-from-minibuffer "Enter command to execute: "
1226 command)))
797aab3c
GM
1227
1228 ;; Run the command
1229 (save-excursion
1230 (set-buffer (get-buffer-create "*run*"))
15ea3b67 1231 (set 'buffer-read-only nil)
4884c50b 1232
15ea3b67 1233 (erase-buffer)
4884c50b
SM
1234 (start-process "run" (current-buffer) shell-file-name
1235 "-c" command)
1236 (comint-mode)
1237 ;; Set these two variables to their default values, since otherwise
1238 ;; the output buffer is scrolled so that only the last output line
1239 ;; is visible at the top of the buffer.
1240 (set (make-local-variable 'scroll-step) 0)
1241 (set (make-local-variable 'scroll-conservatively) 0)
797aab3c
GM
1242 )
1243 (display-buffer "*run*")
1244
1245 ;; change to buffer *run* for interactive programs
1246 (other-window 1)
1247 (switch-to-buffer "*run*")
15ea3b67 1248 ))
797aab3c 1249
4884c50b 1250(defun ada-gdb-application (&optional arg executable-name)
15ea3b67 1251 "Start the debugger on the application.
417451fe 1252If ARG is non-nil, ask the user to confirm the command.
4884c50b 1253EXECUTABLE-NAME, if non-nil, is debugged instead of the file specified in the
417451fe 1254project file."
15ea3b67 1255 (interactive "P")
85187d83 1256 (ada-require-project-file)
797aab3c 1257 (let ((buffer (current-buffer))
4884c50b 1258 cmd pre-cmd post-cmd)
4884c50b
SM
1259 (setq cmd (if executable-name
1260 (concat ada-prj-default-debugger " " executable-name)
1261 (ada-xref-get-project-field 'debug_cmd))
1262 pre-cmd (ada-xref-get-project-field 'debug_pre_cmd)
1263 post-cmd (ada-xref-get-project-field 'debug_post_cmd))
15ea3b67
GM
1264
1265 ;; If the command was not given in the project file, start a bare gdb
1266 (if (not cmd)
1267 (set 'cmd (concat ada-prj-default-debugger
1268 " "
4884c50b
SM
1269 (or executable-name
1270 (file-name-sans-extension (buffer-file-name))))))
1271
1272 ;; For gvd, add an extra switch so that the Emacs window is completly
1273 ;; swallowed inside the Gvd one
1274 (if (and ada-tight-gvd-integration
1275 (string-match "^[^ \t]*gvd" cmd))
1276 ;; Start a new frame, so that when gvd exists we do not kill Emacs
1277 ;; We make sure that gvd swallows the new frame, not the one the
1278 ;; user has been using until now
1279 ;; The frame is made invisible initially, so that GtkPlug gets a
ced16f5d 1280 ;; chance to fully manage it. Then it works fine with Enlightenment
4884c50b
SM
1281 ;; as well
1282 (let ((frame (make-frame '((visibility . nil)))))
1283 (set 'cmd (concat
1284 cmd " --editor-window="
1285 (cdr (assoc 'outer-window-id (frame-parameters frame)))))
1286 (select-frame frame)))
1287
1288 ;; Add a -fullname switch
1289 ;; Use the remote machine
1290 (set 'cmd (ada-remote (concat cmd " -fullname ")))
1291
1292 ;; Ask for confirmation if required
15ea3b67
GM
1293 (if (or arg ada-xref-confirm-compile)
1294 (set 'cmd (read-from-minibuffer "enter command to debug: " cmd)))
1295
96a483d9 1296 (let ((old-comint-exec (symbol-function 'comint-exec)))
4884c50b
SM
1297
1298 ;; Do not add -fullname, since we can have a 'rsh' command in front.
96a483d9 1299 ;; FIXME: This is evil but luckily a nop under Emacs-21.3.50 ! -stef
4884c50b
SM
1300 (fset 'gud-gdb-massage-args (lambda (file args) args))
1301
1302 (set 'pre-cmd (mapconcat 'identity pre-cmd ada-command-separator))
1303 (if (not (equal pre-cmd ""))
1304 (setq pre-cmd (concat pre-cmd ada-command-separator)))
1305
1306 (set 'post-cmd (mapconcat 'identity post-cmd "\n"))
1307 (if post-cmd
96a483d9 1308 (set 'post-cmd (concat post-cmd "\n")))
4884c50b 1309
c94ca9e0 1310
4884c50b
SM
1311 ;; Temporarily replaces the definition of `comint-exec' so that we
1312 ;; can execute commands before running gdb.
96a483d9 1313 ;; FIXME: This is evil and not temporary !!! -stef
a1506d29 1314 (fset 'comint-exec
4884c50b
SM
1315 `(lambda (buffer name command startfile switches)
1316 (let (compilation-buffer-name-function)
1317 (save-excursion
1318 (set 'compilation-buffer-name-function
1319 (lambda(x) (buffer-name buffer)))
1320 (compile (ada-quote-cmd
1321 (concat ,pre-cmd
1322 command " "
1323 (mapconcat 'identity switches " "))))))
1324 ))
1325
1326 ;; Tight integration should force the tty mode
1327 (if (and (string-match "gvd" (comint-arguments cmd 0 0))
1328 ada-tight-gvd-integration
1329 (not (string-match "--tty" cmd)))
1330 (setq cmd (concat cmd "--tty")))
a1506d29 1331
4884c50b
SM
1332 (if (and (string-match "jdb" (comint-arguments cmd 0 0))
1333 (boundp 'jdb))
1334 (funcall (symbol-function 'jdb) cmd)
1335 (gdb cmd))
1336
c94ca9e0
JB
1337 ;; Restore the standard fset command (or for instance C-U M-x shell
1338 ;; wouldn't work anymore
1339
1340 (fset 'comint-exec old-comint-exec)
1341
4884c50b
SM
1342 ;; Send post-commands to the debugger
1343 (process-send-string (get-buffer-process (current-buffer)) post-cmd)
1344
1345 ;; Move to the end of the debugger buffer, so that it is automatically
1346 ;; scrolled from then on.
254746ff 1347 (goto-char (point-max))
4884c50b
SM
1348
1349 ;; Display both the source window and the debugger window (the former
ced16f5d 1350 ;; above the latter). No need to show the debugger window unless it
4884c50b
SM
1351 ;; is going to have some relevant information.
1352 (if (or (not (string-match "gvd" (comint-arguments cmd 0 0)))
1353 (string-match "--tty" cmd))
1354 (split-window-vertically))
1355 (switch-to-buffer buffer)
1356 )))
797aab3c 1357
15ea3b67 1358(defun ada-reread-prj-file (&optional filename)
417451fe 1359 "Reread either the current project, or FILENAME if non-nil."
797aab3c 1360 (interactive "P")
15ea3b67
GM
1361 (if filename
1362 (ada-parse-prj-file filename)
797aab3c 1363 (ada-parse-prj-file (ada-prj-find-prj-file)))
797aab3c 1364
4884c50b
SM
1365 ;; Reread the location of the standard runtime library
1366 (ada-initialize-runtime-library
c94ca9e0 1367 (or (ada-xref-get-project-field 'cross_prefix) ""))
4884c50b 1368 )
15ea3b67 1369
797aab3c
GM
1370;; ------ Private routines
1371
1372(defun ada-xref-current (file &optional ali-file-name)
eec3232e 1373 "Update the cross-references for FILE.
4884c50b
SM
1374This in fact recompiles FILE to create ALI-FILE-NAME.
1375This function returns the name of the file that was recompiled to generate
7977c946
JB
1376the cross-reference information. Note that the ali file can then be deduced
1377by replacing the file extension with `.ali'."
797aab3c
GM
1378 ;; kill old buffer
1379 (if (and ali-file-name
417451fe 1380 (get-file-buffer ali-file-name))
797aab3c 1381 (kill-buffer (get-file-buffer ali-file-name)))
a1506d29 1382
4884c50b
SM
1383 (let* ((name (ada-convert-file-name file))
1384 (body-name (or (ada-get-body-name name) name)))
15ea3b67 1385
ced16f5d 1386 ;; Always recompile the body when we can. We thus temporarily switch to a
4884c50b
SM
1387 ;; buffer than contains the body of the unit
1388 (save-excursion
1389 (let ((body-visible (find-buffer-visiting body-name))
1390 process)
1391 (if body-visible
1392 (set-buffer body-visible)
1393 (find-file body-name))
1394
ced16f5d 1395 ;; Execute the compilation. Note that we must wait for the end of the
4884c50b
SM
1396 ;; process, or the ALI file would still not be available.
1397 ;; Unfortunately, the underlying `compile' command that we use is
1398 ;; asynchronous.
1399 (ada-compile-current)
1400 (setq process (get-buffer-process "*compilation*"))
1401
1402 (while (and process
1403 (not (equal (process-status process) 'exit)))
1404 (sit-for 1))
1405
1406 ;; remove the buffer for the body if it wasn't there before
1407 (unless body-visible
1408 (kill-buffer (find-buffer-visiting body-name)))
1409 ))
1410 body-name))
15ea3b67
GM
1411
1412(defun ada-find-file-in-dir (file dir-list)
1413 "Search for FILE in DIR-LIST."
1414 (let (found)
1415 (while (and (not found) dir-list)
1416 (set 'found (concat (file-name-as-directory (car dir-list))
1417 (file-name-nondirectory file)))
a1506d29 1418
15ea3b67
GM
1419 (unless (file-exists-p found)
1420 (set 'found nil))
1421 (set 'dir-list (cdr dir-list)))
1422 found))
797aab3c
GM
1423
1424(defun ada-find-ali-file-in-dir (file)
417451fe 1425 "Find the ali file FILE, searching obj_dir for the current project.
15ea3b67
GM
1426Adds build_dir in front of the search path to conform to gnatmake's behavior,
1427and the standard runtime location at the end."
4884c50b 1428 (ada-find-file-in-dir file (ada-xref-get-obj-dir-field)))
15ea3b67
GM
1429
1430(defun ada-find-src-file-in-dir (file)
417451fe
JB
1431 "Find the source file FILE, searching src_dir for the current project.
1432Adds the standard runtime location at the end of the search path to conform
1433to gnatmake's behavior."
4884c50b 1434 (ada-find-file-in-dir file (ada-xref-get-src-dir-field)))
797aab3c
GM
1435
1436(defun ada-get-ali-file-name (file)
eec3232e
GM
1437 "Create the ali file name for the ada-file FILE.
1438The file is searched for in every directory shown in the obj_dir lines of
1439the project file."
797aab3c
GM
1440
1441 ;; This function has to handle the special case of non-standard
1442 ;; file names (i.e. not .adb or .ads)
1443 ;; The trick is the following:
1444 ;; 1- replace the extension of the current file with .ali,
1445 ;; and look for this file
1446 ;; 2- If this file is found:
1447 ;; grep the "^U" lines, and make sure we are not reading the
ced16f5d 1448 ;; .ali file for a spec file. If we are, go to step 3.
797aab3c
GM
1449 ;; 3- If the file is not found or step 2 failed:
1450 ;; find the name of the "other file", ie the body, and look
1451 ;; for its associated .ali file by subtituing the extension
4884c50b
SM
1452 ;;
1453 ;; We must also handle the case of separate packages and subprograms:
1454 ;; 4- If no ali file was found, we try to modify the file name by removing
1455 ;; everything after the last '-' or '.' character, so as to get the
ced16f5d 1456 ;; ali file for the parent unit. If we found an ali file, we check that
4884c50b 1457 ;; it indeed contains the definition for the separate entity by checking
ced16f5d 1458 ;; the 'D' lines. This is done repeatedly, in case the direct parent is
4884c50b 1459 ;; also a separate.
797aab3c
GM
1460
1461 (save-excursion
1462 (set-buffer (get-file-buffer file))
1463 (let ((short-ali-file-name
417451fe
JB
1464 (concat (file-name-sans-extension (file-name-nondirectory file))
1465 ".ali"))
1466 ali-file-name
4884c50b
SM
1467 is-spec)
1468
1469 ;; If we have a non-standard file name, and this is a spec, we first
1470 ;; look for the .ali file of the body, since this is the one that
ced16f5d 1471 ;; contains the most complete information. If not found, we will do what
4884c50b
SM
1472 ;; we can with the .ali file for the spec...
1473
1474 (if (not (string= (file-name-extension file) "ads"))
1475 (let ((specs ada-spec-suffixes))
1476 (while specs
1477 (if (string-match (concat (regexp-quote (car specs)) "$")
1478 file)
1479 (set 'is-spec t))
1480 (set 'specs (cdr specs)))))
1481
1482 (if is-spec
1483 (set 'ali-file-name
1484 (ada-find-ali-file-in-dir
1485 (concat (file-name-sans-extension
1486 (file-name-nondirectory
1487 (ada-other-file-name)))
1488 ".ali"))))
a1506d29 1489
4884c50b
SM
1490
1491 (setq ali-file-name
1492 (or ali-file-name
a1506d29 1493
4884c50b
SM
1494 ;; Else we take the .ali file associated with the unit
1495 (ada-find-ali-file-in-dir short-ali-file-name)
a1506d29 1496
4884c50b
SM
1497
1498 ;; else we did not find the .ali file Second chance: in case
1499 ;; the files do not have standard names (such as for instance
1500 ;; file_s.ada and file_b.ada), try to go to the other file
1501 ;; and look for its ali file
1502 (ada-find-ali-file-in-dir
1503 (concat (file-name-sans-extension
1504 (file-name-nondirectory (ada-other-file-name)))
1505 ".ali"))
1506
a1506d29 1507
4884c50b
SM
1508 ;; If we still don't have an ali file, try to get the one
1509 ;; from the parent unit, in case we have a separate entity.
1510 (let ((parent-name (file-name-sans-extension
1511 (file-name-nondirectory file))))
a1506d29 1512
4884c50b
SM
1513 (while (and (not ali-file-name)
1514 (string-match "^\\(.*\\)[.-][^.-]*" parent-name))
a1506d29 1515
4884c50b
SM
1516 (set 'parent-name (match-string 1 parent-name))
1517 (set 'ali-file-name (ada-find-ali-file-in-dir
1518 (concat parent-name ".ali")))
1519 )
1520 ali-file-name)))
a1506d29 1521
4884c50b
SM
1522 ;; If still not found, try to recompile the file
1523 (if (not ali-file-name)
ced16f5d
RS
1524 ;; Recompile only if the user asked for this, and search the ali
1525 ;; filename again. We avoid a possible infinite recursion by
4884c50b 1526 ;; temporarily disabling the automatic compilation.
a1506d29 1527
4884c50b
SM
1528 (if ada-xref-create-ali
1529 (setq ali-file-name
1530 (concat (file-name-sans-extension (ada-xref-current file))
1531 ".ali"))
797aab3c 1532
ced16f5d 1533 (error "`.ali' file not found; recompile your source file"))
a1506d29
JB
1534
1535
4884c50b
SM
1536 ;; same if the .ali file is too old and we must recompile it
1537 (if (and (file-newer-than-file-p file ali-file-name)
1538 ada-xref-create-ali)
1539 (ada-xref-current file ali-file-name)))
797aab3c 1540
4884c50b 1541 ;; Always return the correct absolute file name
797aab3c 1542 (expand-file-name ali-file-name))
4884c50b 1543 ))
797aab3c
GM
1544
1545(defun ada-get-ada-file-name (file original-file)
eec3232e 1546 "Create the complete file name (+directory) for FILE.
7977c946
JB
1547The original file (where the user was) is ORIGINAL-FILE.
1548Search in project file for possible paths."
797aab3c
GM
1549
1550 (save-excursion
15ea3b67
GM
1551
1552 ;; If the buffer for original-file, use it to get the values from the
1553 ;; project file, otherwise load the file and its project file
1554 (let ((buffer (get-file-buffer original-file)))
1555 (if buffer
1556 (set-buffer buffer)
85187d83 1557 (find-file original-file)))
a1506d29 1558
797aab3c
GM
1559 ;; we choose the first possible completion and we
1560 ;; return the absolute file name
15ea3b67 1561 (let ((filename (ada-find-src-file-in-dir file)))
797aab3c 1562 (if filename
417451fe 1563 (expand-file-name filename)
0262d5e1 1564 (signal 'error-file-not-found (file-name-nondirectory file)))
797aab3c
GM
1565 )))
1566
1567(defun ada-find-file-number-in-ali (file)
417451fe 1568 "Return the file number for FILE in the associated ali file."
797aab3c
GM
1569 (set-buffer (ada-get-ali-buffer file))
1570 (goto-char (point-min))
1571
1572 (let ((begin (re-search-forward "^D")))
1573 (beginning-of-line)
1574 (re-search-forward (concat "^D " (file-name-nondirectory file)))
1575 (count-lines begin (point))))
1576
1577(defun ada-read-identifier (pos)
417451fe 1578 "Return the identlist around POS and switch to the .ali buffer.
4884c50b
SM
1579The returned list represents the entity, and can be manipulated through the
1580macros `ada-name-of', `ada-line-of', `ada-column-of', `ada-file-of',..."
797aab3c
GM
1581
1582 ;; If at end of buffer (e.g the buffer is empty), error
1583 (if (>= (point) (point-max))
1584 (error "No identifier on point"))
a1506d29 1585
797aab3c
GM
1586 ;; goto first character of the identifier/operator (skip backward < and >
1587 ;; since they are part of multiple character operators
1588 (goto-char pos)
1589 (skip-chars-backward "a-zA-Z0-9_<>")
1590
1591 ;; check if it really is an identifier
1592 (if (ada-in-comment-p)
1593 (error "Inside comment"))
1594
1595 (let (identifier identlist)
1596 ;; Just in front of a string => we could have an operator declaration,
1597 ;; as in "+", "-", ..
1598 (if (= (char-after) ?\")
417451fe 1599 (forward-char 1))
797aab3c
GM
1600
1601 ;; if looking at an operator
15ea3b67
GM
1602 ;; This is only true if:
1603 ;; - the symbol is +, -, ...
1604 ;; - the symbol is made of letters, and not followed by _ or a letter
1605 (if (and (looking-at ada-operator-re)
1606 (or (not (= (char-syntax (char-after)) ?w))
1607 (not (or (= (char-syntax (char-after (match-end 0))) ?w)
1608 (= (char-after (match-end 0)) ?_)))))
417451fe
JB
1609 (progn
1610 (if (and (= (char-before) ?\")
1611 (= (char-after (+ (length (match-string 0)) (point))) ?\"))
1612 (forward-char -1))
1613 (set 'identifier (regexp-quote (concat "\"" (match-string 0) "\""))))
797aab3c
GM
1614
1615 (if (ada-in-string-p)
417451fe 1616 (error "Inside string or character constant"))
797aab3c 1617 (if (looking-at (concat ada-keywords "[^a-zA-Z_]"))
417451fe 1618 (error "No cross-reference available for reserved keyword"))
797aab3c 1619 (if (looking-at "[a-zA-Z0-9_]+")
417451fe
JB
1620 (set 'identifier (match-string 0))
1621 (error "No identifier around")))
a1506d29 1622
797aab3c
GM
1623 ;; Build the identlist
1624 (set 'identlist (ada-make-identlist))
1625 (ada-set-name identlist (downcase identifier))
1626 (ada-set-line identlist
93cdce20 1627 (number-to-string (count-lines 1 (point))))
797aab3c
GM
1628 (ada-set-column identlist
1629 (number-to-string (1+ (current-column))))
1630 (ada-set-file identlist (buffer-file-name))
1631 identlist
1632 ))
1633
1634(defun ada-get-all-references (identlist)
417451fe
JB
1635 "Complete IDENTLIST with definition file and places where it is referenced.
1636Information is extracted from the ali file."
a1506d29 1637
797aab3c
GM
1638 (let ((ali-buffer (ada-get-ali-buffer (ada-file-of identlist)))
1639 declaration-found)
1640 (set-buffer ali-buffer)
1641 (goto-char (point-min))
1642 (ada-set-on-declaration identlist nil)
1643
1644 ;; First attempt: we might already be on the declaration of the identifier
1645 ;; We want to look for the declaration only in a definite interval (after
1646 ;; the "^X ..." line for the current file, and before the next "^X" line
a1506d29 1647
797aab3c
GM
1648 (if (re-search-forward
1649 (concat "^X [0-9]+ " (file-name-nondirectory (ada-file-of identlist)))
1650 nil t)
417451fe
JB
1651 (let ((bound (save-excursion (re-search-forward "^X " nil t))))
1652 (set 'declaration-found
797aab3c
GM
1653 (re-search-forward
1654 (concat "^" (ada-line-of identlist)
1655 "." (ada-column-of identlist)
15ea3b67 1656 "[ *]" (ada-name-of identlist)
0262d5e1 1657 "[{\[\(<= ]?\\(.*\\)$") bound t))
797aab3c
GM
1658 (if declaration-found
1659 (ada-set-on-declaration identlist t))
1660 ))
1661
1662 ;; If declaration is still nil, then we were not on a declaration, and
1663 ;; have to fall back on other algorithms
1664
1665 (unless declaration-found
a1506d29 1666
797aab3c
GM
1667 ;; Since we alread know the number of the file, search for a direct
1668 ;; reference to it
1669 (goto-char (point-min))
1670 (set 'declaration-found t)
1671 (ada-set-ali-index
1672 identlist
1673 (number-to-string (ada-find-file-number-in-ali
1674 (ada-file-of identlist))))
1675 (unless (re-search-forward (concat (ada-ali-index-of identlist)
93cdce20 1676 "|\\([0-9]+[^0-9][0-9]+\\(\n\\.\\)? \\)*"
797aab3c 1677 (ada-line-of identlist)
c94ca9e0 1678 "[^etpzkd<>=^]"
93cdce20 1679 (ada-column-of identlist) "\\>")
797aab3c
GM
1680 nil t)
1681
417451fe
JB
1682 ;; if we did not find it, it may be because the first reference
1683 ;; is not required to have a 'unit_number|' item included.
1684 ;; Or maybe we are already on the declaration...
1685 (unless (re-search-forward
4884c50b 1686 (concat
93cdce20
SM
1687 "^[0-9]+.[0-9]+[ *]"
1688 (ada-name-of identlist)
0262d5e1 1689 "[ <{=\(\[]\\(.\\|\n\\.\\)*\\<"
4884c50b
SM
1690 (ada-line-of identlist)
1691 "[^0-9]"
93cdce20 1692 (ada-column-of identlist) "\\>")
4884c50b 1693 nil t)
a1506d29 1694
797aab3c
GM
1695 ;; If still not found, then either the declaration is unknown
1696 ;; or the source file has been modified since the ali file was
1697 ;; created
1698 (set 'declaration-found nil)
417451fe 1699 )
797aab3c
GM
1700 )
1701
1702 ;; Last check to be completly sure we have found the correct line (the
1703 ;; ali might not be up to date for instance)
1704 (if declaration-found
1705 (progn
1706 (beginning-of-line)
1707 ;; while we have a continuation line, go up one line
1708 (while (looking-at "^\\.")
7caf6803 1709 (forward-line -1)
0262d5e1 1710 (beginning-of-line))
797aab3c 1711 (unless (looking-at (concat "[0-9]+.[0-9]+[ *]"
0262d5e1 1712 (ada-name-of identlist) "[ <{=\(\[]"))
797aab3c
GM
1713 (set 'declaration-found nil))))
1714
1715 ;; Still no success ! The ali file must be too old, and we need to
ced16f5d 1716 ;; use a basic algorithm based on guesses. Note that this only happens
797aab3c
GM
1717 ;; if the user does not want us to automatically recompile files
1718 ;; automatically
1719 (unless declaration-found
15ea3b67
GM
1720 (if (ada-xref-find-in-modified-ali identlist)
1721 (set 'declaration-found t)
ced16f5d 1722 ;; No more idea to find the declaration. Give up
797aab3c
GM
1723 (progn
1724 (kill-buffer ali-buffer)
a867ead0
DG
1725
1726 (error "No declaration of %s found." (ada-name-of identlist))
797aab3c
GM
1727 )))
1728 )
1729
a1506d29 1730
797aab3c
GM
1731 ;; Now that we have found a suitable line in the .ali file, get the
1732 ;; information available
1733 (beginning-of-line)
1734 (if declaration-found
417451fe 1735 (let ((current-line (buffer-substring
797aab3c 1736 (point) (save-excursion (end-of-line) (point)))))
417451fe 1737 (save-excursion
7caf6803 1738 (forward-line 1)
417451fe
JB
1739 (beginning-of-line)
1740 (while (looking-at "^\\.\\(.*\\)")
1741 (set 'current-line (concat current-line (match-string 1)))
7caf6803 1742 (forward-line 1))
417451fe 1743 )
797aab3c
GM
1744
1745 (if (re-search-backward "^X [0-9]+ \\([a-zA-Z0-9_.-]+\\)" nil t)
4884c50b
SM
1746
1747 ;; If we can find the file
1748 (condition-case err
1749 (ada-set-declare-file
1750 identlist
1751 (ada-get-ada-file-name (match-string 1)
1752 (ada-file-of identlist)))
a1506d29 1753
4884c50b 1754 ;; Else clean up the ali file
0262d5e1
JB
1755 (error-file-not-found
1756 (signal (car err) (cdr err)))
4884c50b
SM
1757 (error
1758 (kill-buffer ali-buffer)
1759 (error (error-message-string err)))
1760 ))
a1506d29 1761
797aab3c
GM
1762 (ada-set-references identlist current-line)
1763 ))
1764 ))
1765
1766(defun ada-xref-find-in-modified-ali (identlist)
1767 "Find the matching position for IDENTLIST in the current ali buffer.
1768This function is only called when the file was not up-to-date, so we need
1769to make some guesses.
eec3232e 1770This function is disabled for operators, and only works for identifiers."
797aab3c
GM
1771
1772 (unless (= (string-to-char (ada-name-of identlist)) ?\")
1773 (progn
417451fe 1774 (let ((declist '()) ;;; ( (line_in_ali_file line_in_ada) ( ... ))
797aab3c
GM
1775 (my-regexp (concat "[ *]"
1776 (regexp-quote (ada-name-of identlist)) " "))
1777 (line-ada "--")
1778 (col-ada "--")
1779 (line-ali 0)
1780 (len 0)
15ea3b67
GM
1781 (choice 0)
1782 (ali-buffer (current-buffer)))
797aab3c 1783
417451fe
JB
1784 (goto-char (point-max))
1785 (while (re-search-backward my-regexp nil t)
1786 (save-excursion
1787 (set 'line-ali (count-lines 1 (point)))
1788 (beginning-of-line)
1789 ;; have a look at the line and column numbers
1790 (if (looking-at "^\\([0-9]+\\).\\([0-9]+\\)[ *]")
1791 (progn
1792 (setq line-ada (match-string 1))
1793 (setq col-ada (match-string 2)))
1794 (setq line-ada "--")
1795 (setq col-ada "--")
1796 )
1797 ;; construct a list with the file names and the positions within
1798 (if (re-search-backward "^X [0-9]+ \\([a-zA-Z0-9._-]+\\)" nil t)
797aab3c
GM
1799 (add-to-list
1800 'declist (list line-ali (match-string 1) line-ada col-ada))
417451fe
JB
1801 )
1802 )
1803 )
1804
1805 ;; how many possible declarations have we found ?
1806 (setq len (length declist))
1807 (cond
1808 ;; none => error
1809 ((= len 0)
1810 (kill-buffer (current-buffer))
a867ead0
DG
1811 (error "No declaration of %s recorded in .ali file"
1812 (ada-name-of identlist)))
417451fe
JB
1813 ;; one => should be the right one
1814 ((= len 1)
1815 (goto-line (caar declist)))
1816
1817 ;; more than one => display choice list
1818 (t
4884c50b
SM
1819 (save-window-excursion
1820 (with-output-to-temp-buffer "*choice list*"
a1506d29 1821
4884c50b
SM
1822 (princ "Identifier is overloaded and Xref information is not up to date.\n")
1823 (princ "Possible declarations are:\n\n")
1824 (princ " no. in file at line col\n")
1825 (princ " --- --------------------- ---- ----\n")
1826 (let ((counter 0))
1827 (while (< counter len)
1828 (princ (format " %2d) %-21s %4s %4s\n"
417451fe 1829 (1+ counter)
797aab3c 1830 (ada-get-ada-file-name
4884c50b 1831 (nth 1 (nth counter declist))
797aab3c 1832 (ada-file-of identlist))
417451fe
JB
1833 (nth 2 (nth counter declist))
1834 (nth 3 (nth counter declist))
1835 ))
4884c50b
SM
1836 (setq counter (1+ counter))
1837 ) ; end of while
1838 ) ; end of let
1839 ) ; end of with-output-to ...
1840 (setq choice nil)
1841 (while (or
1842 (not choice)
1843 (not (integerp choice))
1844 (< choice 1)
1845 (> choice len))
1846 (setq choice
027a4b6b 1847 (string-to-number
4884c50b
SM
1848 (read-from-minibuffer "Enter No. of your choice: "))))
1849 )
15ea3b67 1850 (set-buffer ali-buffer)
417451fe
JB
1851 (goto-line (car (nth (1- choice) declist)))
1852 ))))))
797aab3c
GM
1853
1854
1855(defun ada-find-in-ali (identlist &optional other-frame)
eec3232e 1856 "Look in the .ali file for the definition of the identifier in IDENTLIST.
09aba29c 1857If OTHER-FRAME is non-nil, and `ada-xref-other-buffer' is non-nil,
eec3232e 1858opens a new window to show the declaration."
797aab3c
GM
1859
1860 (ada-get-all-references identlist)
1861 (let ((ali-line (ada-references-of identlist))
4884c50b
SM
1862 (locations nil)
1863 (start 0)
797aab3c 1864 file line col)
4884c50b
SM
1865
1866 ;; Note: in some cases, an entity can have multiple references to the
1867 ;; bodies (this is for instance the case for a separate subprogram, that
1868 ;; has a reference both to the stub and to the real body).
1869 ;; In that case, we simply go to each one in turn.
1870
1871 ;; Get all the possible locations
0262d5e1 1872 (string-match "^\\([0-9]+\\)[a-zA-Z+*]\\([0-9]+\\)[ *]" ali-line)
4884c50b
SM
1873 (set 'locations (list (list (match-string 1 ali-line) ;; line
1874 (match-string 2 ali-line) ;; column
1875 (ada-declare-file-of identlist))))
c94ca9e0
JB
1876 (while (string-match "\\([0-9]+\\)[bc]\\(<[^>]+>\\)?\\([0-9]+\\)"
1877 ali-line start)
4884c50b 1878 (setq line (match-string 1 ali-line)
c94ca9e0
JB
1879 col (match-string 3 ali-line)
1880 start (match-end 3))
4884c50b
SM
1881
1882 ;; it there was a file number in the same line
0262d5e1
JB
1883 ;; Make sure we correctly handle the case where the first file reference
1884 ;; on the line is the type reference.
1885 ;; 1U2 T(2|2r3) 34r23
1886 (if (string-match (concat "[^{(<0-9]\\([0-9]+\\)|\\([^|bc]+\\)?"
4884c50b
SM
1887 (match-string 0 ali-line))
1888 ali-line)
1889 (let ((file-number (match-string 1 ali-line)))
1890 (goto-char (point-min))
1891 (re-search-forward "^D \\([a-zA-Z0-9_.-]+\\)" nil t
1892 (string-to-number file-number))
1893 (set 'file (match-string 1))
1894 )
1895 ;; Else get the nearest file
1896 (set 'file (ada-declare-file-of identlist)))
a1506d29 1897
4884c50b
SM
1898 (set 'locations (append locations (list (list line col file)))))
1899
1900 ;; Add the specs at the end again, so that from the last body we go to
1901 ;; the specs
1902 (set 'locations (append locations (list (car locations))))
1903
1904 ;; Find the new location we want to go to.
1905 ;; If we are on none of the locations listed, we simply go to the specs.
1906
1907 (setq line (caar locations)
1908 col (nth 1 (car locations))
1909 file (nth 2 (car locations)))
a1506d29 1910
4884c50b
SM
1911 (while locations
1912 (if (and (string= (caar locations) (ada-line-of identlist))
1913 (string= (nth 1 (car locations)) (ada-column-of identlist))
1914 (string= (file-name-nondirectory (nth 2 (car locations)))
1915 (file-name-nondirectory (ada-file-of identlist))))
1916 (setq locations (cadr locations)
1917 line (car locations)
1918 col (nth 1 locations)
1919 file (nth 2 locations)
1920 locations nil)
1921 (set 'locations (cdr locations))))
1922
1923 ;; Find the file in the source path
1924 (set 'file (ada-get-ada-file-name file (ada-file-of identlist)))
1925
1926 ;; Kill the .ali buffer
1927 (kill-buffer (current-buffer))
797aab3c
GM
1928
1929 ;; Now go to the buffer
4884c50b
SM
1930 (ada-xref-change-buffer file
1931 (string-to-number line)
1932 (1- (string-to-number col))
1933 identlist
1934 other-frame)
797aab3c
GM
1935 ))
1936
4884c50b
SM
1937(defun ada-find-in-src-path (identlist &optional other-frame)
1938 "More general function for cross-references.
1939This function should be used when the standard algorithm that parses the
1940.ali file has failed, either because that file was too old or even did not
1941exist.
1942This function attempts to find the possible declarations for the identifier
1943anywhere in the object path.
1944This command requires the external `egrep' program to be available.
1945
f020b5c9 1946This works well when one is using an external library and wants to find
7977c946 1947the declaration and documentation of the subprograms one is using."
417451fe 1948;; FIXME: what does this function do?
4884c50b
SM
1949 (let (list
1950 (dirs (ada-xref-get-obj-dir-field))
1951 (regexp (concat "[ *]" (ada-name-of identlist)))
1952 line column
1953 choice
1954 file)
a1506d29 1955
4884c50b 1956 (save-excursion
a1506d29 1957
ced16f5d 1958 ;; Do the grep in all the directories. We do multiple shell
4884c50b
SM
1959 ;; commands instead of one in case there is no .ali file in one
1960 ;; of the directory and the shell stops because of that.
a1506d29 1961
4884c50b
SM
1962 (set-buffer (get-buffer-create "*grep*"))
1963 (while dirs
1964 (insert (shell-command-to-string
81fe5f4b
KS
1965 (concat
1966 "grep -E -i -h "
1967 (shell-quote-argument (concat "^X|" regexp "( |$)"))
1968 " "
1969 (shell-quote-argument (file-name-as-directory (car dirs)))
1970 "*.ali")))
4884c50b 1971 (set 'dirs (cdr dirs)))
a1506d29 1972
4884c50b
SM
1973 ;; Now parse the output
1974 (set 'case-fold-search t)
1975 (goto-char (point-min))
1976 (while (re-search-forward regexp nil t)
1977 (save-excursion
1978 (beginning-of-line)
1979 (if (not (= (char-after) ?X))
1980 (progn
1981 (looking-at "\\([0-9]+\\).\\([0-9]+\\)")
1982 (setq line (match-string 1)
1983 column (match-string 2))
1984 (re-search-backward "^X [0-9]+ \\(.*\\)$")
1985 (set 'file (list (match-string 1) line column))
a1506d29 1986
4884c50b
SM
1987 ;; There could be duplicate choices, because of the structure
1988 ;; of the .ali files
1989 (unless (member file list)
1990 (set 'list (append list (list file))))))))
a1506d29 1991
4884c50b
SM
1992 ;; Current buffer is still "*grep*"
1993 (kill-buffer "*grep*")
1994 )
a1506d29 1995
4884c50b
SM
1996 ;; Now display the list of possible matches
1997 (cond
a1506d29 1998
4884c50b
SM
1999 ;; No choice found => Error
2000 ((null list)
2001 (error "No cross-reference found, please recompile your file"))
a1506d29 2002
4884c50b
SM
2003 ;; Only one choice => Do the cross-reference
2004 ((= (length list) 1)
2005 (set 'file (ada-find-src-file-in-dir (caar list)))
2006 (if file
2007 (ada-xref-change-buffer file
2008 (string-to-number (nth 1 (car list)))
2009 (string-to-number (nth 2 (car list)))
2010 identlist
2011 other-frame)
a867ead0 2012 (error "%s not found in src_dir" (caar list)))
4884c50b
SM
2013 (message "This is only a (good) guess at the cross-reference.")
2014 )
a1506d29 2015
4884c50b
SM
2016 ;; Else, ask the user
2017 (t
2018 (save-window-excursion
2019 (with-output-to-temp-buffer "*choice list*"
a1506d29 2020
4884c50b
SM
2021 (princ "Identifier is overloaded and Xref information is not up to date.\n")
2022 (princ "Possible declarations are:\n\n")
2023 (princ " no. in file at line col\n")
2024 (princ " --- --------------------- ---- ----\n")
2025 (let ((counter 0))
2026 (while (< counter (length list))
2027 (princ (format " %2d) %-21s %4s %4s\n"
2028 (1+ counter)
2029 (nth 0 (nth counter list))
2030 (nth 1 (nth counter list))
2031 (nth 2 (nth counter list))
2032 ))
2033 (setq counter (1+ counter))
2034 )))
2035 (setq choice nil)
2036 (while (or (not choice)
2037 (not (integerp choice))
2038 (< choice 1)
2039 (> choice (length list)))
2040 (setq choice
027a4b6b 2041 (string-to-number
4884c50b
SM
2042 (read-from-minibuffer "Enter No. of your choice: "))))
2043 )
2044 (set 'choice (1- choice))
2045 (kill-buffer "*choice list*")
2046
2047 (set 'file (ada-find-src-file-in-dir (car (nth choice list))))
2048 (if file
2049 (ada-xref-change-buffer file
2050 (string-to-number (nth 1 (nth choice list)))
2051 (string-to-number (nth 2 (nth choice list)))
2052 identlist
2053 other-frame)
0262d5e1 2054 (signal 'error-file-not-found (car (nth choice list))))
4884c50b
SM
2055 (message "This is only a (good) guess at the cross-reference.")
2056 ))))
2057
797aab3c
GM
2058(defun ada-xref-change-buffer
2059 (file line column identlist &optional other-frame)
4884c50b 2060 "Select and display FILE, at LINE and COLUMN.
797aab3c 2061If we do not end on the same identifier as IDENTLIST, find the closest
ced16f5d 2062match. Kills the .ali buffer at the end.
eec3232e 2063If OTHER-FRAME is non-nil, creates a new frame to show the file."
797aab3c 2064
4884c50b 2065 (let (declaration-buffer)
797aab3c
GM
2066
2067 ;; Select and display the destination buffer
2068 (if ada-xref-other-buffer
417451fe
JB
2069 (if other-frame
2070 (find-file-other-frame file)
2071 (set 'declaration-buffer (find-file-noselect file))
2072 (set-buffer declaration-buffer)
2073 (switch-to-buffer-other-window declaration-buffer)
2074 )
797aab3c
GM
2075 (find-file file)
2076 )
2077
797aab3c
GM
2078 ;; move the cursor to the correct position
2079 (push-mark)
2080 (goto-line line)
2081 (move-to-column column)
2082
2083 ;; If we are not on the identifier, the ali file was not up-to-date.
2084 ;; Try to find the nearest position where the identifier is found,
2085 ;; this is probably the right one.
2086 (unless (looking-at (ada-name-of identlist))
2087 (ada-xref-search-nearest (ada-name-of identlist)))
4884c50b 2088 ))
797aab3c
GM
2089
2090
2091(defun ada-xref-search-nearest (name)
417451fe
JB
2092 "Search for NAME nearest to the position recorded in the Xref file.
2093Return the position of the declaration in the buffer, or nil if not found."
797aab3c 2094 (let ((orgpos (point))
417451fe
JB
2095 (newpos nil)
2096 (diff nil))
797aab3c
GM
2097
2098 (goto-char (point-max))
2099
2100 ;; loop - look for all declarations of name in this file
2101 (while (search-backward name nil t)
2102
2103 ;; check if it really is a complete Ada identifier
2104 (if (and
417451fe
JB
2105 (not (save-excursion
2106 (goto-char (match-end 0))
2107 (looking-at "_")))
2108 (not (ada-in-string-or-comment-p))
2109 (or
2110 ;; variable declaration ?
2111 (save-excursion
2112 (skip-chars-forward "a-zA-Z_0-9" )
2113 (ada-goto-next-non-ws)
2114 (looking-at ":[^=]"))
2115 ;; procedure, function, task or package declaration ?
2116 (save-excursion
2117 (ada-goto-previous-word)
2118 (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]\\>"))))
2119
2120 ;; check if it is nearer than the ones before if any
2121 (if (or (not diff)
2122 (< (abs (- (point) orgpos)) diff))
2123 (progn
2124 (setq newpos (point)
797aab3c
GM
2125 diff (abs (- newpos orgpos))))))
2126 )
2127
2128 (if newpos
417451fe
JB
2129 (progn
2130 (message "ATTENTION: this declaration is only a (good) guess ...")
2131 (goto-char newpos))
797aab3c
GM
2132 nil)))
2133
2134
2135;; Find the parent library file of the current file
2136(defun ada-goto-parent ()
eec3232e 2137 "Go to the parent library file."
797aab3c
GM
2138 (interactive)
2139 (ada-require-project-file)
2140
2141 (let ((buffer (ada-get-ali-buffer (buffer-file-name)))
417451fe
JB
2142 (unit-name nil)
2143 (body-name nil)
2144 (ali-name nil))
797aab3c
GM
2145 (save-excursion
2146 (set-buffer buffer)
2147 (goto-char (point-min))
2148 (re-search-forward "^U \\([^ \t%]+\\)%[bs][ \t]+\\([^ \t]+\\)")
2149 (setq unit-name (match-string 1))
2150 (if (not (string-match "\\(.*\\)\\.[^.]+" unit-name))
417451fe
JB
2151 (progn
2152 (kill-buffer buffer)
2153 (error "No parent unit !"))
2154 (setq unit-name (match-string 1 unit-name))
2155 )
797aab3c
GM
2156
2157 ;; look for the file name for the parent unit specification
2158 (goto-char (point-min))
2159 (re-search-forward (concat "^W " unit-name
417451fe
JB
2160 "%s[ \t]+\\([^ \t]+\\)[ \t]+"
2161 "\\([^ \t\n]+\\)"))
797aab3c
GM
2162 (setq body-name (match-string 1))
2163 (setq ali-name (match-string 2))
2164 (kill-buffer buffer)
2165 )
2166
2167 (setq ali-name (ada-find-ali-file-in-dir ali-name))
2168
2169 (save-excursion
2170 ;; Tries to open the new ali file to find the spec file
2171 (if ali-name
417451fe
JB
2172 (progn
2173 (find-file ali-name)
2174 (goto-char (point-min))
2175 (re-search-forward (concat "^U " unit-name "%s[ \t]+"
2176 "\\([^ \t]+\\)"))
2177 (setq body-name (match-string 1))
2178 (kill-buffer (current-buffer))
2179 )
2180 )
797aab3c
GM
2181 )
2182
2183 (find-file body-name)
2184 ))
2185
2186(defun ada-make-filename-from-adaname (adaname)
eec3232e
GM
2187 "Determine the filename in which ADANAME is found.
2188This is a GNAT specific function that uses gnatkrunch."
797aab3c
GM
2189 (let (krunch-buf)
2190 (setq krunch-buf (generate-new-buffer "*gkrunch*"))
2191 (save-excursion
2192 (set-buffer krunch-buf)
2193 ;; send adaname to external process `gnatkr'.
0262d5e1
JB
2194 ;; Add a dummy extension, since gnatkr versions have two different
2195 ;; behaviors depending on the version:
2196 ;; Up to 3.15: "AA.BB.CC" => aa-bb-cc
2197 ;; After: "AA.BB.CC" => aa-bb.cc
797aab3c 2198 (call-process "gnatkr" nil krunch-buf nil
0262d5e1 2199 (concat adaname ".adb") ada-krunch-args)
797aab3c
GM
2200 ;; fetch output of that process
2201 (setq adaname (buffer-substring
417451fe
JB
2202 (point-min)
2203 (progn
2204 (goto-char (point-min))
2205 (end-of-line)
2206 (point))))
0262d5e1
JB
2207 ;; Remove the extra extension we added above
2208 (setq adaname (substring adaname 0 -4))
2209
797aab3c
GM
2210 (kill-buffer krunch-buf)))
2211 adaname
2212 )
2213
2dccd96f 2214(defun ada-make-body-gnatstub (&optional interactive)
797aab3c
GM
2215 "Create an Ada package body in the current buffer.
2216This function uses the `gnatstub' program to create the body.
ab074cb1 2217If INTERACTIVE is nil, kill the current buffer.
ce883133 2218This function typically is to be hooked into `ff-file-created-hook'."
2dccd96f 2219 (interactive "p")
85187d83 2220 (ada-require-project-file)
797aab3c
GM
2221
2222 (save-some-buffers nil nil)
2223
4884c50b 2224 ;; If the current buffer is the body (as is the case when calling this
ce883133 2225 ;; function from ff-file-created-hook), then kill this temporary buffer
2dccd96f 2226 (unless interactive
ab074cb1
JB
2227 (set-buffer-modified-p nil)
2228 (kill-buffer (current-buffer)))
a1506d29 2229
797aab3c 2230
4884c50b
SM
2231 ;; Make sure the current buffer is the spec (this might not be the case
2232 ;; if for instance the user was asked for a project file)
2233
2234 (unless (buffer-file-name (car (buffer-list)))
2235 (set-buffer (cadr (buffer-list))))
2236
797aab3c
GM
2237 ;; Call the external process gnatstub
2238 (let* ((gnatstub-opts (ada-treat-cmd-string ada-gnatstub-opts))
417451fe
JB
2239 (filename (buffer-file-name (car (buffer-list))))
2240 (output (concat (file-name-sans-extension filename) ".adb"))
2241 (gnatstub-cmd (concat "gnatstub " gnatstub-opts " " filename))
2242 (buffer (get-buffer-create "*gnatstub*")))
797aab3c
GM
2243
2244 (save-excursion
2245 (set-buffer buffer)
2246 (compilation-minor-mode 1)
2247 (erase-buffer)
2248 (insert gnatstub-cmd)
2249 (newline)
2250 )
2251 ;; call gnatstub to create the body file
2252 (call-process shell-file-name nil buffer nil "-c" gnatstub-cmd)
2253
2254 (if (save-excursion
417451fe
JB
2255 (set-buffer buffer)
2256 (goto-char (point-min))
2257 (search-forward "command not found" nil t))
2258 (progn
2259 (message "gnatstub was not found -- using the basic algorithm")
2260 (sleep-for 2)
2261 (kill-buffer buffer)
2262 (ada-make-body))
797aab3c
GM
2263
2264 ;; Else clean up the output
2265
797aab3c 2266 (if (file-exists-p output)
417451fe
JB
2267 (progn
2268 (find-file output)
2269 (kill-buffer buffer))
797aab3c 2270
417451fe
JB
2271 ;; display the error buffer
2272 (display-buffer buffer)
2273 )
797aab3c
GM
2274 )))
2275
797aab3c 2276(defun ada-xref-initialize ()
fea24571
SM
2277 "Function called by `ada-mode-hook' to initialize the ada-xref.el package.
2278For instance, it creates the gnat-specific menus, sets some hooks for
7977c946 2279`find-file'."
ce883133
JB
2280 (remove-hook 'ff-file-created-hook 'ada-make-body) ; from global hook
2281 (remove-hook 'ff-file-created-hook 'ada-make-body t) ; from local hook
2282 (add-hook 'ff-file-created-hook 'ada-make-body-gnatstub nil t)
797aab3c 2283
797aab3c
GM
2284 ;; Completion for file names in the mini buffer should ignore .ali files
2285 (add-to-list 'completion-ignored-extensions ".ali")
c94ca9e0
JB
2286
2287 (ada-xref-update-project-menu)
797aab3c
GM
2288 )
2289
797aab3c
GM
2290;; ----- Add to ada-mode-hook ---------------------------------------------
2291
4884c50b 2292;; This must be done before initializing the Ada menu.
797aab3c
GM
2293(add-hook 'ada-mode-hook 'ada-xref-initialize)
2294
0262d5e1
JB
2295;; Define a new error type
2296(put 'error-file-not-found
2297 'error-conditions
2298 '(error ada-mode-errors error-file-not-found))
2299(put 'error-file-not-found
2300 'error-message
2301 "File not found in src-dir (check project file): ")
2302
15ea3b67 2303;; Initializes the cross references to the runtime library
4884c50b 2304(ada-initialize-runtime-library "")
15ea3b67
GM
2305
2306;; Add these standard directories to the search path
7abe197c 2307(set 'ada-search-directories-internal
15ea3b67
GM
2308 (append (mapcar 'directory-file-name ada-xref-runtime-library-specs-path)
2309 ada-search-directories))
2310
797aab3c
GM
2311(provide 'ada-xref)
2312
ab5796a9 2313;;; arch-tag: 415a39fe-577b-4676-b3b1-6ff6db7ca24e
383d5bbb 2314;;; ada-xref.el ends here