aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorStefan Monnier2002-04-09 18:54:20 +0000
committerStefan Monnier2002-04-09 18:54:20 +0000
commit4884c50b604797005e04c3317e79286314c3fa2e (patch)
tree0e37646ad3fa85378eb64256a64b0bce9a9ef5bc
parent4607c7f43312969969a0050daffd0e5ae2ff3aff (diff)
downloademacs-4884c50b604797005e04c3317e79286314c3fa2e.tar.gz
emacs-4884c50b604797005e04c3317e79286314c3fa2e.zip
ada-mode no longer supports a different
project file per buffer. This was too complex. Instead, there is now a single active project file at any given time, and the user can switch the active one through the Ada menu. This revision also provides better handling of the Windows command line, and the various available shells on that platform. ada-mode is now fully integrated with the GNU visual debugger gvd, see http://libre.act-europe.fr. (ada-prj-default-comp-opt): Use the new GNAT switch -gnatQ. This is only available with GNAT 3.14. (ada-prj-gnatfind-switches, ada-cd-command): New variable. (ada-quote-cmd): New function. (ada-initialize-runtime-library): Get the location of the actual runtime the compiler will be using, including support for cross-platform environments. (ada-treat-cmd-string): Add support for the new variable ${full_current} add support for debug-pre-cmd and debug-post-cmd, two commands to run just prior to running the debugger, and just after starting it. This provide better support for cross-platform and remote debugging. (ada-get-absolute-dir): Remove, replace with expand-file-name. (ada-gdb-application): New parameter executable-name. (ada-get-ali-file-name): Better handling of separate packages. Checkin on behalf of the ada-mode maintainer.
-rw-r--r--lisp/progmodes/ada-xref.el1550
1 files changed, 958 insertions, 592 deletions
diff --git a/lisp/progmodes/ada-xref.el b/lisp/progmodes/ada-xref.el
index 6c3807a9886..5cf2c2e75b9 100644
--- a/lisp/progmodes/ada-xref.el
+++ b/lisp/progmodes/ada-xref.el
@@ -1,12 +1,13 @@
1;;; ada-xref.el --- for lookup and completion in Ada mode 1;;; ada-xref.el --- for lookup and completion in Ada mode
2 2
3;; Copyright (C) 1994, 95, 96, 97, 98, 99, 2000 Free Software Foundation, Inc. 3;; Copyright (C) 1994, 95, 96, 97, 98, 99, 2000, 2001
4;; Free Software Foundation, Inc.
4 5
5;; Author: Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de> 6;; Author: Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de>
6;; Rolf Ebert <ebert@inf.enst.fr> 7;; Rolf Ebert <ebert@inf.enst.fr>
7;; Emmanuel Briot <briot@gnat.com> 8;; Emmanuel Briot <briot@gnat.com>
8;; Maintainer: Emmanuel Briot <briot@gnat.com> 9;; Maintainer: Emmanuel Briot <briot@gnat.com>
9;; Ada Core Technologies's version: $Revision: 1.7 $ 10;; Ada Core Technologies's version: $Revision: 1.150 $
10;; Keywords: languages ada xref 11;; Keywords: languages ada xref
11 12
12;; This file is part of GNU Emacs. 13;; This file is part of GNU Emacs.
@@ -31,27 +32,6 @@
31;;; cross reference capabilities of the GNAT Ada compiler 32;;; cross reference capabilities of the GNAT Ada compiler
32;;; for lookup and completion in Ada mode. 33;;; for lookup and completion in Ada mode.
33;;; 34;;;
34;;; The functions provided are the following ones :
35;;; - `ada-complete-identifier': completes the current identifier as much as
36;;; possible, depending of the known identifier in the unit
37;;; - `ada-point-and-xref': moves the mouse pointer and shows the declaration
38;;; of the selected identifier (either in the same buffer or in another
39;;; buffer
40;;; - `ada-goto-declaration': shows the declaration of the selected
41;;; identifier (the one under the cursor), either in the same buffer or in
42;;; another buffer
43;;; - `ada-goto-declaration-other-frame': same as previous, but opens a new
44;; frame to show the declaration
45;;; - `ada-compile-application': recompile your whole application, provided
46;;; that a project file exists in your directory
47;;; - `ada-run-application': run your application directly from Emacs
48;;; - `ada-reread-prj-file': force Emacs to read your project file again.
49;;; Otherwise, this file is only read the first time Emacs needs some
50;;; informations, which are then kept in memory
51;;; - `ada-change-prj': change the prj file associated with a buffer
52;;; - `ada-change-default-prj': change the default project file used for
53;;; every new buffer
54;;;
55;;; If a file *.`adp' exists in the ada-file directory, then it is 35;;; If a file *.`adp' exists in the ada-file directory, then it is
56;;; read for configuration informations. It is read only the first 36;;; read for configuration informations. It is read only the first
57;;; time a cross-reference is asked for, and is not read later. 37;;; time a cross-reference is asked for, and is not read later.
@@ -86,7 +66,7 @@ the application."
86Set to 0, if you don't use crunched filenames. This should be a string." 66Set to 0, if you don't use crunched filenames. This should be a string."
87 :type 'string :group 'ada) 67 :type 'string :group 'ada)
88 68
89(defcustom ada-prj-default-comp-opt "-gnatq" 69(defcustom ada-prj-default-comp-opt "-gnatq -gnatQ"
90 "Default compilation options." 70 "Default compilation options."
91 :type 'string :group 'ada) 71 :type 'string :group 'ada)
92 72
@@ -102,8 +82,16 @@ Set to 0, if you don't use crunched filenames. This should be a string."
102 "Default options for gnatmake." 82 "Default options for gnatmake."
103 :type 'string :group 'ada) 83 :type 'string :group 'ada)
104 84
85(defcustom ada-prj-gnatfind-switches "-rf"
86 "Default switches to use for gnatfind.
87You should modify this variable, for instance to add -a, if you are working
88in an environment where most ALI files are write-protected.
89The command gnatfind is used every time you choose the menu
90\"Show all references\"."
91 :type 'string :group 'ada)
92
105(defcustom ada-prj-default-comp-cmd 93(defcustom ada-prj-default-comp-cmd
106 "${cross_prefix}gcc -c ${comp_opt}" 94 "${cross_prefix}gcc -x ada -c ${comp_opt} ${full_current}"
107 "*Default command to be used to compile a single file. 95 "*Default command to be used to compile a single file.
108Emacs will add the filename at the end of this command. This is the same 96Emacs will add the filename at the end of this command. This is the same
109syntax as in the project file." 97syntax as in the project file."
@@ -137,6 +125,13 @@ This has the same syntax as in the project file (with variable substitution)."
137Otherwise, ask the user for the name of the project file to use." 125Otherwise, ask the user for the name of the project file to use."
138 :type 'boolean :group 'ada) 126 :type 'boolean :group 'ada)
139 127
128(defconst is-windows (memq system-type (quote (windows-nt)))
129 "True if we are running on windows NT or windows 95.")
130
131(defcustom ada-tight-gvd-integration nil
132 "*If non-nil, a new Emacs frame will be swallowed in GVD when debugging.
133If GVD is not the debugger used, nothing happens.")
134
140;; ------- Nothing to be modified by the user below this 135;; ------- Nothing to be modified by the user below this
141(defvar ada-last-prj-file "" 136(defvar ada-last-prj-file ""
142 "Name of the last project file entered by the user.") 137 "Name of the last project file entered by the user.")
@@ -144,12 +139,9 @@ Otherwise, ask the user for the name of the project file to use."
144(defvar ada-check-switch "-gnats" 139(defvar ada-check-switch "-gnats"
145 "Switch added to the command line to check the current file.") 140 "Switch added to the command line to check the current file.")
146 141
147(defvar ada-project-file-extension ".adp" 142(defconst ada-project-file-extension ".adp"
148 "The extension used for project files.") 143 "The extension used for project files.")
149 144
150(defconst is-windows (memq system-type (quote (windows-nt)))
151 "True if we are running on windows NT or windows 95.")
152
153(defvar ada-xref-runtime-library-specs-path '() 145(defvar ada-xref-runtime-library-specs-path '()
154 "Directories where the specs for the standard library is found. 146 "Directories where the specs for the standard library is found.
155This is used for cross-references.") 147This is used for cross-references.")
@@ -162,6 +154,20 @@ This is used for cross-references.")
162 "List of positions selected by the cross-references functions. 154 "List of positions selected by the cross-references functions.
163Used to go back to these positions.") 155Used to go back to these positions.")
164 156
157(defvar ada-cd-command
158 (if (string-match "cmdproxy.exe" shell-file-name)
159 "cd /d"
160 "cd")
161 "Command to use to change to a specific directory. On windows systems
162using cmdproxy.exe as the shell, we need to use /d or the drive is never
163changed.")
164
165(defvar ada-command-separator (if is-windows " && " "\n")
166 "Separator to use when sending multiple commands to `compile' or
167`start-process'.
168cmdproxy.exe doesn't recognize multiple-line commands, so we have to use
169\"&&\" for now.")
170
165(defconst ada-xref-pos-ring-max 16 171(defconst ada-xref-pos-ring-max 16
166 "Number of positions kept in the list ada-xref-pos-ring.") 172 "Number of positions kept in the list ada-xref-pos-ring.")
167 173
@@ -169,35 +175,22 @@ Used to go back to these positions.")
169 "\\+\\|-\\|/\\|\\*\\*\\|\\*\\|=\\|&\\|abs\\|mod\\|rem\\|and\\|not\\|or\\|xor\\|<=\\|<\\|>=\\|>" 175 "\\+\\|-\\|/\\|\\*\\*\\|\\*\\|=\\|&\\|abs\\|mod\\|rem\\|and\\|not\\|or\\|xor\\|<=\\|<\\|>=\\|>"
170 "Regexp to match for operators.") 176 "Regexp to match for operators.")
171 177
172(defvar ada-xref-default-prj-file nil
173 "Name of the default prj file, per directory.
174Every directory is potentially associated with a default project file.
175If it is nil, then the first prj file loaded will be the default for this
176Emacs session.")
177
178
179(defvar ada-xref-project-files '() 178(defvar ada-xref-project-files '()
180 "Associative list of project files. 179 "Associative list of project files.
181It has the following format: 180It has the following format:
182\((project_name . value) (project_name . value) ...) 181\((project_name . value) (project_name . value) ...)
183As always, the values of the project file are defined through properties.") 182As always, the values of the project file are defined through properties.")
184 183
185(defvar ada-prj-prj-file nil 184(defun ada-quote-cmd (cmd)
186 "Buffer local variable that specifies the name of the project file. 185 "Duplicates all \\ characters in CMD so that it can be passed to `compile'"
187Getting the project is done by looking up the key in ada-pxref-project-file.") 186 (mapconcat 'identity (split-string cmd "\\\\") "\\\\"))
188
189(defun my-local-variable-if-set-p (variable &optional buffer)
190 "Returns t if VARIABLE is local in BUFFER and is non-nil."
191 (and (local-variable-p variable buffer)
192 (save-excursion
193 (set-buffer buffer)
194 (symbol-value variable))))
195 187
196(defun ada-initialize-runtime-library () 188(defun ada-initialize-runtime-library (cross-prefix)
197 "Initializes the variables for the runtime library location." 189 "Initializes the variables for the runtime library location.
190CROSS-PREFIX is the prefix to use for the gnatls command"
198 (save-excursion 191 (save-excursion
199 (set 'ada-xref-runtime-library-specs-path '()) 192 (setq ada-xref-runtime-library-specs-path '()
200 (set 'ada-xref-runtime-library-ali-path '()) 193 ada-xref-runtime-library-ali-path '())
201 (set-buffer (get-buffer-create "*gnatls*")) 194 (set-buffer (get-buffer-create "*gnatls*"))
202 (widen) 195 (widen)
203 (erase-buffer) 196 (erase-buffer)
@@ -206,7 +199,8 @@ Getting the project is done by looking up the key in ada-pxref-project-file.")
206 ;; Even if we get an error, delete the *gnatls* buffer 199 ;; Even if we get an error, delete the *gnatls* buffer
207 (unwind-protect 200 (unwind-protect
208 (progn 201 (progn
209 (call-process "gnatls" nil t nil "-v") 202 (call-process (concat cross-prefix "gnatls")
203 nil t nil "-v")
210 (goto-char (point-min)) 204 (goto-char (point-min))
211 205
212 ;; Source path 206 ;; Source path
@@ -248,23 +242,34 @@ Getting the project is done by looking up the key in ada-pxref-project-file.")
248 "Replace meta-sequences like ${...} in CMD-STRING with the appropriate value. 242 "Replace meta-sequences like ${...} in CMD-STRING with the appropriate value.
249The project file must have been loaded first. 243The project file must have been loaded first.
250As a special case, ${current} is replaced with the name of the currently 244As a special case, ${current} is replaced with the name of the currently
251edited file, minus extension but with directory." 245edited file, minus extension but with directory, and ${full_current} is
246replaced by the name including the extension."
252 247
253 (while (string-match "\\(-[^-\$IO]*[IO]\\)?\${\\([^}]+\\)}" cmd-string) 248 (while (string-match "\\(-[^-\$IO]*[IO]\\)?\${\\([^}]+\\)}" cmd-string)
254 (let (value) 249 (let (value
255 (if (string= (match-string 2 cmd-string) "current") 250 (name (match-string 2 cmd-string)))
256 (set 'value (file-name-sans-extension (buffer-file-name))) 251 (cond
252 ((string= name "current")
253 (setq value (file-name-sans-extension (buffer-file-name))))
254 ((string= name "full_current")
255 (setq value (buffer-file-name)))
256 (t
257 (save-match-data 257 (save-match-data
258 (set 'value (ada-xref-get-project-field 258 (setq value (ada-xref-get-project-field (intern name))))))
259 (intern (match-string 2 cmd-string)))))) 259
260 ;; Check if there is an environment variable with the same name
261 (if (null value)
262 (if (not (setq value (getenv name)))
263 (message (concat "No environment variable " name " found"))))
264
260 (cond 265 (cond
261 ((null value) 266 ((null value)
262 (set 'cmd-string (replace-match "" t t cmd-string))) 267 (setq cmd-string (replace-match "" t t cmd-string)))
263 ((stringp value) 268 ((stringp value)
264 (set 'cmd-string (replace-match value t t cmd-string))) 269 (setq cmd-string (replace-match value t t cmd-string)))
265 ((listp value) 270 ((listp value)
266 (let ((prefix (match-string 1 cmd-string))) 271 (let ((prefix (match-string 1 cmd-string)))
267 (set 'cmd-string (replace-match 272 (setq cmd-string (replace-match
268 (mapconcat (lambda(x) (concat prefix x)) value " ") 273 (mapconcat (lambda(x) (concat prefix x)) value " ")
269 t t cmd-string))))) 274 t t cmd-string)))))
270 )) 275 ))
@@ -282,17 +287,17 @@ edited file, minus extension but with directory."
282 ;; Try hard to find a default value for filename, so that the user 287 ;; Try hard to find a default value for filename, so that the user
283 ;; can edit his project file even if the current buffer is not an 288 ;; can edit his project file even if the current buffer is not an
284 ;; Ada file or not even associated with a file 289 ;; Ada file or not even associated with a file
285 (list 'filename (cond 290 (list 'filename (expand-file-name
286 (file 291 (cond
287 (ada-prj-get-prj-dir file)) 292 (file
288 (ada-prj-prj-file 293 (ada-prj-get-prj-dir file))
289 ada-prj-prj-file) 294 (ada-prj-default-project-file
290 (ada-xref-default-prj-file 295 ada-prj-default-project-file)
291 ada-xref-default-prj-file) 296 (t
292 (t 297 (message (concat "Not editing an Ada file,"
293 (error (concat "Not editing an Ada file," 298 "and no default project "
294 "and no default project " 299 "file specified!"))
295 "file specified!")))) 300 "")))
296 'build_dir (file-name-as-directory (expand-file-name ".")) 301 'build_dir (file-name-as-directory (expand-file-name "."))
297 'src_dir (list ".") 302 'src_dir (list ".")
298 'obj_dir (list ".") 303 'obj_dir (list ".")
@@ -303,8 +308,10 @@ edited file, minus extension but with directory."
303 'bind_opt ada-prj-default-bind-opt 308 'bind_opt ada-prj-default-bind-opt
304 'link_opt ada-prj-default-link-opt 309 'link_opt ada-prj-default-link-opt
305 'gnatmake_opt ada-prj-default-gnatmake-opt 310 'gnatmake_opt ada-prj-default-gnatmake-opt
311 'gnatfind_opt ada-prj-gnatfind-switches
306 'main (if file 312 'main (if file
307 (file-name-sans-extension file) 313 (file-name-nondirectory
314 (file-name-sans-extension file))
308 "") 315 "")
309 'main_unit (if file 316 'main_unit (if file
310 (file-name-nondirectory 317 (file-name-nondirectory
@@ -312,36 +319,39 @@ edited file, minus extension but with directory."
312 "") 319 "")
313 'cross_prefix "" 320 'cross_prefix ""
314 'remote_machine "" 321 'remote_machine ""
315 'comp_cmd (concat "cd ${build_dir} && " 322 'comp_cmd (list (concat ada-cd-command " ${build_dir}")
316 ada-prj-default-comp-cmd) 323 ada-prj-default-comp-cmd)
317 'check_cmd (concat ada-prj-default-comp-cmd " " 324 'check_cmd (list (concat ada-prj-default-comp-cmd " "
318 ada-check-switch) 325 ada-check-switch))
319 'make_cmd (concat "cd ${build_dir} && " 326 'make_cmd (list (concat ada-cd-command " ${build_dir}")
320 ada-prj-default-make-cmd) 327 ada-prj-default-make-cmd)
321 'run_cmd (concat "cd ${build_dir} && ${main}" 328 'run_cmd (list (concat ada-cd-command " ${build_dir}")
322 (if is-windows ".exe")) 329 (concat "${main}"
330 (if is-windows ".exe")))
331 'debug_pre_cmd (list (concat ada-cd-command
332 " ${build_dir}"))
323 'debug_cmd (concat ada-prj-default-debugger 333 'debug_cmd (concat ada-prj-default-debugger
324 (if is-windows " ${main}.exe" 334 (if is-windows " ${main}.exe"
325 " ${main}")))) 335 " ${main}"))
336 'debug_post_cmd (list nil)))
326 ) 337 )
327 (set symbol plist))) 338 (set symbol plist)))
328 339
329(defun ada-xref-get-project-field (field) 340(defun ada-xref-get-project-field (field)
330 "Extract the value of FIELD from the project file of the current buffer. 341 "Extract the value of FIELD from the current project file.
331The project file must have been loaded first. 342The project file must have been loaded first.
332A default value is returned if the file was not found." 343A default value is returned if the file was not found.
344
345Note that for src_dir and obj_dir, you should rather use
346`ada-xref-get-src-dir-field' or `ada-xref-get-obj-dir-field' which will in
347addition return the default paths."
333 348
334 (let ((file-name ada-prj-prj-file) 349 (let ((file-name ada-prj-default-project-file)
335 file value) 350 file value)
336 351
337 ;; If a default project file was set, use it if no other project 352 ;; Get the project file (either the current one, or a default one)
338 ;; file was specified for the buffer 353 (setq file (or (assoc file-name ada-xref-project-files)
339 (if (and (not file-name) 354 (assoc nil ada-xref-project-files)))
340 ada-prj-default-project-file
341 (not (string= ada-prj-default-project-file "")))
342 (set 'file-name ada-prj-default-project-file))
343
344 (set 'file (assoc file-name ada-xref-project-files))
345 355
346 ;; If the file was not found, use the default values 356 ;; If the file was not found, use the default values
347 (if file 357 (if file
@@ -351,12 +361,143 @@ A default value is returned if the file was not found."
351 ;; Create a default nil file that contains the default values 361 ;; Create a default nil file that contains the default values
352 (ada-xref-set-default-prj-values 'value (current-buffer)) 362 (ada-xref-set-default-prj-values 'value (current-buffer))
353 (add-to-list 'ada-xref-project-files (cons nil value)) 363 (add-to-list 'ada-xref-project-files (cons nil value))
364 (ada-xref-update-project-menu)
354 (set 'value (plist-get value field)) 365 (set 'value (plist-get value field))
355 ) 366 )
356 (if (stringp value) 367
357 (ada-treat-cmd-string value) 368 ;; Substitute the ${...} constructs in all the strings, including
358 value)) 369 ;; inside lists
359 ) 370 (cond
371 ((stringp value)
372 (ada-treat-cmd-string value))
373 ((null value)
374 nil)
375 ((listp value)
376 (mapcar (lambda(x) (if x (ada-treat-cmd-string x) x)) value))
377 (t
378 value)
379 )
380 ))
381
382
383(defun ada-xref-get-src-dir-field ()
384 "Return the full value for src_dir, including the default directories.
385All the directories are returned as absolute directories."
386
387 (let ((build-dir (ada-xref-get-project-field 'build_dir)))
388 (append
389 ;; Add ${build_dir} in front of the path
390 (list build-dir)
391
392 (ada-get-absolute-dir-list (ada-xref-get-project-field 'src_dir)
393 build-dir)
394
395 ;; Add the standard runtime at the end
396 ada-xref-runtime-library-specs-path)))
397
398(defun ada-xref-get-obj-dir-field ()
399 "Return the full value for obj_dir, including the default directories.
400All the directories are returned as absolute directories."
401
402 (let ((build-dir (ada-xref-get-project-field 'build_dir)))
403 (append
404 ;; Add ${build_dir} in front of the path
405 (list build-dir)
406
407 (ada-get-absolute-dir-list (ada-xref-get-project-field 'obj_dir)
408 build-dir)
409
410 ;; Add the standard runtime at the end
411 ada-xref-runtime-library-ali-path)))
412
413(defun ada-xref-update-project-menu ()
414 "Update the menu Ada->Project, with the list of available project files."
415 (interactive)
416 (let (submenu)
417
418 ;; Create the standard items
419 (set 'submenu (list (cons 'Load (cons "Load..."
420 'ada-set-default-project-file))
421 (cons 'New (cons "New..." 'ada-prj-new))
422 (cons 'Edit (cons "Edit..." 'ada-prj-edit))
423 (cons 'sep (cons "---" nil))))
424
425 ;; Add the new items
426 (mapcar
427 (lambda (x)
428 (let ((name (or (car x) "<default>"))
429 (command `(lambda ()
430 "Change the active project file."
431 (interactive)
432 (ada-parse-prj-file ,(car x))
433 (set 'ada-prj-default-project-file ,(car x))
434 (ada-xref-update-project-menu))))
435 (set 'submenu
436 (append submenu
437 (list (cons (intern name)
438 (list
439 'menu-item (file-name-sans-extension
440 (file-name-nondirectory name))
441 command
442 :button (cons
443 :toggle
444 (equal ada-prj-default-project-file
445 (car x))
446 ))))))))
447
448 ;; Parses all the known project files, and insert at least the default
449 ;; one (in case ada-xref-project-files is nil)
450 (or ada-xref-project-files '(nil)))
451
452 (if (not ada-xemacs)
453 (if (lookup-key ada-mode-map [menu-bar Ada Project])
454 (setcdr (lookup-key ada-mode-map [menu-bar Ada Project])
455 submenu)))
456 ))
457
458
459;;-------------------------------------------------------------
460;;-- Searching a file anywhere on the source path.
461;;--
462;;-- The following functions provide support for finding a file anywhere
463;;-- on the source path, without providing an explicit directory.
464;;-- They also provide file name completion in the minibuffer.
465;;--
466;;-- Public subprograms: ada-find-file
467;;--
468;;-------------------------------------------------------------
469
470(defun ada-do-file-completion (string predicate flag)
471 "Completion function when reading a file from the minibuffer.
472Completion is attempted in all the directories in the source path, as
473defined in the project file."
474 (let (list
475 (dirs (ada-xref-get-src-dir-field)))
476
477 (while dirs
478 (if (file-directory-p (car dirs))
479 (set 'list (append list (file-name-all-completions string (car dirs)))))
480 (set 'dirs (cdr dirs)))
481 (cond ((equal flag 'lambda)
482 (assoc string list))
483 (flag
484 list)
485 (t
486 (try-completion string
487 (mapcar (lambda (x) (cons x 1)) list)
488 predicate)))))
489
490;;;###autoload
491(defun ada-find-file (filename)
492 "Open a file anywhere in the source path.
493Completion is available."
494 (interactive
495 (list (completing-read "File: " 'ada-do-file-completion)))
496 (let ((file (ada-find-src-file-in-dir filename)))
497 (if file
498 (find-file file)
499 (error (concat filename " not found in src_dir")))))
500
360 501
361;; ----- Keybindings ------------------------------------------------------ 502;; ----- Keybindings ------------------------------------------------------
362 503
@@ -376,14 +517,14 @@ A default value is returned if the file was not found."
376 (define-key ada-mode-map "\C-c\C-s" 'ada-xref-goto-previous-reference) 517 (define-key ada-mode-map "\C-c\C-s" 'ada-xref-goto-previous-reference)
377 (define-key ada-mode-map "\C-c\C-x" 'ada-reread-prj-file) 518 (define-key ada-mode-map "\C-c\C-x" 'ada-reread-prj-file)
378 (define-key ada-mode-map "\C-c\C-c" 'ada-compile-application) 519 (define-key ada-mode-map "\C-c\C-c" 'ada-compile-application)
379 (define-key ada-mode-map "\C-cb" 'ada-buffer-list)
380 (define-key ada-mode-map "\C-cc" 'ada-change-prj) 520 (define-key ada-mode-map "\C-cc" 'ada-change-prj)
381 (define-key ada-mode-map "\C-cd" 'ada-change-default-prj) 521 (define-key ada-mode-map "\C-cd" 'ada-set-default-project-file)
382 (define-key ada-mode-map "\C-cg" 'ada-gdb-application) 522 (define-key ada-mode-map "\C-cg" 'ada-gdb-application)
383 (define-key ada-mode-map "\C-cr" 'ada-run-application) 523 (define-key ada-mode-map "\C-cr" 'ada-run-application)
384 (define-key ada-mode-map "\C-c\C-o" 'ada-goto-parent) 524 (define-key ada-mode-map "\C-c\C-o" 'ada-goto-parent)
385 (define-key ada-mode-map "\C-c\C-r" 'ada-find-references) 525 (define-key ada-mode-map "\C-c\C-r" 'ada-find-references)
386 (define-key ada-mode-map "\C-c\C-v" 'ada-check-current) 526 (define-key ada-mode-map "\C-c\C-v" 'ada-check-current)
527 (define-key ada-mode-map "\C-c\C-f" 'ada-find-file)
387 ) 528 )
388 529
389;; ----- Menus -------------------------------------------------------------- 530;; ----- Menus --------------------------------------------------------------
@@ -412,12 +553,6 @@ name as was passed to `ada-create-menu'."
412 menu-list ["Debug" ada-gdb-application t] "Goto") 553 menu-list ["Debug" ada-gdb-application t] "Goto")
413 (funcall (symbol-function 'add-menu-button) 554 (funcall (symbol-function 'add-menu-button)
414 menu-list ["--" nil t] "Goto") 555 menu-list ["--" nil t] "Goto")
415 (funcall (symbol-function 'add-submenu)
416 menu-list '("Project"
417 ["Associate" ada-change-prj t]
418 ["Set Default..." ada-set-default-project-file t]
419 ["List" ada-buffer-list t])
420 "Goto")
421 (funcall (symbol-function 'add-menu-button) 556 (funcall (symbol-function 'add-menu-button)
422 goto-menu ["Goto Parent Unit" ada-goto-parent t] 557 goto-menu ["Goto Parent Unit" ada-goto-parent t]
423 "Next compilation error") 558 "Next compilation error")
@@ -475,6 +610,13 @@ name as was passed to `ada-create-menu'."
475 (setq ada-xref-confirm-compile 610 (setq ada-xref-confirm-compile
476 (not ada-xref-confirm-compile)) 611 (not ada-xref-confirm-compile))
477 :style toggle :selected ada-xref-confirm-compile]) 612 :style toggle :selected ada-xref-confirm-compile])
613 (if (string-match "gvd" ada-prj-default-debugger)
614 (funcall (symbol-function 'add-menu-button)
615 options-menu
616 ["Tight Integration With Gnu Visual Debugger"
617 (setq ada-tight-gvd-integration
618 (not ada-tight-gvd-integration))
619 :style toggle :selected ada-tight-gvd-integration]))
478 ) 620 )
479 621
480 ;; for Emacs 622 ;; for Emacs
@@ -494,14 +636,7 @@ name as was passed to `ada-create-menu'."
494 (define-key-after menu [Debug] '("Debug" . ada-gdb-application) 'Run) 636 (define-key-after menu [Debug] '("Debug" . ada-gdb-application) 'Run)
495 (define-key-after menu [rem] '("--" . nil) 'Debug) 637 (define-key-after menu [rem] '("--" . nil) 'Debug)
496 (define-key-after menu [Project] 638 (define-key-after menu [Project]
497 (cons "Project" 639 (cons "Project" (make-sparse-keymap)) 'rem)
498 (funcall (symbol-function 'easy-menu-create-menu)
499 "Project"
500 '(["Associate..." ada-change-prj t
501 :included (string= mode-name "Ada")]
502 ["Set Default..." ada-set-default-project-file t]
503 ["List" ada-buffer-list t])))
504 'rem)
505 640
506 (define-key help-menu [Gnat_ug] 641 (define-key help-menu [Gnat_ug]
507 '("Gnat User Guide" . (lambda() (interactive) (info "gnat_ug")))) 642 '("Gnat User Guide" . (lambda() (interactive) (info "gnat_ug"))))
@@ -511,7 +646,7 @@ name as was passed to `ada-create-menu'."
511 '("Gcc Documentation" . (lambda() (interactive) (info "gcc")))) 646 '("Gcc Documentation" . (lambda() (interactive) (info "gcc"))))
512 (define-key help-menu [gdb] 647 (define-key help-menu [gdb]
513 '("Gdb Documentation" . (lambda() (interactive) (info "gdb")))) 648 '("Gdb Documentation" . (lambda() (interactive) (info "gdb"))))
514 (define-key help-menu [gdb] 649 (define-key help-menu [arm95]
515 '("Ada95 Reference Manual" . (lambda() (interactive) (info "arm95")))) 650 '("Ada95 Reference Manual" . (lambda() (interactive) (info "arm95"))))
516 651
517 (define-key goto-menu [rem] '("----" . nil)) 652 (define-key goto-menu [rem] '("----" . nil))
@@ -548,15 +683,30 @@ name as was passed to `ada-create-menu'."
548 (lambda()(interactive) 683 (lambda()(interactive)
549 (setq ada-xref-other-buffer (not ada-xref-other-buffer))) 684 (setq ada-xref-other-buffer (not ada-xref-other-buffer)))
550 :button (:toggle . ada-xref-other-buffer)) t) 685 :button (:toggle . ada-xref-other-buffer)) t)
686
687 (if (string-match "gvd" ada-prj-default-debugger)
688 (define-key-after options-menu [tightgvd]
689 '(menu-item "Tight Integration With Gnu Visual Debugger"
690 (lambda()(interactive)
691 (setq ada-tight-gvd-integration
692 (not ada-tight-gvd-integration)))
693 :button (:toggle . ada-tight-gvd-integration)) t))
694
695 (define-key ada-mode-map [menu-bar Ada Edit rem3] '("------------" . nil))
696 (define-key ada-mode-map [menu-bar Ada Edit open-file-from-src-path]
697 '("Search File on source path..." . ada-find-file))
551 ) 698 )
552 ) 699 )
700 (ada-xref-update-project-menu)
553 ) 701 )
554 702
555;; ----- Utilities ------------------------------------------------- 703;; ----- Utilities -------------------------------------------------
556 704
557(defun ada-require-project-file () 705(defun ada-require-project-file ()
558 "If no project file is assigned to this buffer, load one." 706 "If no project file is currently active, load a default one."
559 (if (not (my-local-variable-if-set-p 'ada-prj-prj-file (current-buffer))) 707 (if (or (not ada-prj-default-project-file)
708 (not ada-xref-project-files)
709 (string= ada-prj-default-project-file ""))
560 (ada-reread-prj-file))) 710 (ada-reread-prj-file)))
561 711
562(defun ada-xref-push-pos (filename position) 712(defun ada-xref-push-pos (filename position)
@@ -582,18 +732,7 @@ This is overriden on VMS to convert from VMS filenames to Unix filenames."
582(defun ada-set-default-project-file (name) 732(defun ada-set-default-project-file (name)
583 "Set the file whose name is NAME as the default project file." 733 "Set the file whose name is NAME as the default project file."
584 (interactive "fProject file:") 734 (interactive "fProject file:")
585
586 ;; All the directories should use this file as the default from now on,
587 ;; even if they were already associated with a file.
588 (set 'ada-xref-default-prj-file nil)
589
590 (set 'ada-prj-default-project-file name) 735 (set 'ada-prj-default-project-file name)
591
592 ;; Make sure that all the buffers see the new project file, even if they
593 ;; are not Ada buffers (for instance if we want to display the current
594 ;; project file in the frame title).
595 (setq-default ada-prj-prj-file name)
596
597 (ada-reread-prj-file name) 736 (ada-reread-prj-file name)
598 ) 737 )
599 738
@@ -608,90 +747,81 @@ file. If none is set, return nil."
608 747
609 (let (selected) 748 (let (selected)
610 749
611 ;; If we don't have an ada buffer, or the current buffer is not 750 ;; Use the active project file if there is one.
612 ;; a real file (for instance an emerge buffer) 751 ;; This is also valid if we don't currently have an Ada buffer, or if
752 ;; the current buffer is not a real file (for instance an emerge buffer)
613 753
614 (if (or (not (string= mode-name "Ada")) 754 (if (or (not (string= mode-name "Ada"))
615 (not (buffer-file-name))) 755 (not (buffer-file-name))
616 756 (and ada-prj-default-project-file
617 ;; 1st case: not an Ada buffer 757 (not (string= ada-prj-default-project-file ""))))
618 (if (and ada-prj-default-project-file 758 (set 'selected ada-prj-default-project-file)
619 (not (string= ada-prj-default-project-file ""))) 759
620 (set 'selected ada-prj-default-project-file)) 760 ;; other cases: use a more complex algorithm
621 761
622 ;; 2nd case: If the buffer already has a project file, use it 762 (let* ((current-file (buffer-file-name))
623 (if (my-local-variable-if-set-p 'ada-prj-prj-file (current-buffer)) 763 (first-choice (concat
624 (set 'selected ada-prj-prj-file) 764 (file-name-sans-extension current-file)
765 ada-project-file-extension))
766 (dir (file-name-directory current-file))
767
768 ;; on Emacs 20.2, directory-files does not work if
769 ;; parse-sexp-lookup-properties is set
770 (parse-sexp-lookup-properties nil)
771 (prj-files (directory-files
772 dir t
773 (concat ".*" (regexp-quote
774 ada-project-file-extension) "$")))
775 (choice nil))
625 776
626 (let* ((current-file (buffer-file-name)) 777 (cond
627 (first-choice (concat 778
628 (file-name-sans-extension current-file) 779 ;; Else if there is a project file with the same name as the Ada
629 ada-project-file-extension)) 780 ;; file, but not the same extension.
630 (dir (file-name-directory current-file)) 781 ((file-exists-p first-choice)
631 782 (set 'selected first-choice))
632 ;; on Emacs 20.2, directory-files does not work if 783
633 ;; parse-sexp-lookup-properties is set 784 ;; Else if only one project file was found in the current directory
634 (parse-sexp-lookup-properties nil) 785 ((= (length prj-files) 1)
635 (prj-files (directory-files 786 (set 'selected (car prj-files)))
636 dir t 787
637 (concat ".*" (regexp-quote ada-project-file-extension) "$"))) 788 ;; Else if there are multiple files, ask the user
638 (choice nil) 789 ((and (> (length prj-files) 1) (not no-user-question))
639 (default (assoc dir ada-xref-default-prj-file))) 790 (save-window-excursion
640 791 (with-output-to-temp-buffer "*choice list*"
641 (cond 792 (princ "There are more than one possible project file.\n")
642 793 (princ "Which one should we use ?\n\n")
643 ;; 3rd case: a project file is already associated with the directory 794 (princ " no. file name \n")
644 (default 795 (princ " --- ------------------------\n")
645 (set 'selected (cdr default))) 796 (let ((counter 1))
646 797 (while (<= counter (length prj-files))
647 ;; 4th case: the user has set a default project file for every file 798 (princ (format " %2d) %s\n"
648 ((and ada-prj-default-project-file 799 counter
649 (not (string= ada-prj-default-project-file ""))) 800 (nth (1- counter) prj-files)))
650 (set 'selected ada-prj-default-project-file)) 801 (setq counter (1+ counter))
651 802 ))) ; end of with-output-to ...
652 ;; 5th case: there is a project file with the same name as the Ada file, 803 (setq choice nil)
653 ;; but not the same extension. 804 (while (or
654 ((file-exists-p first-choice) 805 (not choice)
655 (set 'selected first-choice)) 806 (not (integerp choice))
656 807 (< choice 1)
657 ;; 6th case: only one project file was found in the current directory 808 (> choice (length prj-files)))
658 ((= (length prj-files) 1) 809 (setq choice (string-to-int
659 (set 'selected (car prj-files))) 810 (read-from-minibuffer "Enter No. of your choice: "))))
660 811 (set 'selected (nth (1- choice) prj-files))))
661 ;; 7th case: if there are multiple files, ask the user 812
662 ((and (> (length prj-files) 1) (not no-user-question)) 813 ;; Else if no project file was found in the directory, ask a name
663 (save-window-excursion 814 ;; to the user, using as a default value the last one entered by
664 (with-output-to-temp-buffer "*choice list*" 815 ;; the user
665 (princ "There are more than one possible project file. Which one should\n") 816 ((= (length prj-files) 0)
666 (princ "be used ?\n\n") 817 (unless (or no-user-question (not ada-always-ask-project))
667 (princ " no. file name \n") 818 (setq ada-last-prj-file
668 (princ " --- ------------------------\n") 819 (read-file-name
669 (let ((counter 1)) 820 (concat "project file [" ada-last-prj-file "]:")
670 (while (<= counter (length prj-files)) 821 nil ada-last-prj-file))
671 (princ (format " %2d) %s\n" 822 (unless (string= ada-last-prj-file "")
672 counter 823 (set 'selected ada-last-prj-file))))
673 (nth (1- counter) prj-files))) 824 )))
674 (setq counter (1+ counter))
675 ))) ; end of with-output-to ...
676 (setq choice nil)
677 (while (or
678 (not choice)
679 (not (integerp choice))
680 (< choice 1)
681 (> choice (length prj-files)))
682 (setq choice (string-to-int
683 (read-from-minibuffer "Enter No. of your choice: "))))
684 (set 'selected (nth (1- choice) prj-files))))
685
686 ;; 8th case: no project file was found in the directory, ask a name to the
687 ;; user, using as a default value the last one entered by the user
688 ((= (length prj-files) 0)
689 (unless (or no-user-question (not ada-always-ask-project))
690 (setq ada-last-prj-file
691 (read-file-name "project file:" nil ada-last-prj-file))
692 (unless (string= ada-last-prj-file "")
693 (set 'selected ada-last-prj-file))))
694 ))))
695 selected 825 selected
696 )) 826 ))
697 827
@@ -700,9 +830,10 @@ file. If none is set, return nil."
700 "Reads and parses the PRJ-FILE file if it was found. 830 "Reads and parses the PRJ-FILE file if it was found.
701The current buffer should be the ada-file buffer." 831The current buffer should be the ada-file buffer."
702 (if prj-file 832 (if prj-file
703 (let (project src_dir obj_dir casing 833 (let (project src_dir obj_dir make_cmd comp_cmd check_cmd casing
834 run_cmd debug_pre_cmd debug_post_cmd
704 (ada-buffer (current-buffer))) 835 (ada-buffer (current-buffer)))
705 (set 'prj-file (expand-file-name prj-file)) 836 (setq prj-file (expand-file-name prj-file))
706 837
707 ;; Initialize the project with the default values 838 ;; Initialize the project with the default values
708 (ada-xref-set-default-prj-values 'project (current-buffer)) 839 (ada-xref-set-default-prj-values 'project (current-buffer))
@@ -716,7 +847,7 @@ The current buffer should be the ada-file buffer."
716 847
717 (widen) 848 (widen)
718 (goto-char (point-min)) 849 (goto-char (point-min))
719 850
720 ;; Now overrides these values with the project file 851 ;; Now overrides these values with the project file
721 (while (not (eobp)) 852 (while (not (eobp))
722 (if (looking-at "^\\([^=]+\\)=\\(.*\\)") 853 (if (looking-at "^\\([^=]+\\)=\\(.*\\)")
@@ -733,6 +864,18 @@ The current buffer should be the ada-file buffer."
733 (set 'project 864 (set 'project
734 (plist-put project 'build_dir 865 (plist-put project 'build_dir
735 (file-name-as-directory (match-string 2))))) 866 (file-name-as-directory (match-string 2)))))
867 ((string= (match-string 1) "make_cmd")
868 (add-to-list 'make_cmd (match-string 2)))
869 ((string= (match-string 1) "comp_cmd")
870 (add-to-list 'comp_cmd (match-string 2)))
871 ((string= (match-string 1) "check_cmd")
872 (add-to-list 'check_cmd (match-string 2)))
873 ((string= (match-string 1) "run_cmd")
874 (add-to-list 'run_cmd (match-string 2)))
875 ((string= (match-string 1) "debug_pre_cmd")
876 (add-to-list 'debug_pre_cmd (match-string 2)))
877 ((string= (match-string 1) "debug_post_cmd")
878 (add-to-list 'debug_post_cmd (match-string 2)))
736 (t 879 (t
737 (set 'project (plist-put project (intern (match-string 1)) 880 (set 'project (plist-put project (intern (match-string 1))
738 (match-string 2)))))) 881 (match-string 2))))))
@@ -742,31 +885,48 @@ The current buffer should be the ada-file buffer."
742 (reverse src_dir)))) 885 (reverse src_dir))))
743 (if obj_dir (set 'project (plist-put project 'obj_dir 886 (if obj_dir (set 'project (plist-put project 'obj_dir
744 (reverse obj_dir)))) 887 (reverse obj_dir))))
745 (if casing (set 'project (plist-put project 'casing casing))) 888 (if casing (set 'project (plist-put project 'casing
746 889 (reverse casing))))
890 (if make_cmd (set 'project (plist-put project 'make_cmd
891 (reverse make_cmd))))
892 (if comp_cmd (set 'project (plist-put project 'comp_cmd
893 (reverse comp_cmd))))
894 (if check_cmd (set 'project (plist-put project 'check_cmd
895 (reverse check_cmd))))
896 (if run_cmd (set 'project (plist-put project 'run_cmd
897 (reverse run_cmd))))
898 (set 'project (plist-put project 'debug_post_cmd
899 (reverse debug_post_cmd)))
900 (set 'project (plist-put project 'debug_pre_cmd
901 (reverse debug_pre_cmd)))
902
903 ;; Delete the default project file from the list, if it is there.
904 ;; Note that in that case, this default project is the only one in
905 ;; the list
906 (if (assoc nil ada-xref-project-files)
907 (setq ada-xref-project-files nil))
908
747 ;; Memorize the newly read project file 909 ;; Memorize the newly read project file
748 (if (assoc prj-file ada-xref-project-files) 910 (if (assoc prj-file ada-xref-project-files)
749 (setcdr (assoc prj-file ada-xref-project-files) project) 911 (setcdr (assoc prj-file ada-xref-project-files) project)
750 (add-to-list 'ada-xref-project-files (cons prj-file project))) 912 (add-to-list 'ada-xref-project-files (cons prj-file project)))
913
914 ;; Set the project file as the active one.
915 (setq ada-prj-default-project-file prj-file)
751 916
752 ;; Sets up the compilation-search-path so that Emacs is able to 917 ;; Sets up the compilation-search-path so that Emacs is able to
753 ;; go to the source of the errors in a compilation buffer 918 ;; go to the source of the errors in a compilation buffer
754 (setq compilation-search-path (ada-get-absolute-dir-list 919 (setq compilation-search-path (ada-xref-get-src-dir-field))
755 (plist-get project 'src_dir) 920
756 (plist-get project 'build_dir))) 921 ;; Set the casing exceptions file list
757 922 (if casing
758 ;; Associate each source directory in the project file with this file 923 (progn
759 (mapcar (lambda (x) 924 (setq ada-case-exception-file (reverse casing))
760 (if (not (assoc (expand-file-name x) 925 (ada-case-read-exceptions)))
761 ada-xref-default-prj-file))
762 (setq ada-xref-default-prj-file
763 (cons (cons (expand-file-name x) prj-file)
764 ada-xref-default-prj-file))))
765 compilation-search-path)
766 926
767 ;; Add the directories to the search path for ff-find-other-file 927 ;; Add the directories to the search path for ff-find-other-file
768 ;; Do not add the '/' or '\' at the end 928 ;; Do not add the '/' or '\' at the end
769 (set (make-local-variable 'ff-search-directories) 929 (setq ada-search-directories
770 (append (mapcar 'directory-file-name compilation-search-path) 930 (append (mapcar 'directory-file-name compilation-search-path)
771 ada-search-directories)) 931 ada-search-directories))
772 932
@@ -774,10 +934,15 @@ The current buffer should be the ada-file buffer."
774 (kill-buffer nil) 934 (kill-buffer nil)
775 (set-buffer ada-buffer) 935 (set-buffer ada-buffer)
776 936
777 ;; Setup the project file for the current buffer 937 (ada-xref-update-project-menu)
778 (set (make-local-variable 'ada-prj-prj-file) prj-file)
779
780 ) 938 )
939
940 ;; No prj file ? => Setup default values
941 ;; Note that nil means that all compilation modes will first look in the
942 ;; current directory, and only then in the current file's directory. This
943 ;; current file is assumed at this point to be in the common source
944 ;; directory.
945 (setq compilation-search-path (list nil default-directory))
781 )) 946 ))
782 947
783 948
@@ -813,14 +978,26 @@ ENTITY was first found the location given by FILE, LINE and COLUMN."
813 (interactive "sEntity name: ") 978 (interactive "sEntity name: ")
814 (ada-require-project-file) 979 (ada-require-project-file)
815 980
816 (let* ((command (concat "gnatfind -rf " entity 981 ;; Prepare the gnatfind command. Note that we must protect the quotes
982 ;; around operators, so that they are correctly handled and can be
983 ;; processed (gnatfind \"+\":...).
984 (let* ((quote-entity
985 (if (= (aref entity 0) ?\")
986 (if is-windows
987 (concat "\\\"" (substring entity 1 -1) "\\\"")
988 (concat "'\"" (substring entity 1 -1) "\"'"))
989 entity))
990 (switches (ada-xref-get-project-field 'gnatfind_opt))
991 (command (concat "gnatfind " switches " "
992 quote-entity
817 (if file (concat ":" (file-name-nondirectory file))) 993 (if file (concat ":" (file-name-nondirectory file)))
818 (if line (concat ":" line)) 994 (if line (concat ":" line))
819 (if column (concat ":" column))))) 995 (if column (concat ":" column)))))
820 996
821 ;; If a project file is defined, use it 997 ;; If a project file is defined, use it
822 (if (my-local-variable-if-set-p 'ada-prj-prj-file (current-buffer)) 998 (if (and ada-prj-default-project-file
823 (setq command (concat command " -p" ada-prj-prj-file))) 999 (not (string= ada-prj-default-project-file "")))
1000 (setq command (concat command " -p" ada-prj-default-project-file)))
824 1001
825 (compile-internal command "No more references" "gnatfind") 1002 (compile-internal command "No more references" "gnatfind")
826 1003
@@ -831,83 +1008,7 @@ ENTITY was first found the location given by FILE, LINE and COLUMN."
831 ) 1008 )
832 ) 1009 )
833 1010
834(defun ada-buffer-list () 1011(defalias 'ada-change-prj (symbol-function 'ada-set-default-project-file))
835 "Display a buffer with all the Ada buffers and their associated project."
836 (interactive)
837 (save-excursion
838 (set-buffer (get-buffer-create "*Buffer List*"))
839 (setq buffer-read-only nil)
840 (erase-buffer)
841 (setq standard-output (current-buffer))
842 (princ "The following line is a list showing the associations between
843directories and project file. It has the format : ((directory_1 . project_file1)
844(directory2 . project_file2)...)\n\n")
845 (princ ada-xref-default-prj-file)
846 (princ "\n
847 Buffer Mode Project file
848 ------ ---- ------------
849\n")
850 (let ((bl (buffer-list)))
851 (while bl
852 (let* ((buffer (car bl))
853 (buffer-name (buffer-name buffer))
854 this-buffer-mode-name
855 this-buffer-project-file)
856 (save-excursion
857 (set-buffer buffer)
858 (setq this-buffer-mode-name
859 (if (eq buffer standard-output)
860 "Buffer Menu" mode-name))
861 (if (string= this-buffer-mode-name
862 "Ada")
863 (setq this-buffer-project-file
864 (if ( my-local-variable-if-set-p 'ada-prj-prj-file
865 (current-buffer))
866 (expand-file-name ada-prj-prj-file)
867 ""))))
868 (if (string= this-buffer-mode-name
869 "Ada")
870 (progn
871 (princ (format "%-19s " buffer-name))
872 (princ (format "%-6s " this-buffer-mode-name))
873 (princ this-buffer-project-file)
874 (princ "\n")
875 ))
876 ) ;; end let*
877 (setq bl (cdr bl))
878 ) ;; end while
879 );; end let
880 ) ;; end save-excursion
881 (display-buffer "*Buffer List*")
882 (other-window 1)
883 )
884
885(defun ada-change-prj (filename)
886 "Set FILENAME to be the project file for current buffer."
887 (interactive "fproject file:")
888
889 ;; make sure we are using an Ada file
890 (if (not (string= mode-name "Ada"))
891 (error "You must be in ada-mode to use this function"))
892
893 (set (make-local-variable 'ada-prj-prj-file) filename)
894 (ada-parse-prj-file filename)
895 )
896
897(defun ada-change-default-prj (filename)
898 "Set FILENAME to be the default project file for the current directory."
899 (interactive "ffile name:")
900 (let ((dir (file-name-directory (buffer-file-name)))
901 (prj (expand-file-name filename)))
902
903 ;; Associate the directory with a project file
904 (if (assoc dir ada-xref-default-prj-file)
905 (setcdr (assoc dir ada-xref-default-prj-file) prj)
906 (add-to-list 'ada-xref-default-prj-file (list dir prj)))
907
908 ;; Reparse the project file
909 (ada-parse-prj-file filename)))
910
911 1012
912;; ----- Identlist manipulation ------------------------------------------- 1013;; ----- Identlist manipulation -------------------------------------------
913;; An identlist is a vector that is used internally to reference an identifier 1014;; An identlist is a vector that is used internally to reference an identifier
@@ -985,24 +1086,29 @@ option."
985 (mouse-set-point last-input-event) 1086 (mouse-set-point last-input-event)
986 (ada-goto-declaration (point))) 1087 (ada-goto-declaration (point)))
987 1088
988(defun ada-goto-declaration (pos) 1089(defun ada-goto-declaration (pos &optional other-frame)
989 "Display the declaration of the identifier around POS. 1090 "Display the declaration of the identifier around POS.
990The declaration is shown in another buffer if `ada-xref-other-buffer' is 1091The declaration is shown in another buffer if `ada-xref-other-buffer' is
991non-nil." 1092non-nil.
1093If OTHER-FRAME is non-nil, display the cross-reference in another frame."
992 (interactive "d") 1094 (interactive "d")
993 (ada-require-project-file) 1095 (ada-require-project-file)
994 (push-mark pos) 1096 (push-mark pos)
995 (ada-xref-push-pos (buffer-file-name) pos) 1097 (ada-xref-push-pos (buffer-file-name) pos)
996 (ada-find-in-ali (ada-read-identifier pos)))
997 1098
998(defun ada-goto-declaration-other-frame (pos) 1099 ;; First try the standard algorithm by looking into the .ali file, but if
1100 ;; that file was too old or even did not exist, try to look in the whole
1101 ;; object path for a possible location.
1102 (let ((identlist (ada-read-identifier pos)))
1103 (condition-case nil
1104 (ada-find-in-ali identlist other-frame)
1105 (error (ada-find-in-src-path identlist other-frame)))))
1106
1107(defun ada-goto-declaration-other-frame (pos &optional other-frame)
999 "Display the declaration of the identifier around POS. 1108 "Display the declaration of the identifier around POS.
1000The declation is shown in another frame if `ada-xref-other-buffer' is non-nil." 1109The declation is shown in another frame if `ada-xref-other-buffer' is non-nil."
1001 (interactive "d") 1110 (interactive "d")
1002 (ada-require-project-file) 1111 (ada-goto-declaration pos t))
1003 (push-mark pos)
1004 (ada-xref-push-pos (buffer-file-name) pos)
1005 (ada-find-in-ali (ada-read-identifier pos) t))
1006 1112
1007(defun ada-remote (command) 1113(defun ada-remote (command)
1008 "Return the remote version of COMMAND, or COMMAND if remote_machine is nil." 1114 "Return the remote version of COMMAND, or COMMAND if remote_machine is nil."
@@ -1014,18 +1120,11 @@ The declation is shown in another frame if `ada-xref-other-buffer' is non-nil."
1014 machine 1120 machine
1015 command)))) 1121 command))))
1016 1122
1017(defun ada-get-absolute-dir (dir root-dir)
1018 "Returns the absolute directory corresponding to DIR.
1019If DIR is a relative directory, the value of ROOT-DIR is added in front."
1020 (if (= (string-to-char dir) ?/)
1021 dir
1022 (concat root-dir dir)))
1023
1024(defun ada-get-absolute-dir-list (dir-list root-dir) 1123(defun ada-get-absolute-dir-list (dir-list root-dir)
1025 "Returns the list of absolute directories found in dir-list. 1124 "Returns the list of absolute directories found in dir-list.
1026If a directory is a relative directory, the value of ROOT-DIR is added in 1125If a directory is a relative directory, the value of ROOT-DIR is added in
1027front." 1126front."
1028 (mapcar (lambda (x) (ada-get-absolute-dir x root-dir)) dir-list)) 1127 (mapcar (lambda (x) (expand-file-name x root-dir)) dir-list))
1029 1128
1030(defun ada-set-environment () 1129(defun ada-set-environment ()
1031 "Return the new value for process-environment. 1130 "Return the new value for process-environment.
@@ -1035,21 +1134,21 @@ project file."
1035 (objects (getenv "ADA_OBJECTS_PATH")) 1134 (objects (getenv "ADA_OBJECTS_PATH"))
1036 (build-dir (ada-xref-get-project-field 'build_dir))) 1135 (build-dir (ada-xref-get-project-field 'build_dir)))
1037 (if include 1136 (if include
1038 (set 'include (concat include path-separator))) 1137 (set 'include (concat path-separator include)))
1039 (if objects 1138 (if objects
1040 (set 'objects (concat objects path-separator))) 1139 (set 'objects (concat path-separator objects)))
1041 (cons 1140 (cons
1042 (concat "ADA_INCLUDE_PATH=" 1141 (concat "ADA_INCLUDE_PATH="
1043 include 1142 (mapconcat (lambda(x) (expand-file-name x build-dir))
1044 (mapconcat (lambda(x) (ada-get-absolute-dir x build-dir))
1045 (ada-xref-get-project-field 'src_dir) 1143 (ada-xref-get-project-field 'src_dir)
1046 path-separator)) 1144 path-separator)
1145 include)
1047 (cons 1146 (cons
1048 (concat "ADA_OBJECTS_PATH=" 1147 (concat "ADA_OBJECTS_PATH="
1049 objects 1148 (mapconcat (lambda(x) (expand-file-name x build-dir))
1050 (mapconcat (lambda(x) (ada-get-absolute-dir x build-dir))
1051 (ada-xref-get-project-field 'obj_dir) 1149 (ada-xref-get-project-field 'obj_dir)
1052 path-separator)) 1150 path-separator)
1151 objects)
1053 process-environment)))) 1152 process-environment))))
1054 1153
1055(defun ada-compile-application (&optional arg) 1154(defun ada-compile-application (&optional arg)
@@ -1061,19 +1160,26 @@ If ARG is not nil, ask for user confirmation."
1061 (process-environment (ada-set-environment)) 1160 (process-environment (ada-set-environment))
1062 (compilation-scroll-output t)) 1161 (compilation-scroll-output t))
1063 1162
1064 (set 'compilation-search-path 1163 (setq compilation-search-path (ada-xref-get-src-dir-field))
1065 (ada-get-absolute-dir-list (ada-xref-get-project-field 'src_dir)
1066 (ada-xref-get-project-field 'build_dir)))
1067 1164
1068 ;; If no project file was found, ask the user 1165 ;; If no project file was found, ask the user
1069 (unless cmd 1166 (unless cmd
1070 (setq cmd "" arg t)) 1167 (setq cmd '("") arg t))
1071 1168
1072 (compile (ada-remote 1169 ;; Make a single command from the list of commands, including the
1073 (if (or ada-xref-confirm-compile arg) 1170 ;; commands to run it on a remote machine.
1074 (read-from-minibuffer "enter command to compile: " cmd) 1171 (setq cmd (ada-remote (mapconcat 'identity cmd ada-command-separator)))
1075 cmd))) 1172
1076 )) 1173 (if (or ada-xref-confirm-compile arg)
1174 (setq cmd (read-from-minibuffer "enter command to compile: " cmd)))
1175
1176 ;; Insert newlines so as to separate the name of the commands to run
1177 ;; and the output of the commands. this doesn't work with cmdproxy.exe,
1178 ;; which gets confused by newline characters.
1179 (if (not (string-match "cmdproxy.exe" shell-file-name))
1180 (setq cmd (concat cmd "\n\n")))
1181
1182 (compile (ada-quote-cmd cmd))))
1077 1183
1078(defun ada-compile-current (&optional arg prj-field) 1184(defun ada-compile-current (&optional arg prj-field)
1079 "Recompile the current file. 1185 "Recompile the current file.
@@ -1087,19 +1193,26 @@ command, and should be either comp_cmd (default) or check_cmd."
1087 (process-environment (ada-set-environment)) 1193 (process-environment (ada-set-environment))
1088 (compilation-scroll-output t)) 1194 (compilation-scroll-output t))
1089 1195
1090 (set 'compilation-search-path 1196 (setq compilation-search-path (ada-xref-get-src-dir-field))
1091 (ada-get-absolute-dir-list (ada-xref-get-project-field 'src_dir)
1092 (ada-xref-get-project-field 'build_dir)))
1093 1197
1198 (unless cmd
1199 (setq cmd '("") arg t))
1200
1201 ;; Make a single command from the list of commands, including the
1202 ;; commands to run it on a remote machine.
1203 (setq cmd (ada-remote (mapconcat 'identity cmd ada-command-separator)))
1204
1094 ;; If no project file was found, ask the user 1205 ;; If no project file was found, ask the user
1095 (if cmd 1206 (if (or ada-xref-confirm-compile arg)
1096 (set 'cmd (concat cmd " " (ada-convert-file-name (buffer-file-name)))) 1207 (setq cmd (read-from-minibuffer "enter command to compile: " cmd)))
1097 (setq cmd "" arg t)) 1208
1209 ;; Insert newlines so as to separate the name of the commands to run
1210 ;; and the output of the commands. this doesn't work with cmdproxy.exe,
1211 ;; which gets confused by newline characters.
1212 (if (not (string-match "cmdproxy.exe" shell-file-name))
1213 (setq cmd (concat cmd "\n\n")))
1098 1214
1099 (compile (ada-remote 1215 (compile (ada-quote-cmd cmd))))
1100 (if (or ada-xref-confirm-compile arg)
1101 (read-from-minibuffer "enter command to compile: " cmd)
1102 cmd)))))
1103 1216
1104(defun ada-check-current (&optional arg) 1217(defun ada-check-current (&optional arg)
1105 "Recompile the current file. 1218 "Recompile the current file.
@@ -1120,24 +1233,32 @@ if ARG is not-nil, asks for user confirmation."
1120 (let ((command (ada-xref-get-project-field 'run_cmd))) 1233 (let ((command (ada-xref-get-project-field 'run_cmd)))
1121 1234
1122 ;; Guess the command if it wasn't specified 1235 ;; Guess the command if it wasn't specified
1123 (if (or (not command) (string= command "")) 1236 (if (not command)
1124 (set 'command (file-name-sans-extension (buffer-name)))) 1237 (set 'command (list (file-name-sans-extension (buffer-name)))))
1125 1238
1239 ;; Modify the command to run remotely
1240 (setq command (ada-remote (mapconcat 'identity command
1241 ada-command-separator)))
1242
1126 ;; Ask for the arguments to the command if required 1243 ;; Ask for the arguments to the command if required
1127 (if (or ada-xref-confirm-compile arg) 1244 (if (or ada-xref-confirm-compile arg)
1128 (set 'command (read-from-minibuffer "Enter command to execute: " command))) 1245 (setq command (read-from-minibuffer "Enter command to execute: "
1129 1246 command)))
1130 ;; Modify the command to run remotely
1131 (setq command (ada-remote command))
1132 1247
1133 ;; Run the command 1248 ;; Run the command
1134 (save-excursion 1249 (save-excursion
1135 (set-buffer (get-buffer-create "*run*")) 1250 (set-buffer (get-buffer-create "*run*"))
1136 (set 'buffer-read-only nil) 1251 (set 'buffer-read-only nil)
1252
1137 (erase-buffer) 1253 (erase-buffer)
1138 (goto-char (point-min)) 1254 (start-process "run" (current-buffer) shell-file-name
1139 (insert "\nRunning " command "\n\n") 1255 "-c" command)
1140 (start-process "run" (current-buffer) shell-file-name "-c" command) 1256 (comint-mode)
1257 ;; Set these two variables to their default values, since otherwise
1258 ;; the output buffer is scrolled so that only the last output line
1259 ;; is visible at the top of the buffer.
1260 (set (make-local-variable 'scroll-step) 0)
1261 (set (make-local-variable 'scroll-conservatively) 0)
1141 ) 1262 )
1142 (display-buffer "*run*") 1263 (display-buffer "*run*")
1143 1264
@@ -1146,53 +1267,107 @@ if ARG is not-nil, asks for user confirmation."
1146 (switch-to-buffer "*run*") 1267 (switch-to-buffer "*run*")
1147 )) 1268 ))
1148 1269
1149 1270(defun ada-gdb-application (&optional arg executable-name)
1150(defun ada-gdb-application (&optional arg)
1151 "Start the debugger on the application. 1271 "Start the debugger on the application.
1272EXECUTABLE-NAME, if non-nil, is debugged instead of the file specified in the
1273project file.
1152If ARG is non-nil, ask the user to confirm the command." 1274If ARG is non-nil, ask the user to confirm the command."
1153 (interactive "P") 1275 (interactive "P")
1154 (let ((buffer (current-buffer)) 1276 (let ((buffer (current-buffer))
1155 gdb-buffer 1277 cmd pre-cmd post-cmd)
1156 cmd)
1157 (ada-require-project-file) 1278 (ada-require-project-file)
1158 (set 'cmd (ada-xref-get-project-field 'debug_cmd)) 1279 (setq cmd (if executable-name
1159 (let ((machine (ada-xref-get-project-field 'remote_machine))) 1280 (concat ada-prj-default-debugger " " executable-name)
1160 (if (and machine (not (string= machine ""))) 1281 (ada-xref-get-project-field 'debug_cmd))
1161 (error "This feature is not supported yet for remote environments"))) 1282 pre-cmd (ada-xref-get-project-field 'debug_pre_cmd)
1283 post-cmd (ada-xref-get-project-field 'debug_post_cmd))
1162 1284
1163 ;; If the command was not given in the project file, start a bare gdb 1285 ;; If the command was not given in the project file, start a bare gdb
1164 (if (not cmd) 1286 (if (not cmd)
1165 (set 'cmd (concat ada-prj-default-debugger 1287 (set 'cmd (concat ada-prj-default-debugger
1166 " " 1288 " "
1167 (file-name-sans-extension (buffer-file-name))))) 1289 (or executable-name
1290 (file-name-sans-extension (buffer-file-name))))))
1291
1292 ;; For gvd, add an extra switch so that the Emacs window is completly
1293 ;; swallowed inside the Gvd one
1294 (if (and ada-tight-gvd-integration
1295 (string-match "^[^ \t]*gvd" cmd))
1296 ;; Start a new frame, so that when gvd exists we do not kill Emacs
1297 ;; We make sure that gvd swallows the new frame, not the one the
1298 ;; user has been using until now
1299 ;; The frame is made invisible initially, so that GtkPlug gets a
1300 ;; chance to fully manage it. Then it works fine with Enlightenment
1301 ;; as well
1302 (let ((frame (make-frame '((visibility . nil)))))
1303 (set 'cmd (concat
1304 cmd " --editor-window="
1305 (cdr (assoc 'outer-window-id (frame-parameters frame)))))
1306 (select-frame frame)))
1307
1308 ;; Add a -fullname switch
1309 ;; Use the remote machine
1310 (set 'cmd (ada-remote (concat cmd " -fullname ")))
1311
1312 ;; Ask for confirmation if required
1168 (if (or arg ada-xref-confirm-compile) 1313 (if (or arg ada-xref-confirm-compile)
1169 (set 'cmd (read-from-minibuffer "enter command to debug: " cmd))) 1314 (set 'cmd (read-from-minibuffer "enter command to debug: " cmd)))
1170 1315
1171 ;; Set the variable gud-last-last-frame so that glide-debug can find 1316 (let (comint-exec
1172 ;; the name of the Ada file, and thus of the project file if needed. 1317 in-post-mode
1173 (if ada-prj-prj-file 1318 gud-gdb-massage-args)
1174 (set 'gud-last-last-frame (cons ada-prj-prj-file 1))) 1319
1175 1320 ;; Do not add -fullname, since we can have a 'rsh' command in front.
1176 (if (and (string-match "jdb" (comint-arguments cmd 0 0)) 1321 (fset 'gud-gdb-massage-args (lambda (file args) args))
1177 (boundp 'jdb)) 1322
1178 (funcall (symbol-function 'jdb) cmd) 1323 (set 'pre-cmd (mapconcat 'identity pre-cmd ada-command-separator))
1179 (gdb cmd)) 1324 (if (not (equal pre-cmd ""))
1180 1325 (setq pre-cmd (concat pre-cmd ada-command-separator)))
1181 (set 'gdb-buffer (symbol-value 'gud-comint-buffer)) 1326
1182 1327 (set 'post-cmd (mapconcat 'identity post-cmd "\n"))
1183 ;; Switch back to the source buffer 1328 (if post-cmd
1184 ;; and Activate the debug part in the contextual menu 1329 (set 'post-cmd (concat post-cmd "\n")))
1185 (switch-to-buffer buffer) 1330
1186 1331 ;; Temporarily replaces the definition of `comint-exec' so that we
1187 (if (functionp 'gud-make-debug-menu) 1332 ;; can execute commands before running gdb.
1188 (funcall (symbol-function 'gud-make-debug-menu))) 1333 (fset 'comint-exec
1189 1334 `(lambda (buffer name command startfile switches)
1190 ;; Warning: on Emacs >= 20.3.8, same-window-regexps includes gud-*, 1335 (let (compilation-buffer-name-function)
1191 ;; so the following call to display buffer will select the 1336 (save-excursion
1192 ;; buffer instead of displaying it in another window 1337 (set 'compilation-buffer-name-function
1193 ;; This is why the second argument to display-buffer is 't' 1338 (lambda(x) (buffer-name buffer)))
1194 (display-buffer gdb-buffer t) 1339 (compile (ada-quote-cmd
1195 )) 1340 (concat ,pre-cmd
1341 command " "
1342 (mapconcat 'identity switches " "))))))
1343 ))
1344
1345 ;; Tight integration should force the tty mode
1346 (if (and (string-match "gvd" (comint-arguments cmd 0 0))
1347 ada-tight-gvd-integration
1348 (not (string-match "--tty" cmd)))
1349 (setq cmd (concat cmd "--tty")))
1350
1351 (if (and (string-match "jdb" (comint-arguments cmd 0 0))
1352 (boundp 'jdb))
1353 (funcall (symbol-function 'jdb) cmd)
1354 (gdb cmd))
1355
1356 ;; Send post-commands to the debugger
1357 (process-send-string (get-buffer-process (current-buffer)) post-cmd)
1358
1359 ;; Move to the end of the debugger buffer, so that it is automatically
1360 ;; scrolled from then on.
1361 (end-of-buffer)
1362
1363 ;; Display both the source window and the debugger window (the former
1364 ;; above the latter). No need to show the debugger window unless it
1365 ;; is going to have some relevant information.
1366 (if (or (not (string-match "gvd" (comint-arguments cmd 0 0)))
1367 (string-match "--tty" cmd))
1368 (split-window-vertically))
1369 (switch-to-buffer buffer)
1370 )))
1196 1371
1197 1372
1198(defun ada-reread-prj-file (&optional filename) 1373(defun ada-reread-prj-file (&optional filename)
@@ -1205,35 +1380,53 @@ automatically modifies the setup for all the Ada buffer that use this file."
1205 (if filename 1380 (if filename
1206 (ada-parse-prj-file filename) 1381 (ada-parse-prj-file filename)
1207 (ada-parse-prj-file (ada-prj-find-prj-file))) 1382 (ada-parse-prj-file (ada-prj-find-prj-file)))
1208 )
1209 1383
1384 ;; Reread the location of the standard runtime library
1385 (ada-initialize-runtime-library
1386 (or (ada-xref-get-project-field 'cross-prefix) ""))
1387 )
1210 1388
1211;; ------ Private routines 1389;; ------ Private routines
1212 1390
1213(defun ada-xref-current (file &optional ali-file-name) 1391(defun ada-xref-current (file &optional ali-file-name)
1214 "Update the cross-references for FILE. 1392 "Update the cross-references for FILE.
1215This in fact recompiles FILE to create ALI-FILE-NAME." 1393This in fact recompiles FILE to create ALI-FILE-NAME.
1394This function returns the name of the file that was recompiled to generate
1395the cross-reference information. Note that the ali file can then be deduced by
1396replacing the file extension with .ali"
1216 ;; kill old buffer 1397 ;; kill old buffer
1217 (if (and ali-file-name 1398 (if (and ali-file-name
1218 (get-file-buffer ali-file-name)) 1399 (get-file-buffer ali-file-name))
1219 (kill-buffer (get-file-buffer ali-file-name))) 1400 (kill-buffer (get-file-buffer ali-file-name)))
1220 ;; read the project file 1401
1221 (ada-require-project-file) 1402 (let* ((name (ada-convert-file-name file))
1222 (let* ((cmd (ada-xref-get-project-field 'comp_cmd)) 1403 (body-name (or (ada-get-body-name name) name)))
1223 (process-environment (ada-set-environment))
1224 (compilation-scroll-output t)
1225 (name (ada-convert-file-name (buffer-file-name)))
1226 (body-name (ada-get-body-name name)))
1227
1228 ;; Always recompile the body when we can
1229 (set 'body-name (or body-name name))
1230 1404
1231 ;; prompt for command to execute 1405 ;; Always recompile the body when we can. We thus temporarily switch to a
1232 (set 'cmd (concat cmd " " body-name)) 1406 ;; buffer than contains the body of the unit
1233 (compile (ada-remote 1407 (save-excursion
1234 (if ada-xref-confirm-compile 1408 (let ((body-visible (find-buffer-visiting body-name))
1235 (read-from-minibuffer "enter command to compile: " cmd) 1409 process)
1236 cmd))))) 1410 (if body-visible
1411 (set-buffer body-visible)
1412 (find-file body-name))
1413
1414 ;; Execute the compilation. Note that we must wait for the end of the
1415 ;; process, or the ALI file would still not be available.
1416 ;; Unfortunately, the underlying `compile' command that we use is
1417 ;; asynchronous.
1418 (ada-compile-current)
1419 (setq process (get-buffer-process "*compilation*"))
1420
1421 (while (and process
1422 (not (equal (process-status process) 'exit)))
1423 (sit-for 1))
1424
1425 ;; remove the buffer for the body if it wasn't there before
1426 (unless body-visible
1427 (kill-buffer (find-buffer-visiting body-name)))
1428 ))
1429 body-name))
1237 1430
1238(defun ada-find-file-in-dir (file dir-list) 1431(defun ada-find-file-in-dir (file dir-list)
1239 "Search for FILE in DIR-LIST." 1432 "Search for FILE in DIR-LIST."
@@ -1251,36 +1444,13 @@ This in fact recompiles FILE to create ALI-FILE-NAME."
1251 "Find an .ali file in obj_dir. The current buffer must be the Ada file. 1444 "Find an .ali file in obj_dir. The current buffer must be the Ada file.
1252Adds build_dir in front of the search path to conform to gnatmake's behavior, 1445Adds build_dir in front of the search path to conform to gnatmake's behavior,
1253and the standard runtime location at the end." 1446and the standard runtime location at the end."
1254 (ada-find-file-in-dir file 1447 (ada-find-file-in-dir file (ada-xref-get-obj-dir-field)))
1255 (append
1256
1257 ;; Add ${build_dir} in front of the path
1258 (list (ada-xref-get-project-field 'build_dir))
1259
1260 (ada-get-absolute-dir-list
1261 (ada-xref-get-project-field 'obj_dir)
1262 (ada-xref-get-project-field 'build_dir))
1263
1264 ;; Add the standard runtime at the end
1265 ada-xref-runtime-library-ali-path)))
1266 1448
1267(defun ada-find-src-file-in-dir (file) 1449(defun ada-find-src-file-in-dir (file)
1268 "Find a source file in src_dir. The current buffer must be the Ada file. 1450 "Find a source file in src_dir. The current buffer must be the Ada file.
1269Adds src_dir in front of the search path to conform to gnatmake's behavior, 1451Adds src_dir in front of the search path to conform to gnatmake's behavior,
1270and the standard runtime location at the end." 1452and the standard runtime location at the end."
1271 (ada-find-file-in-dir file 1453 (ada-find-file-in-dir file (ada-xref-get-src-dir-field)))
1272 (append
1273
1274 ;; Add ${build_dir} in front of the path
1275 (list (ada-xref-get-project-field 'build_dir))
1276
1277 (ada-get-absolute-dir-list
1278 (ada-xref-get-project-field 'src_dir)
1279 (ada-xref-get-project-field 'build_dir))
1280
1281 ;; Add the standard runtime at the end
1282 ada-xref-runtime-library-specs-path)))
1283
1284 1454
1285(defun ada-get-ali-file-name (file) 1455(defun ada-get-ali-file-name (file)
1286 "Create the ali file name for the ada-file FILE. 1456 "Create the ali file name for the ada-file FILE.
@@ -1298,68 +1468,98 @@ the project file."
1298 ;; 3- If the file is not found or step 2 failed: 1468 ;; 3- If the file is not found or step 2 failed:
1299 ;; find the name of the "other file", ie the body, and look 1469 ;; find the name of the "other file", ie the body, and look
1300 ;; for its associated .ali file by subtituing the extension 1470 ;; for its associated .ali file by subtituing the extension
1471 ;;
1472 ;; We must also handle the case of separate packages and subprograms:
1473 ;; 4- If no ali file was found, we try to modify the file name by removing
1474 ;; everything after the last '-' or '.' character, so as to get the
1475 ;; ali file for the parent unit. If we found an ali file, we check that
1476 ;; it indeed contains the definition for the separate entity by checking
1477 ;; the 'D' lines. This is done repeatedly, in case the direct parent is
1478 ;; also a separate.
1301 1479
1302 (save-excursion 1480 (save-excursion
1303 (set-buffer (get-file-buffer file)) 1481 (set-buffer (get-file-buffer file))
1304 (let ((short-ali-file-name 1482 (let ((short-ali-file-name
1305 (concat (file-name-sans-extension (file-name-nondirectory file)) 1483 (concat (file-name-sans-extension (file-name-nondirectory file))
1306 ".ali")) 1484 ".ali"))
1307 ali-file-name) 1485 ali-file-name
1308 ;; First step 1486 is-spec)
1309 ;; we take the first possible completion 1487
1310 (setq ali-file-name (ada-find-ali-file-in-dir short-ali-file-name)) 1488 ;; If we have a non-standard file name, and this is a spec, we first
1311 1489 ;; look for the .ali file of the body, since this is the one that
1312 ;; If we have found the .ali file, but the source file was a spec 1490 ;; contains the most complete information. If not found, we will do what
1313 ;; with a non-standard name, search the .ali file for the body if any, 1491 ;; we can with the .ali file for the spec...
1314 ;; since the xref information is more complete in that one 1492
1315 (unless ali-file-name 1493 (if (not (string= (file-name-extension file) "ads"))
1316 (if (not (string= (file-name-extension file) "ads")) 1494 (let ((specs ada-spec-suffixes))
1317 (let ((is-spec nil) 1495 (while specs
1318 (specs ada-spec-suffixes) 1496 (if (string-match (concat (regexp-quote (car specs)) "$")
1319 body-ali) 1497 file)
1320 (while specs 1498 (set 'is-spec t))
1321 (if (string-match (concat (regexp-quote (car specs)) "$") 1499 (set 'specs (cdr specs)))))
1322 file) 1500
1323 (set 'is-spec t)) 1501 (if is-spec
1324 (set 'specs (cdr specs))) 1502 (set 'ali-file-name
1325 1503 (ada-find-ali-file-in-dir
1326 (if is-spec 1504 (concat (file-name-sans-extension
1327 (set 'body-ali 1505 (file-name-nondirectory
1328 (ada-find-ali-file-in-dir 1506 (ada-other-file-name)))
1329 (concat (file-name-sans-extension 1507 ".ali"))))
1330 (file-name-nondirectory 1508
1331 (ada-other-file-name))) 1509
1332 ".ali")))) 1510 (setq ali-file-name
1333 (if body-ali 1511 (or ali-file-name
1334 (set 'ali-file-name body-ali)))) 1512
1335 1513 ;; Else we take the .ali file associated with the unit
1336 ;; else we did not find the .ali file 1514 (ada-find-ali-file-in-dir short-ali-file-name)
1337 ;; Second chance: in case the files do not have standard names (such 1515
1338 ;; as for instance file_s.ada and file_b.ada), try to go to the 1516
1339 ;; other file and look for its ali file 1517 ;; else we did not find the .ali file Second chance: in case
1340 (setq short-ali-file-name 1518 ;; the files do not have standard names (such as for instance
1341 (concat (file-name-sans-extension 1519 ;; file_s.ada and file_b.ada), try to go to the other file
1342 (file-name-nondirectory (ada-other-file-name))) 1520 ;; and look for its ali file
1343 ".ali")) 1521 (ada-find-ali-file-in-dir
1344 (setq ali-file-name (ada-find-ali-file-in-dir short-ali-file-name)) 1522 (concat (file-name-sans-extension
1345 1523 (file-name-nondirectory (ada-other-file-name)))
1346 ;; If still not found, try to recompile the file 1524 ".ali"))
1347 (if (not ali-file-name) 1525
1348 (progn 1526
1349 ;; recompile only if the user asked for this 1527 ;; If we still don't have an ali file, try to get the one
1350 (if ada-xref-create-ali 1528 ;; from the parent unit, in case we have a separate entity.
1351 (ada-xref-current file ali-file-name)) 1529 (let ((parent-name (file-name-sans-extension
1352 (error "Ali file not found. Recompile your file"))) 1530 (file-name-nondirectory file))))
1353 ) 1531
1532 (while (and (not ali-file-name)
1533 (string-match "^\\(.*\\)[.-][^.-]*" parent-name))
1534
1535 (set 'parent-name (match-string 1 parent-name))
1536 (set 'ali-file-name (ada-find-ali-file-in-dir
1537 (concat parent-name ".ali")))
1538 )
1539 ali-file-name)))
1540
1541 ;; If still not found, try to recompile the file
1542 (if (not ali-file-name)
1543 ;; recompile only if the user asked for this. and search the ali
1544 ;; filename again. We avoid a possible infinite recursion by
1545 ;; temporarily disabling the automatic compilation.
1546
1547 (if ada-xref-create-ali
1548 (setq ali-file-name
1549 (concat (file-name-sans-extension (ada-xref-current file))
1550 ".ali"))
1354 1551
1355 ;; same if the .ali file is too old and we must recompile it 1552 (error "Ali file not found. Recompile your file"))
1356 (if (and (file-newer-than-file-p file ali-file-name) 1553
1357 ada-xref-create-ali) 1554
1358 (ada-xref-current file ali-file-name)) 1555 ;; same if the .ali file is too old and we must recompile it
1556 (if (and (file-newer-than-file-p file ali-file-name)
1557 ada-xref-create-ali)
1558 (ada-xref-current file ali-file-name)))
1359 1559
1360 ;; else returns the correct absolute file name 1560 ;; Always return the correct absolute file name
1361 (expand-file-name ali-file-name)) 1561 (expand-file-name ali-file-name))
1362 )) 1562 ))
1363 1563
1364(defun ada-get-ada-file-name (file original-file) 1564(defun ada-get-ada-file-name (file original-file)
1365 "Create the complete file name (+directory) for FILE. 1565 "Create the complete file name (+directory) for FILE.
@@ -1398,14 +1598,9 @@ file for possible paths."
1398 (count-lines begin (point)))) 1598 (count-lines begin (point))))
1399 1599
1400(defun ada-read-identifier (pos) 1600(defun ada-read-identifier (pos)
1401 "Returns the identlist around POS and switch to the .ali buffer." 1601 "Returns the identlist around POS and switch to the .ali buffer.
1402 1602The returned list represents the entity, and can be manipulated through the
1403 ;; If there's a compilation in progress, it's probably because the 1603macros `ada-name-of', `ada-line-of', `ada-column-of', `ada-file-of',..."
1404 ;; .ali file didn't exist. So we should wait...
1405 (if compilation-in-progress
1406 (progn
1407 (message "Compilation in progress. Try again when it is finished")
1408 (set 'quit-flag t)))
1409 1604
1410 ;; If at end of buffer (e.g the buffer is empty), error 1605 ;; If at end of buffer (e.g the buffer is empty), error
1411 (if (>= (point) (point-max)) 1606 (if (>= (point) (point-max))
@@ -1510,11 +1705,13 @@ from the ali file (definition file and places where it is referenced)."
1510 ;; if we did not find it, it may be because the first reference 1705 ;; if we did not find it, it may be because the first reference
1511 ;; is not required to have a 'unit_number|' item included. 1706 ;; is not required to have a 'unit_number|' item included.
1512 ;; Or maybe we are already on the declaration... 1707 ;; Or maybe we are already on the declaration...
1513 (unless (re-search-forward (concat "^\\([a-zA-Z0-9_.\"]+[ *]\\)*" 1708 (unless (re-search-forward
1514 (ada-line-of identlist) 1709 (concat
1515 "[^0-9]" 1710 "^\\(\\([a-zA-Z0-9_.]+\\|\"[<>=+*-/a-z]\"\\)[ *]\\)*"
1516 (ada-column-of identlist)) 1711 (ada-line-of identlist)
1517 nil t) 1712 "[^0-9]"
1713 (ada-column-of identlist))
1714 nil t)
1518 1715
1519 ;; If still not found, then either the declaration is unknown 1716 ;; If still not found, then either the declaration is unknown
1520 ;; or the source file has been modified since the ali file was 1717 ;; or the source file has been modified since the ali file was
@@ -1566,10 +1763,19 @@ from the ali file (definition file and places where it is referenced)."
1566 ) 1763 )
1567 1764
1568 (if (re-search-backward "^X [0-9]+ \\([a-zA-Z0-9_.-]+\\)" nil t) 1765 (if (re-search-backward "^X [0-9]+ \\([a-zA-Z0-9_.-]+\\)" nil t)
1569 (ada-set-declare-file 1766
1570 identlist 1767 ;; If we can find the file
1571 (ada-get-ada-file-name (match-string 1) 1768 (condition-case err
1572 (ada-file-of identlist)))) 1769 (ada-set-declare-file
1770 identlist
1771 (ada-get-ada-file-name (match-string 1)
1772 (ada-file-of identlist)))
1773
1774 ;; Else clean up the ali file
1775 (error
1776 (kill-buffer ali-buffer)
1777 (error (error-message-string err)))
1778 ))
1573 1779
1574 (ada-set-references identlist current-line) 1780 (ada-set-references identlist current-line)
1575 )) 1781 ))
@@ -1630,34 +1836,37 @@ This function is disabled for operators, and only works for identifiers."
1630 1836
1631 ;; more than one => display choice list 1837 ;; more than one => display choice list
1632 (t 1838 (t
1633 (with-output-to-temp-buffer "*choice list*" 1839 (save-window-excursion
1634 1840 (with-output-to-temp-buffer "*choice list*"
1635 (princ "Identifier is overloaded and Xref information is not up to date.\n") 1841
1636 (princ "Possible declarations are:\n\n") 1842 (princ "Identifier is overloaded and Xref information is not up to date.\n")
1637 (princ " no. in file at line col\n") 1843 (princ "Possible declarations are:\n\n")
1638 (princ " --- --------------------- ---- ----\n") 1844 (princ " no. in file at line col\n")
1639 (let ((counter 1)) 1845 (princ " --- --------------------- ---- ----\n")
1640 (while (<= counter len) 1846 (let ((counter 0))
1641 (princ (format " %2d) %-21s %4s %4s\n" 1847 (while (< counter len)
1642 counter 1848 (princ (format " %2d) %-21s %4s %4s\n"
1849 (1+ counter)
1643 (ada-get-ada-file-name 1850 (ada-get-ada-file-name
1644 (nth 1 (nth (1- counter) declist)) 1851 (nth 1 (nth counter declist))
1645 (ada-file-of identlist)) 1852 (ada-file-of identlist))
1646 (nth 2 (nth (1- counter) declist)) 1853 (nth 2 (nth counter declist))
1647 (nth 3 (nth (1- counter) declist)) 1854 (nth 3 (nth counter declist))
1648 )) 1855 ))
1649 (setq counter (1+ counter)) 1856 (setq counter (1+ counter))
1650 ) ; end of while 1857 ) ; end of while
1651 ) ; end of let 1858 ) ; end of let
1652 ) ; end of with-output-to ... 1859 ) ; end of with-output-to ...
1653 (setq choice nil) 1860 (setq choice nil)
1654 (while (or 1861 (while (or
1655 (not choice) 1862 (not choice)
1656 (not (integerp choice)) 1863 (not (integerp choice))
1657 (< choice 1) 1864 (< choice 1)
1658 (> choice len)) 1865 (> choice len))
1659 (setq choice (string-to-int 1866 (setq choice
1660 (read-from-minibuffer "Enter No. of your choice: ")))) 1867 (string-to-int
1868 (read-from-minibuffer "Enter No. of your choice: "))))
1869 )
1661 (set-buffer ali-buffer) 1870 (set-buffer ali-buffer)
1662 (goto-line (car (nth (1- choice) declist))) 1871 (goto-line (car (nth (1- choice) declist)))
1663 )))))) 1872 ))))))
@@ -1670,60 +1879,203 @@ opens a new window to show the declaration."
1670 1879
1671 (ada-get-all-references identlist) 1880 (ada-get-all-references identlist)
1672 (let ((ali-line (ada-references-of identlist)) 1881 (let ((ali-line (ada-references-of identlist))
1882 (locations nil)
1883 (start 0)
1673 file line col) 1884 file line col)
1885
1886 ;; Note: in some cases, an entity can have multiple references to the
1887 ;; bodies (this is for instance the case for a separate subprogram, that
1888 ;; has a reference both to the stub and to the real body).
1889 ;; In that case, we simply go to each one in turn.
1890
1891 ;; Get all the possible locations
1892 (string-match "^\\([0-9]+\\)[a-zA-Z+]\\([0-9]+\\)[ *]" ali-line)
1893 (set 'locations (list (list (match-string 1 ali-line) ;; line
1894 (match-string 2 ali-line) ;; column
1895 (ada-declare-file-of identlist))))
1896 (while (string-match "\\([0-9]+\\)[bc]\\([0-9]+\\)" ali-line start)
1897 (setq line (match-string 1 ali-line)
1898 col (match-string 2 ali-line)
1899 start (match-end 2))
1900
1901 ;; it there was a file number in the same line
1902 (if (string-match (concat "\\([0-9]+\\)|\\([^|bc]+\\)?"
1903 (match-string 0 ali-line))
1904 ali-line)
1905 (let ((file-number (match-string 1 ali-line)))
1906 (goto-char (point-min))
1907 (re-search-forward "^D \\([a-zA-Z0-9_.-]+\\)" nil t
1908 (string-to-number file-number))
1909 (set 'file (match-string 1))
1910 )
1911 ;; Else get the nearest file
1912 (set 'file (ada-declare-file-of identlist)))
1913
1914 (set 'locations (append locations (list (list line col file)))))
1915
1916 ;; Add the specs at the end again, so that from the last body we go to
1917 ;; the specs
1918 (set 'locations (append locations (list (car locations))))
1919
1920 ;; Find the new location we want to go to.
1921 ;; If we are on none of the locations listed, we simply go to the specs.
1922
1923 (setq line (caar locations)
1924 col (nth 1 (car locations))
1925 file (nth 2 (car locations)))
1674 1926
1675 ;; If we were on a declaration, go to the body 1927 (while locations
1676 (if (ada-on-declaration identlist) 1928 (if (and (string= (caar locations) (ada-line-of identlist))
1677 (if (string-match "\\([0-9]+\\)[bc]\\([0-9]+\\)" ali-line) 1929 (string= (nth 1 (car locations)) (ada-column-of identlist))
1678 (progn 1930 (string= (file-name-nondirectory (nth 2 (car locations)))
1679 (setq line (match-string 1 ali-line) 1931 (file-name-nondirectory (ada-file-of identlist))))
1680 col (match-string 2 ali-line)) 1932 (setq locations (cadr locations)
1681 ;; it there was a file number in the same line 1933 line (car locations)
1682 (if (string-match "\\([0-9]+\\)|\\([^|bc]+\\)?[bc]" ali-line) 1934 col (nth 1 locations)
1683 (let ((file-number (match-string 1 ali-line))) 1935 file (nth 2 locations)
1684 (goto-char (point-min)) 1936 locations nil)
1685 (re-search-forward "^D \\([a-zA-Z0-9_.-]+\\)" nil t 1937 (set 'locations (cdr locations))))
1686 (string-to-number file-number)) 1938
1687 (set 'file (match-string 1)) 1939 ;; Find the file in the source path
1688 ) 1940 (set 'file (ada-get-ada-file-name file (ada-file-of identlist)))
1689 ;; Else get the nearest file 1941
1690 (set 'file (ada-declare-file-of identlist)) 1942 ;; Kill the .ali buffer
1691 ) 1943 (kill-buffer (current-buffer))
1692 )
1693 (error "No body found"))
1694
1695 ;; Else we were not on the declaration, find the place for it
1696 (string-match "\\([0-9]+\\)[a-zA-Z+]\\([0-9]+\\)[ *]" ali-line)
1697 (setq line (match-string 1 ali-line)
1698 col (match-string 2 ali-line)
1699 file (ada-declare-file-of identlist))
1700 )
1701 1944
1702 ;; Now go to the buffer 1945 ;; Now go to the buffer
1703 (ada-xref-change-buffer 1946 (ada-xref-change-buffer file
1704 (ada-get-ada-file-name file (ada-file-of identlist)) 1947 (string-to-number line)
1705 (string-to-number line) 1948 (1- (string-to-number col))
1706 (1- (string-to-number col)) 1949 identlist
1707 identlist 1950 other-frame)
1708 other-frame)
1709 )) 1951 ))
1710 1952
1953(defun ada-find-in-src-path (identlist &optional other-frame)
1954 "More general function for cross-references.
1955This function should be used when the standard algorithm that parses the
1956.ali file has failed, either because that file was too old or even did not
1957exist.
1958This function attempts to find the possible declarations for the identifier
1959anywhere in the object path.
1960This command requires the external `egrep' program to be available.
1961
1962This works well when one is using an external librarie and wants
1963to find the declaration and documentation of the subprograms one is
1964is using."
1965
1966 (let (list
1967 (dirs (ada-xref-get-obj-dir-field))
1968 (regexp (concat "[ *]" (ada-name-of identlist)))
1969 line column
1970 choice
1971 file)
1972
1973 (save-excursion
1974
1975 ;; Do the grep in all the directories. We do multiple shell
1976 ;; commands instead of one in case there is no .ali file in one
1977 ;; of the directory and the shell stops because of that.
1978
1979 (set-buffer (get-buffer-create "*grep*"))
1980 (while dirs
1981 (insert (shell-command-to-string
1982 (concat "egrep -i -h '^X|" regexp "( |$)' "
1983 (file-name-as-directory (car dirs)) "*.ali")))
1984 (set 'dirs (cdr dirs)))
1985
1986 ;; Now parse the output
1987 (set 'case-fold-search t)
1988 (goto-char (point-min))
1989 (while (re-search-forward regexp nil t)
1990 (save-excursion
1991 (beginning-of-line)
1992 (if (not (= (char-after) ?X))
1993 (progn
1994 (looking-at "\\([0-9]+\\).\\([0-9]+\\)")
1995 (setq line (match-string 1)
1996 column (match-string 2))
1997 (re-search-backward "^X [0-9]+ \\(.*\\)$")
1998 (set 'file (list (match-string 1) line column))
1999
2000 ;; There could be duplicate choices, because of the structure
2001 ;; of the .ali files
2002 (unless (member file list)
2003 (set 'list (append list (list file))))))))
2004
2005 ;; Current buffer is still "*grep*"
2006 (kill-buffer "*grep*")
2007 )
2008
2009 ;; Now display the list of possible matches
2010 (cond
2011
2012 ;; No choice found => Error
2013 ((null list)
2014 (error "No cross-reference found, please recompile your file"))
2015
2016 ;; Only one choice => Do the cross-reference
2017 ((= (length list) 1)
2018 (set 'file (ada-find-src-file-in-dir (caar list)))
2019 (if file
2020 (ada-xref-change-buffer file
2021 (string-to-number (nth 1 (car list)))
2022 (string-to-number (nth 2 (car list)))
2023 identlist
2024 other-frame)
2025 (error (concat (caar list) " not found in src_dir")))
2026 (message "This is only a (good) guess at the cross-reference.")
2027 )
2028
2029 ;; Else, ask the user
2030 (t
2031 (save-window-excursion
2032 (with-output-to-temp-buffer "*choice list*"
2033
2034 (princ "Identifier is overloaded and Xref information is not up to date.\n")
2035 (princ "Possible declarations are:\n\n")
2036 (princ " no. in file at line col\n")
2037 (princ " --- --------------------- ---- ----\n")
2038 (let ((counter 0))
2039 (while (< counter (length list))
2040 (princ (format " %2d) %-21s %4s %4s\n"
2041 (1+ counter)
2042 (nth 0 (nth counter list))
2043 (nth 1 (nth counter list))
2044 (nth 2 (nth counter list))
2045 ))
2046 (setq counter (1+ counter))
2047 )))
2048 (setq choice nil)
2049 (while (or (not choice)
2050 (not (integerp choice))
2051 (< choice 1)
2052 (> choice (length list)))
2053 (setq choice
2054 (string-to-int
2055 (read-from-minibuffer "Enter No. of your choice: "))))
2056 )
2057 (set 'choice (1- choice))
2058 (kill-buffer "*choice list*")
2059
2060 (set 'file (ada-find-src-file-in-dir (car (nth choice list))))
2061 (if file
2062 (ada-xref-change-buffer file
2063 (string-to-number (nth 1 (nth choice list)))
2064 (string-to-number (nth 2 (nth choice list)))
2065 identlist
2066 other-frame)
2067 (error (concat (car (nth choice list)) " not found in src_dir")))
2068 (message "This is only a (good) guess at the cross-reference.")
2069 ))))
2070
1711(defun ada-xref-change-buffer 2071(defun ada-xref-change-buffer
1712 (file line column identlist &optional other-frame) 2072 (file line column identlist &optional other-frame)
1713 "Select and display FILE, at LINE and COLUMN. The new file is 2073 "Select and display FILE, at LINE and COLUMN.
1714associated with the same project file as the one for IDENTLIST.
1715If we do not end on the same identifier as IDENTLIST, find the closest 2074If we do not end on the same identifier as IDENTLIST, find the closest
1716match. Kills the .ali buffer at the end. 2075match. Kills the .ali buffer at the end.
1717If OTHER-FRAME is non-nil, creates a new frame to show the file." 2076If OTHER-FRAME is non-nil, creates a new frame to show the file."
1718 2077
1719 (let (prj-file 2078 (let (declaration-buffer)
1720 declaration-buffer
1721 (ali-buffer (current-buffer)))
1722
1723 ;; get the current project file for the source ada file
1724 (save-excursion
1725 (set-buffer (get-file-buffer (ada-file-of identlist)))
1726 (set 'prj-file ada-prj-prj-file))
1727 2079
1728 ;; Select and display the destination buffer 2080 ;; Select and display the destination buffer
1729 (if ada-xref-other-buffer 2081 (if ada-xref-other-buffer
@@ -1736,10 +2088,6 @@ If OTHER-FRAME is non-nil, creates a new frame to show the file."
1736 (find-file file) 2088 (find-file file)
1737 ) 2089 )
1738 2090
1739 ;; If the new buffer is not already associated with a project file, do it
1740 (unless (my-local-variable-if-set-p 'ada-prj-prj-file (current-buffer))
1741 (set (make-local-variable 'ada-prj-prj-file) prj-file))
1742
1743 ;; move the cursor to the correct position 2091 ;; move the cursor to the correct position
1744 (push-mark) 2092 (push-mark)
1745 (goto-line line) 2093 (goto-line line)
@@ -1750,8 +2098,7 @@ If OTHER-FRAME is non-nil, creates a new frame to show the file."
1750 ;; this is probably the right one. 2098 ;; this is probably the right one.
1751 (unless (looking-at (ada-name-of identlist)) 2099 (unless (looking-at (ada-name-of identlist))
1752 (ada-xref-search-nearest (ada-name-of identlist))) 2100 (ada-xref-search-nearest (ada-name-of identlist)))
1753 2101 ))
1754 (kill-buffer ali-buffer)))
1755 2102
1756 2103
1757(defun ada-xref-search-nearest (name) 2104(defun ada-xref-search-nearest (name)
@@ -1878,13 +2225,28 @@ This function typically is to be hooked into `ff-file-created-hooks'."
1878 2225
1879 (save-some-buffers nil nil) 2226 (save-some-buffers nil nil)
1880 2227
1881 (ada-require-project-file) 2228 ;; If the current buffer is the body (as is the case when calling this
2229 ;; function from ff-file-created-hooks), then kill this temporary buffer
2230 (unless (interactive-p)
2231 (progn
2232 (set-buffer-modified-p nil)
2233 (kill-buffer (current-buffer))))
2234
1882 2235
1883 (delete-region (point-min) (point-max)) 2236 ;; Make sure the current buffer is the spec (this might not be the case
2237 ;; if for instance the user was asked for a project file)
2238
2239 (unless (buffer-file-name (car (buffer-list)))
2240 (set-buffer (cadr (buffer-list))))
2241
2242 ;; Make sure we have a project file (for parameters to gnatstub). Note that
2243 ;; this might have already been done if we have been called from the hook,
2244 ;; but this is not an expensive call)
2245 (ada-require-project-file)
1884 2246
1885 ;; Call the external process gnatstub 2247 ;; Call the external process gnatstub
1886 (let* ((gnatstub-opts (ada-treat-cmd-string ada-gnatstub-opts)) 2248 (let* ((gnatstub-opts (ada-treat-cmd-string ada-gnatstub-opts))
1887 (filename (buffer-file-name (car (cdr (buffer-list))))) 2249 (filename (buffer-file-name (car (buffer-list))))
1888 (output (concat (file-name-sans-extension filename) ".adb")) 2250 (output (concat (file-name-sans-extension filename) ".adb"))
1889 (gnatstub-cmd (concat "gnatstub " gnatstub-opts " " filename)) 2251 (gnatstub-cmd (concat "gnatstub " gnatstub-opts " " filename))
1890 (buffer (get-buffer-create "*gnatstub*"))) 2252 (buffer (get-buffer-create "*gnatstub*")))
@@ -1911,10 +2273,6 @@ This function typically is to be hooked into `ff-file-created-hooks'."
1911 2273
1912 ;; Else clean up the output 2274 ;; Else clean up the output
1913 2275
1914 ;; Kill the temporary buffer created by find-file
1915 (set-buffer-modified-p nil)
1916 (kill-buffer (current-buffer))
1917
1918 (if (file-exists-p output) 2276 (if (file-exists-p output)
1919 (progn 2277 (progn
1920 (find-file output) 2278 (find-file output)
@@ -1925,7 +2283,6 @@ This function typically is to be hooked into `ff-file-created-hooks'."
1925 ) 2283 )
1926 ))) 2284 )))
1927 2285
1928
1929(defun ada-xref-initialize () 2286(defun ada-xref-initialize ()
1930 "Function called by `ada-mode-hook' to initialize the ada-xref.el package. 2287 "Function called by `ada-mode-hook' to initialize the ada-xref.el package.
1931For instance, it creates the gnat-specific menus, sets some hooks for 2288For instance, it creates the gnat-specific menus, sets some hooks for
@@ -1946,6 +2303,19 @@ find-file...."
1946 2303
1947;; ----- Add to ada-mode-hook --------------------------------------------- 2304;; ----- Add to ada-mode-hook ---------------------------------------------
1948 2305
2306;; Use gvd or ddd as the default debugger if it was found
2307;; On windows, do not use the --tty switch for GVD, since this is
2308;; not supported. Actually, we do not use this on Unix either, since otherwise
2309;; there is no console window left in GVD, and people have to use the
2310;; Emacs one.
2311;; This must be done before initializing the Ada menu.
2312(if (ada-find-file-in-dir "gvd" exec-path)
2313 (set 'ada-prj-default-debugger "gvd ")
2314 (if (ada-find-file-in-dir "gvd.exe" exec-path)
2315 (set 'ada-prj-default-debugger "gvd ")
2316 (if (ada-find-file-in-dir "ddd" exec-path)
2317 (set 'ada-prj-default-debugger "ddd --tty -fullname -toolbar"))))
2318
1949;; Set the keymap once and for all, so that the keys set by the user in his 2319;; Set the keymap once and for all, so that the keys set by the user in his
1950;; config file are not overwritten every time we open a new file. 2320;; config file are not overwritten every time we open a new file.
1951(ada-add-ada-menu) 2321(ada-add-ada-menu)
@@ -1953,12 +2323,8 @@ find-file...."
1953 2323
1954(add-hook 'ada-mode-hook 'ada-xref-initialize) 2324(add-hook 'ada-mode-hook 'ada-xref-initialize)
1955 2325
1956;; Use ddd as the default debugger if it was found
1957(if (ada-find-file-in-dir "ddd" exec-path)
1958 (set 'ada-prj-default-debugger "ddd --tty -fullname -toolbar"))
1959
1960;; Initializes the cross references to the runtime library 2326;; Initializes the cross references to the runtime library
1961(ada-initialize-runtime-library) 2327(ada-initialize-runtime-library "")
1962 2328
1963;; Add these standard directories to the search path 2329;; Add these standard directories to the search path
1964(set 'ada-search-directories 2330(set 'ada-search-directories