1 |
;;; ada-xref.el --- for lookup and completion in Ada mode |
;;; ada-xref.el --- for lookup and completion in Ada mode |
2 |
|
|
3 |
;; Copyright (C) 1994, 95, 96, 97, 98, 99, 2000 Free Software Foundation, Inc. |
;; Copyright (C) 1994, 95, 96, 97, 98, 99, 2000, 2001 |
4 |
|
;; Free Software Foundation, Inc. |
5 |
|
|
6 |
;; Author: Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de> |
;; Author: Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de> |
7 |
;; Rolf Ebert <ebert@inf.enst.fr> |
;; Rolf Ebert <ebert@inf.enst.fr> |
32 |
;;; cross reference capabilities of the GNAT Ada compiler |
;;; cross reference capabilities of the GNAT Ada compiler |
33 |
;;; for lookup and completion in Ada mode. |
;;; for lookup and completion in Ada mode. |
34 |
;;; |
;;; |
|
;;; The functions provided are the following ones : |
|
|
;;; - `ada-complete-identifier': completes the current identifier as much as |
|
|
;;; possible, depending of the known identifier in the unit |
|
|
;;; - `ada-point-and-xref': moves the mouse pointer and shows the declaration |
|
|
;;; of the selected identifier (either in the same buffer or in another |
|
|
;;; buffer |
|
|
;;; - `ada-goto-declaration': shows the declaration of the selected |
|
|
;;; identifier (the one under the cursor), either in the same buffer or in |
|
|
;;; another buffer |
|
|
;;; - `ada-goto-declaration-other-frame': same as previous, but opens a new |
|
|
;; frame to show the declaration |
|
|
;;; - `ada-compile-application': recompile your whole application, provided |
|
|
;;; that a project file exists in your directory |
|
|
;;; - `ada-run-application': run your application directly from Emacs |
|
|
;;; - `ada-reread-prj-file': force Emacs to read your project file again. |
|
|
;;; Otherwise, this file is only read the first time Emacs needs some |
|
|
;;; informations, which are then kept in memory |
|
|
;;; - `ada-change-prj': change the prj file associated with a buffer |
|
|
;;; - `ada-change-default-prj': change the default project file used for |
|
|
;;; every new buffer |
|
|
;;; |
|
35 |
;;; If a file *.`adp' exists in the ada-file directory, then it is |
;;; If a file *.`adp' exists in the ada-file directory, then it is |
36 |
;;; read for configuration informations. It is read only the first |
;;; read for configuration informations. It is read only the first |
37 |
;;; time a cross-reference is asked for, and is not read later. |
;;; time a cross-reference is asked for, and is not read later. |
66 |
Set to 0, if you don't use crunched filenames. This should be a string." |
Set to 0, if you don't use crunched filenames. This should be a string." |
67 |
:type 'string :group 'ada) |
:type 'string :group 'ada) |
68 |
|
|
69 |
(defcustom ada-prj-default-comp-opt "-gnatq" |
(defcustom ada-prj-default-comp-opt "-gnatq -gnatQ" |
70 |
"Default compilation options." |
"Default compilation options." |
71 |
:type 'string :group 'ada) |
:type 'string :group 'ada) |
72 |
|
|
82 |
"Default options for gnatmake." |
"Default options for gnatmake." |
83 |
:type 'string :group 'ada) |
:type 'string :group 'ada) |
84 |
|
|
85 |
|
(defcustom ada-prj-gnatfind-switches "-rf" |
86 |
|
"Default switches to use for gnatfind. |
87 |
|
You should modify this variable, for instance to add -a, if you are working |
88 |
|
in an environment where most ALI files are write-protected. |
89 |
|
The command gnatfind is used every time you choose the menu |
90 |
|
\"Show all references\"." |
91 |
|
:type 'string :group 'ada) |
92 |
|
|
93 |
(defcustom ada-prj-default-comp-cmd |
(defcustom ada-prj-default-comp-cmd |
94 |
"${cross_prefix}gcc -c ${comp_opt}" |
"${cross_prefix}gcc -x ada -c ${comp_opt} ${full_current}" |
95 |
"*Default command to be used to compile a single file. |
"*Default command to be used to compile a single file. |
96 |
Emacs will add the filename at the end of this command. This is the same |
Emacs will add the filename at the end of this command. This is the same |
97 |
syntax as in the project file." |
syntax as in the project file." |
125 |
Otherwise, ask the user for the name of the project file to use." |
Otherwise, ask the user for the name of the project file to use." |
126 |
:type 'boolean :group 'ada) |
:type 'boolean :group 'ada) |
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. |
133 |
|
If GVD is not the debugger used, nothing happens.") |
134 |
|
|
135 |
;; ------- Nothing to be modified by the user below this |
;; ------- Nothing to be modified by the user below this |
136 |
(defvar ada-last-prj-file "" |
(defvar ada-last-prj-file "" |
137 |
"Name of the last project file entered by the user.") |
"Name of the last project file entered by the user.") |
139 |
(defvar ada-check-switch "-gnats" |
(defvar ada-check-switch "-gnats" |
140 |
"Switch added to the command line to check the current file.") |
"Switch added to the command line to check the current file.") |
141 |
|
|
142 |
(defvar ada-project-file-extension ".adp" |
(defconst ada-project-file-extension ".adp" |
143 |
"The extension used for project files.") |
"The extension used for project files.") |
144 |
|
|
|
(defconst is-windows (memq system-type (quote (windows-nt))) |
|
|
"True if we are running on windows NT or windows 95.") |
|
|
|
|
145 |
(defvar ada-xref-runtime-library-specs-path '() |
(defvar ada-xref-runtime-library-specs-path '() |
146 |
"Directories where the specs for the standard library is found. |
"Directories where the specs for the standard library is found. |
147 |
This is used for cross-references.") |
This is used for cross-references.") |
154 |
"List of positions selected by the cross-references functions. |
"List of positions selected by the cross-references functions. |
155 |
Used to go back to these positions.") |
Used to go back to these positions.") |
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 |
162 |
|
using cmdproxy.exe as the shell, we need to use /d or the drive is never |
163 |
|
changed.") |
164 |
|
|
165 |
|
(defvar ada-command-separator (if is-windows " && " "\n") |
166 |
|
"Separator to use when sending multiple commands to `compile' or |
167 |
|
`start-process'. |
168 |
|
cmdproxy.exe doesn't recognize multiple-line commands, so we have to use |
169 |
|
\"&&\" for now.") |
170 |
|
|
171 |
(defconst ada-xref-pos-ring-max 16 |
(defconst ada-xref-pos-ring-max 16 |
172 |
"Number of positions kept in the list ada-xref-pos-ring.") |
"Number of positions kept in the list ada-xref-pos-ring.") |
173 |
|
|
175 |
"\\+\\|-\\|/\\|\\*\\*\\|\\*\\|=\\|&\\|abs\\|mod\\|rem\\|and\\|not\\|or\\|xor\\|<=\\|<\\|>=\\|>" |
"\\+\\|-\\|/\\|\\*\\*\\|\\*\\|=\\|&\\|abs\\|mod\\|rem\\|and\\|not\\|or\\|xor\\|<=\\|<\\|>=\\|>" |
176 |
"Regexp to match for operators.") |
"Regexp to match for operators.") |
177 |
|
|
|
(defvar ada-xref-default-prj-file nil |
|
|
"Name of the default prj file, per directory. |
|
|
Every directory is potentially associated with a default project file. |
|
|
If it is nil, then the first prj file loaded will be the default for this |
|
|
Emacs session.") |
|
|
|
|
|
|
|
178 |
(defvar ada-xref-project-files '() |
(defvar ada-xref-project-files '() |
179 |
"Associative list of project files. |
"Associative list of project files. |
180 |
It has the following format: |
It has the following format: |
181 |
\((project_name . value) (project_name . value) ...) |
\((project_name . value) (project_name . value) ...) |
182 |
As always, the values of the project file are defined through properties.") |
As always, the values of the project file are defined through properties.") |
183 |
|
|
184 |
(defvar ada-prj-prj-file nil |
(defun ada-quote-cmd (cmd) |
185 |
"Buffer local variable that specifies the name of the project file. |
"Duplicates all \\ characters in CMD so that it can be passed to `compile'" |
186 |
Getting the project is done by looking up the key in ada-pxref-project-file.") |
(mapconcat 'identity (split-string cmd "\\\\") "\\\\")) |
187 |
|
|
188 |
(defun my-local-variable-if-set-p (variable &optional buffer) |
(defun ada-initialize-runtime-library (cross-prefix) |
189 |
"Returns t if VARIABLE is local in BUFFER and is non-nil." |
"Initializes the variables for the runtime library location. |
190 |
(and (local-variable-p variable buffer) |
CROSS-PREFIX is the prefix to use for the gnatls command" |
|
(save-excursion |
|
|
(set-buffer buffer) |
|
|
(symbol-value variable)))) |
|
|
|
|
|
(defun ada-initialize-runtime-library () |
|
|
"Initializes the variables for the runtime library location." |
|
191 |
(save-excursion |
(save-excursion |
192 |
(set 'ada-xref-runtime-library-specs-path '()) |
(setq ada-xref-runtime-library-specs-path '() |
193 |
(set 'ada-xref-runtime-library-ali-path '()) |
ada-xref-runtime-library-ali-path '()) |
194 |
(set-buffer (get-buffer-create "*gnatls*")) |
(set-buffer (get-buffer-create "*gnatls*")) |
195 |
(widen) |
(widen) |
196 |
(erase-buffer) |
(erase-buffer) |
199 |
;; Even if we get an error, delete the *gnatls* buffer |
;; Even if we get an error, delete the *gnatls* buffer |
200 |
(unwind-protect |
(unwind-protect |
201 |
(progn |
(progn |
202 |
(call-process "gnatls" nil t nil "-v") |
(call-process (concat cross-prefix "gnatls") |
203 |
|
nil t nil "-v") |
204 |
(goto-char (point-min)) |
(goto-char (point-min)) |
205 |
|
|
206 |
;; Source path |
;; Source path |
242 |
"Replace meta-sequences like ${...} in CMD-STRING with the appropriate value. |
"Replace meta-sequences like ${...} in CMD-STRING with the appropriate value. |
243 |
The project file must have been loaded first. |
The project file must have been loaded first. |
244 |
As a special case, ${current} is replaced with the name of the currently |
As a special case, ${current} is replaced with the name of the currently |
245 |
edited file, minus extension but with directory." |
edited file, minus extension but with directory, and ${full_current} is |
246 |
|
replaced by the name including the extension." |
247 |
|
|
248 |
(while (string-match "\\(-[^-\$IO]*[IO]\\)?\${\\([^}]+\\)}" cmd-string) |
(while (string-match "\\(-[^-\$IO]*[IO]\\)?\${\\([^}]+\\)}" cmd-string) |
249 |
(let (value) |
(let (value |
250 |
(if (string= (match-string 2 cmd-string) "current") |
(name (match-string 2 cmd-string))) |
251 |
(set 'value (file-name-sans-extension (buffer-file-name))) |
(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 |
(save-match-data |
258 |
(set 'value (ada-xref-get-project-field |
(setq value (ada-xref-get-project-field (intern name)))))) |
259 |
(intern (match-string 2 cmd-string)))))) |
|
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 |
|
|
265 |
(cond |
(cond |
266 |
((null value) |
((null value) |
267 |
(set 'cmd-string (replace-match "" t t cmd-string))) |
(setq cmd-string (replace-match "" t t cmd-string))) |
268 |
((stringp value) |
((stringp value) |
269 |
(set 'cmd-string (replace-match value t t cmd-string))) |
(setq cmd-string (replace-match value t t cmd-string))) |
270 |
((listp value) |
((listp value) |
271 |
(let ((prefix (match-string 1 cmd-string))) |
(let ((prefix (match-string 1 cmd-string))) |
272 |
(set 'cmd-string (replace-match |
(setq cmd-string (replace-match |
273 |
(mapconcat (lambda(x) (concat prefix x)) value " ") |
(mapconcat (lambda(x) (concat prefix x)) value " ") |
274 |
t t cmd-string))))) |
t t cmd-string))))) |
275 |
)) |
)) |
287 |
;; Try hard to find a default value for filename, so that the user |
;; Try hard to find a default value for filename, so that the user |
288 |
;; can edit his project file even if the current buffer is not an |
;; can edit his project file even if the current buffer is not an |
289 |
;; Ada file or not even associated with a file |
;; Ada file or not even associated with a file |
290 |
(list 'filename (cond |
(list 'filename (expand-file-name |
291 |
(file |
(cond |
292 |
(ada-prj-get-prj-dir file)) |
(file |
293 |
(ada-prj-prj-file |
(ada-prj-get-prj-dir file)) |
294 |
ada-prj-prj-file) |
(ada-prj-default-project-file |
295 |
(ada-xref-default-prj-file |
ada-prj-default-project-file) |
296 |
ada-xref-default-prj-file) |
(t |
297 |
(t |
(message (concat "Not editing an Ada file," |
298 |
(error (concat "Not editing an Ada file," |
"and no default project " |
299 |
"and no default project " |
"file specified!")) |
300 |
"file specified!")))) |
""))) |
301 |
'build_dir (file-name-as-directory (expand-file-name ".")) |
'build_dir (file-name-as-directory (expand-file-name ".")) |
302 |
'src_dir (list ".") |
'src_dir (list ".") |
303 |
'obj_dir (list ".") |
'obj_dir (list ".") |
308 |
'bind_opt ada-prj-default-bind-opt |
'bind_opt ada-prj-default-bind-opt |
309 |
'link_opt ada-prj-default-link-opt |
'link_opt ada-prj-default-link-opt |
310 |
'gnatmake_opt ada-prj-default-gnatmake-opt |
'gnatmake_opt ada-prj-default-gnatmake-opt |
311 |
|
'gnatfind_opt ada-prj-gnatfind-switches |
312 |
'main (if file |
'main (if file |
313 |
(file-name-sans-extension file) |
(file-name-nondirectory |
314 |
|
(file-name-sans-extension file)) |
315 |
"") |
"") |
316 |
'main_unit (if file |
'main_unit (if file |
317 |
(file-name-nondirectory |
(file-name-nondirectory |
319 |
"") |
"") |
320 |
'cross_prefix "" |
'cross_prefix "" |
321 |
'remote_machine "" |
'remote_machine "" |
322 |
'comp_cmd (concat "cd ${build_dir} && " |
'comp_cmd (list (concat ada-cd-command " ${build_dir}") |
323 |
ada-prj-default-comp-cmd) |
ada-prj-default-comp-cmd) |
324 |
'check_cmd (concat ada-prj-default-comp-cmd " " |
'check_cmd (list (concat ada-prj-default-comp-cmd " " |
325 |
ada-check-switch) |
ada-check-switch)) |
326 |
'make_cmd (concat "cd ${build_dir} && " |
'make_cmd (list (concat ada-cd-command " ${build_dir}") |
327 |
ada-prj-default-make-cmd) |
ada-prj-default-make-cmd) |
328 |
'run_cmd (concat "cd ${build_dir} && ${main}" |
'run_cmd (list (concat ada-cd-command " ${build_dir}") |
329 |
(if is-windows ".exe")) |
(concat "${main}" |
330 |
|
(if is-windows ".exe"))) |
331 |
|
'debug_pre_cmd (list (concat ada-cd-command |
332 |
|
" ${build_dir}")) |
333 |
'debug_cmd (concat ada-prj-default-debugger |
'debug_cmd (concat ada-prj-default-debugger |
334 |
(if is-windows " ${main}.exe" |
(if is-windows " ${main}.exe" |
335 |
" ${main}")))) |
" ${main}")) |
336 |
|
'debug_post_cmd (list nil))) |
337 |
) |
) |
338 |
(set symbol plist))) |
(set symbol plist))) |
339 |
|
|
340 |
(defun ada-xref-get-project-field (field) |
(defun ada-xref-get-project-field (field) |
341 |
"Extract the value of FIELD from the project file of the current buffer. |
"Extract the value of FIELD from the current project file. |
342 |
The project file must have been loaded first. |
The project file must have been loaded first. |
343 |
A default value is returned if the file was not found." |
A default value is returned if the file was not found. |
344 |
|
|
345 |
|
Note 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 |
347 |
|
addition return the default paths." |
348 |
|
|
349 |
(let ((file-name ada-prj-prj-file) |
(let ((file-name ada-prj-default-project-file) |
350 |
file value) |
file value) |
351 |
|
|
352 |
;; If a default project file was set, use it if no other project |
;; Get the project file (either the current one, or a default one) |
353 |
;; file was specified for the buffer |
(setq file (or (assoc file-name ada-xref-project-files) |
354 |
(if (and (not file-name) |
(assoc nil ada-xref-project-files))) |
|
ada-prj-default-project-file |
|
|
(not (string= ada-prj-default-project-file ""))) |
|
|
(set 'file-name ada-prj-default-project-file)) |
|
|
|
|
|
(set 'file (assoc file-name ada-xref-project-files)) |
|
355 |
|
|
356 |
;; If the file was not found, use the default values |
;; If the file was not found, use the default values |
357 |
(if file |
(if file |
361 |
;; Create a default nil file that contains the default values |
;; Create a default nil file that contains the default values |
362 |
(ada-xref-set-default-prj-values 'value (current-buffer)) |
(ada-xref-set-default-prj-values 'value (current-buffer)) |
363 |
(add-to-list 'ada-xref-project-files (cons nil value)) |
(add-to-list 'ada-xref-project-files (cons nil value)) |
364 |
|
(ada-xref-update-project-menu) |
365 |
(set 'value (plist-get value field)) |
(set 'value (plist-get value field)) |
366 |
) |
) |
367 |
(if (stringp value) |
|
368 |
(ada-treat-cmd-string value) |
;; Substitute the ${...} constructs in all the strings, including |
369 |
value)) |
;; inside lists |
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. |
385 |
|
All 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. |
400 |
|
All 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. |
472 |
|
Completion is attempted in all the directories in the source path, as |
473 |
|
defined 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. |
493 |
|
Completion 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 |
|
|
501 |
|
|
502 |
;; ----- Keybindings ------------------------------------------------------ |
;; ----- Keybindings ------------------------------------------------------ |
503 |
|
|
517 |
(define-key ada-mode-map "\C-c\C-s" 'ada-xref-goto-previous-reference) |
(define-key ada-mode-map "\C-c\C-s" 'ada-xref-goto-previous-reference) |
518 |
(define-key ada-mode-map "\C-c\C-x" 'ada-reread-prj-file) |
(define-key ada-mode-map "\C-c\C-x" 'ada-reread-prj-file) |
519 |
(define-key ada-mode-map "\C-c\C-c" 'ada-compile-application) |
(define-key ada-mode-map "\C-c\C-c" 'ada-compile-application) |
|
(define-key ada-mode-map "\C-cb" 'ada-buffer-list) |
|
520 |
(define-key ada-mode-map "\C-cc" 'ada-change-prj) |
(define-key ada-mode-map "\C-cc" 'ada-change-prj) |
521 |
(define-key ada-mode-map "\C-cd" 'ada-change-default-prj) |
(define-key ada-mode-map "\C-cd" 'ada-set-default-project-file) |
522 |
(define-key ada-mode-map "\C-cg" 'ada-gdb-application) |
(define-key ada-mode-map "\C-cg" 'ada-gdb-application) |
523 |
(define-key ada-mode-map "\C-cr" 'ada-run-application) |
(define-key ada-mode-map "\C-cr" 'ada-run-application) |
524 |
(define-key ada-mode-map "\C-c\C-o" 'ada-goto-parent) |
(define-key ada-mode-map "\C-c\C-o" 'ada-goto-parent) |
525 |
(define-key ada-mode-map "\C-c\C-r" 'ada-find-references) |
(define-key ada-mode-map "\C-c\C-r" 'ada-find-references) |
526 |
(define-key ada-mode-map "\C-c\C-v" 'ada-check-current) |
(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) |
528 |
) |
) |
529 |
|
|
530 |
;; ----- Menus -------------------------------------------------------------- |
;; ----- Menus -------------------------------------------------------------- |
553 |
menu-list ["Debug" ada-gdb-application t] "Goto") |
menu-list ["Debug" ada-gdb-application t] "Goto") |
554 |
(funcall (symbol-function 'add-menu-button) |
(funcall (symbol-function 'add-menu-button) |
555 |
menu-list ["--" nil t] "Goto") |
menu-list ["--" nil t] "Goto") |
|
(funcall (symbol-function 'add-submenu) |
|
|
menu-list '("Project" |
|
|
["Associate" ada-change-prj t] |
|
|
["Set Default..." ada-set-default-project-file t] |
|
|
["List" ada-buffer-list t]) |
|
|
"Goto") |
|
556 |
(funcall (symbol-function 'add-menu-button) |
(funcall (symbol-function 'add-menu-button) |
557 |
goto-menu ["Goto Parent Unit" ada-goto-parent t] |
goto-menu ["Goto Parent Unit" ada-goto-parent t] |
558 |
"Next compilation error") |
"Next compilation error") |
610 |
(setq ada-xref-confirm-compile |
(setq ada-xref-confirm-compile |
611 |
(not ada-xref-confirm-compile)) |
(not ada-xref-confirm-compile)) |
612 |
:style toggle :selected ada-xref-confirm-compile]) |
: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])) |
620 |
) |
) |
621 |
|
|
622 |
;; for Emacs |
;; for Emacs |
636 |
(define-key-after menu [Debug] '("Debug" . ada-gdb-application) 'Run) |
(define-key-after menu [Debug] '("Debug" . ada-gdb-application) 'Run) |
637 |
(define-key-after menu [rem] '("--" . nil) 'Debug) |
(define-key-after menu [rem] '("--" . nil) 'Debug) |
638 |
(define-key-after menu [Project] |
(define-key-after menu [Project] |
639 |
(cons "Project" |
(cons "Project" (make-sparse-keymap)) 'rem) |
|
(funcall (symbol-function 'easy-menu-create-menu) |
|
|
"Project" |
|
|
'(["Associate..." ada-change-prj t |
|
|
:included (string= mode-name "Ada")] |
|
|
["Set Default..." ada-set-default-project-file t] |
|
|
["List" ada-buffer-list t]))) |
|
|
'rem) |
|
640 |
|
|
641 |
(define-key help-menu [Gnat_ug] |
(define-key help-menu [Gnat_ug] |
642 |
'("Gnat User Guide" . (lambda() (interactive) (info "gnat_ug")))) |
'("Gnat User Guide" . (lambda() (interactive) (info "gnat_ug")))) |
646 |
'("Gcc Documentation" . (lambda() (interactive) (info "gcc")))) |
'("Gcc Documentation" . (lambda() (interactive) (info "gcc")))) |
647 |
(define-key help-menu [gdb] |
(define-key help-menu [gdb] |
648 |
'("Gdb Documentation" . (lambda() (interactive) (info "gdb")))) |
'("Gdb Documentation" . (lambda() (interactive) (info "gdb")))) |
649 |
(define-key help-menu [gdb] |
(define-key help-menu [arm95] |
650 |
'("Ada95 Reference Manual" . (lambda() (interactive) (info "arm95")))) |
'("Ada95 Reference Manual" . (lambda() (interactive) (info "arm95")))) |
651 |
|
|
652 |
(define-key goto-menu [rem] '("----" . nil)) |
(define-key goto-menu [rem] '("----" . nil)) |
683 |
(lambda()(interactive) |
(lambda()(interactive) |
684 |
(setq ada-xref-other-buffer (not ada-xref-other-buffer))) |
(setq ada-xref-other-buffer (not ada-xref-other-buffer))) |
685 |
:button (:toggle . ada-xref-other-buffer)) t) |
: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)) |
698 |
) |
) |
699 |
) |
) |
700 |
|
(ada-xref-update-project-menu) |
701 |
) |
) |
702 |
|
|
703 |
;; ----- Utilities ------------------------------------------------- |
;; ----- Utilities ------------------------------------------------- |
704 |
|
|
705 |
(defun ada-require-project-file () |
(defun ada-require-project-file () |
706 |
"If no project file is assigned to this buffer, load one." |
"If no project file is currently active, load a default one." |
707 |
(if (not (my-local-variable-if-set-p 'ada-prj-prj-file (current-buffer))) |
(if (or (not ada-prj-default-project-file) |
708 |
|
(not ada-xref-project-files) |
709 |
|
(string= ada-prj-default-project-file "")) |
710 |
(ada-reread-prj-file))) |
(ada-reread-prj-file))) |
711 |
|
|
712 |
(defun ada-xref-push-pos (filename position) |
(defun ada-xref-push-pos (filename position) |
732 |
(defun ada-set-default-project-file (name) |
(defun ada-set-default-project-file (name) |
733 |
"Set the file whose name is NAME as the default project file." |
"Set the file whose name is NAME as the default project file." |
734 |
(interactive "fProject file:") |
(interactive "fProject file:") |
|
|
|
|
;; All the directories should use this file as the default from now on, |
|
|
;; even if they were already associated with a file. |
|
|
(set 'ada-xref-default-prj-file nil) |
|
|
|
|
735 |
(set 'ada-prj-default-project-file name) |
(set 'ada-prj-default-project-file name) |
|
|
|
|
;; Make sure that all the buffers see the new project file, even if they |
|
|
;; are not Ada buffers (for instance if we want to display the current |
|
|
;; project file in the frame title). |
|
|
(setq-default ada-prj-prj-file name) |
|
|
|
|
736 |
(ada-reread-prj-file name) |
(ada-reread-prj-file name) |
737 |
) |
) |
738 |
|
|
747 |
|
|
748 |
(let (selected) |
(let (selected) |
749 |
|
|
750 |
;; If we don't have an ada buffer, or the current buffer is not |
;; Use the active project file if there is one. |
751 |
;; a real file (for instance an emerge buffer) |
;; 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) |
753 |
|
|
754 |
(if (or (not (string= mode-name "Ada")) |
(if (or (not (string= mode-name "Ada")) |
755 |
(not (buffer-file-name))) |
(not (buffer-file-name)) |
756 |
|
(and ada-prj-default-project-file |
757 |
;; 1st case: not an Ada buffer |
(not (string= ada-prj-default-project-file "")))) |
758 |
(if (and ada-prj-default-project-file |
(set 'selected ada-prj-default-project-file) |
759 |
(not (string= ada-prj-default-project-file ""))) |
|
760 |
(set 'selected ada-prj-default-project-file)) |
;; other cases: use a more complex algorithm |
761 |
|
|
762 |
;; 2nd case: If the buffer already has a project file, use it |
(let* ((current-file (buffer-file-name)) |
763 |
(if (my-local-variable-if-set-p 'ada-prj-prj-file (current-buffer)) |
(first-choice (concat |
764 |
(set 'selected ada-prj-prj-file) |
(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)) |
776 |
|
|
777 |
(let* ((current-file (buffer-file-name)) |
(cond |
778 |
(first-choice (concat |
|
779 |
(file-name-sans-extension current-file) |
;; Else if there is a project file with the same name as the Ada |
780 |
ada-project-file-extension)) |
;; file, but not the same extension. |
781 |
(dir (file-name-directory current-file)) |
((file-exists-p first-choice) |
782 |
|
(set 'selected first-choice)) |
783 |
;; on Emacs 20.2, directory-files does not work if |
|
784 |
;; parse-sexp-lookup-properties is set |
;; Else if only one project file was found in the current directory |
785 |
(parse-sexp-lookup-properties nil) |
((= (length prj-files) 1) |
786 |
(prj-files (directory-files |
(set 'selected (car prj-files))) |
787 |
dir t |
|
788 |
(concat ".*" (regexp-quote ada-project-file-extension) "$"))) |
;; Else if there are multiple files, ask the user |
789 |
(choice nil) |
((and (> (length prj-files) 1) (not no-user-question)) |
790 |
(default (assoc dir ada-xref-default-prj-file))) |
(save-window-excursion |
791 |
|
(with-output-to-temp-buffer "*choice list*" |
792 |
(cond |
(princ "There are more than one possible project file.\n") |
793 |
|
(princ "Which one should we use ?\n\n") |
794 |
;; 3rd case: a project file is already associated with the directory |
(princ " no. file name \n") |
795 |
(default |
(princ " --- ------------------------\n") |
796 |
(set 'selected (cdr default))) |
(let ((counter 1)) |
797 |
|
(while (<= counter (length prj-files)) |
798 |
;; 4th case: the user has set a default project file for every file |
(princ (format " %2d) %s\n" |
799 |
((and ada-prj-default-project-file |
counter |
800 |
(not (string= ada-prj-default-project-file ""))) |
(nth (1- counter) prj-files))) |
801 |
(set 'selected ada-prj-default-project-file)) |
(setq counter (1+ counter)) |
802 |
|
))) ; end of with-output-to ... |
803 |
;; 5th case: there is a project file with the same name as the Ada file, |
(setq choice nil) |
804 |
;; but not the same extension. |
(while (or |
805 |
((file-exists-p first-choice) |
(not choice) |
806 |
(set 'selected first-choice)) |
(not (integerp choice)) |
807 |
|
(< choice 1) |
808 |
;; 6th case: only one project file was found in the current directory |
(> choice (length prj-files))) |
809 |
((= (length prj-files) 1) |
(setq choice (string-to-int |
810 |
(set 'selected (car prj-files))) |
(read-from-minibuffer "Enter No. of your choice: ")))) |
811 |
|
(set 'selected (nth (1- choice) prj-files)))) |
812 |
;; 7th case: if there are multiple files, ask the user |
|
813 |
((and (> (length prj-files) 1) (not no-user-question)) |
;; Else if no project file was found in the directory, ask a name |
814 |
(save-window-excursion |
;; to the user, using as a default value the last one entered by |
815 |
(with-output-to-temp-buffer "*choice list*" |
;; the user |
816 |
(princ "There are more than one possible project file. Which one should\n") |
((= (length prj-files) 0) |
817 |
(princ "be used ?\n\n") |
(unless (or no-user-question (not ada-always-ask-project)) |
818 |
(princ " no. file name \n") |
(setq ada-last-prj-file |
819 |
(princ " --- ------------------------\n") |
(read-file-name |
820 |
(let ((counter 1)) |
(concat "project file [" ada-last-prj-file "]:") |
821 |
(while (<= counter (length prj-files)) |
nil ada-last-prj-file)) |
822 |
(princ (format " %2d) %s\n" |
(unless (string= ada-last-prj-file "") |
823 |
counter |
(set 'selected ada-last-prj-file)))) |
824 |
(nth (1- counter) prj-files))) |
))) |
|
(setq counter (1+ counter)) |
|
|
))) ; end of with-output-to ... |
|
|
(setq choice nil) |
|
|
(while (or |
|
|
(not choice) |
|
|
(not (integerp choice)) |
|
|
(< choice 1) |
|
|
(> choice (length prj-files))) |
|
|
(setq choice (string-to-int |
|
|
(read-from-minibuffer "Enter No. of your choice: ")))) |
|
|
(set 'selected (nth (1- choice) prj-files)))) |
|
|
|
|
|
;; 8th case: no project file was found in the directory, ask a name to the |
|
|
;; user, using as a default value the last one entered by the user |
|
|
((= (length prj-files) 0) |
|
|
(unless (or no-user-question (not ada-always-ask-project)) |
|
|
(setq ada-last-prj-file |
|
|
(read-file-name "project file:" nil ada-last-prj-file)) |
|
|
(unless (string= ada-last-prj-file "") |
|
|
(set 'selected ada-last-prj-file)))) |
|
|
)))) |
|
825 |
selected |
selected |
826 |
)) |
)) |
827 |
|
|
830 |
"Reads and parses the PRJ-FILE file if it was found. |
"Reads and parses the PRJ-FILE file if it was found. |
831 |
The current buffer should be the ada-file buffer." |
The current buffer should be the ada-file buffer." |
832 |
(if prj-file |
(if prj-file |
833 |
(let (project src_dir obj_dir casing |
(let (project src_dir obj_dir make_cmd comp_cmd check_cmd casing |
834 |
|
run_cmd debug_pre_cmd debug_post_cmd |
835 |
(ada-buffer (current-buffer))) |
(ada-buffer (current-buffer))) |
836 |
(set 'prj-file (expand-file-name prj-file)) |
(setq prj-file (expand-file-name prj-file)) |
837 |
|
|
838 |
;; Initialize the project with the default values |
;; Initialize the project with the default values |
839 |
(ada-xref-set-default-prj-values 'project (current-buffer)) |
(ada-xref-set-default-prj-values 'project (current-buffer)) |
847 |
|
|
848 |
(widen) |
(widen) |
849 |
(goto-char (point-min)) |
(goto-char (point-min)) |
850 |
|
|
851 |
;; Now overrides these values with the project file |
;; Now overrides these values with the project file |
852 |
(while (not (eobp)) |
(while (not (eobp)) |
853 |
(if (looking-at "^\\([^=]+\\)=\\(.*\\)") |
(if (looking-at "^\\([^=]+\\)=\\(.*\\)") |
864 |
(set 'project |
(set 'project |
865 |
(plist-put project 'build_dir |
(plist-put project 'build_dir |
866 |
(file-name-as-directory (match-string 2))))) |
(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))) |
879 |
(t |
(t |
880 |
(set 'project (plist-put project (intern (match-string 1)) |
(set 'project (plist-put project (intern (match-string 1)) |
881 |
(match-string 2)))))) |
(match-string 2)))))) |
885 |
(reverse src_dir)))) |
(reverse src_dir)))) |
886 |
(if obj_dir (set 'project (plist-put project 'obj_dir |
(if obj_dir (set 'project (plist-put project 'obj_dir |
887 |
(reverse obj_dir)))) |
(reverse obj_dir)))) |
888 |
(if casing (set 'project (plist-put project 'casing casing))) |
(if casing (set 'project (plist-put project 'casing |
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 |
|
|
909 |
;; Memorize the newly read project file |
;; Memorize the newly read project file |
910 |
(if (assoc prj-file ada-xref-project-files) |
(if (assoc prj-file ada-xref-project-files) |
911 |
(setcdr (assoc prj-file ada-xref-project-files) project) |
(setcdr (assoc prj-file ada-xref-project-files) project) |
912 |
(add-to-list 'ada-xref-project-files (cons prj-file project))) |
(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) |
916 |
|
|
917 |
;; Sets up the compilation-search-path so that Emacs is able to |
;; Sets up the compilation-search-path so that Emacs is able to |
918 |
;; go to the source of the errors in a compilation buffer |
;; go to the source of the errors in a compilation buffer |
919 |
(setq compilation-search-path (ada-get-absolute-dir-list |
(setq compilation-search-path (ada-xref-get-src-dir-field)) |
920 |
(plist-get project 'src_dir) |
|
921 |
(plist-get project 'build_dir))) |
;; Set the casing exceptions file list |
922 |
|
(if casing |
923 |
;; Associate each source directory in the project file with this file |
(progn |
924 |
(mapcar (lambda (x) |
(setq ada-case-exception-file (reverse casing)) |
925 |
(if (not (assoc (expand-file-name x) |
(ada-case-read-exceptions))) |
|
ada-xref-default-prj-file)) |
|
|
(setq ada-xref-default-prj-file |
|
|
(cons (cons (expand-file-name x) prj-file) |
|
|
ada-xref-default-prj-file)))) |
|
|
compilation-search-path) |
|
926 |
|
|
927 |
;; Add the directories to the search path for ff-find-other-file |
;; Add the directories to the search path for ff-find-other-file |
928 |
;; Do not add the '/' or '\' at the end |
;; Do not add the '/' or '\' at the end |
929 |
(set (make-local-variable 'ff-search-directories) |
(setq ada-search-directories |
930 |
(append (mapcar 'directory-file-name compilation-search-path) |
(append (mapcar 'directory-file-name compilation-search-path) |
931 |
ada-search-directories)) |
ada-search-directories)) |
932 |
|
|
934 |
(kill-buffer nil) |
(kill-buffer nil) |
935 |
(set-buffer ada-buffer) |
(set-buffer ada-buffer) |
936 |
|
|
937 |
;; Setup the project file for the current buffer |
(ada-xref-update-project-menu) |
|
(set (make-local-variable 'ada-prj-prj-file) prj-file) |
|
|
|
|
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)) |
946 |
)) |
)) |
947 |
|
|
948 |
|
|
978 |
(interactive "sEntity name: ") |
(interactive "sEntity name: ") |
979 |
(ada-require-project-file) |
(ada-require-project-file) |
980 |
|
|
981 |
(let* ((command (concat "gnatfind -rf " entity |
;; 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 |
993 |
(if file (concat ":" (file-name-nondirectory file))) |
(if file (concat ":" (file-name-nondirectory file))) |
994 |
(if line (concat ":" line)) |
(if line (concat ":" line)) |
995 |
(if column (concat ":" column))))) |
(if column (concat ":" column))))) |
996 |
|
|
997 |
;; If a project file is defined, use it |
;; If a project file is defined, use it |
998 |
(if (my-local-variable-if-set-p 'ada-prj-prj-file (current-buffer)) |
(if (and ada-prj-default-project-file |
999 |
(setq command (concat command " -p" ada-prj-prj-file))) |
(not (string= ada-prj-default-project-file ""))) |
1000 |
|
(setq command (concat command " -p" ada-prj-default-project-file))) |
1001 |
|
|
1002 |
(compile-internal command "No more references" "gnatfind") |
(compile-internal command "No more references" "gnatfind") |
1003 |
|
|
1008 |
) |
) |
1009 |
) |
) |
1010 |
|
|
1011 |
(defun ada-buffer-list () |
(defalias 'ada-change-prj (symbol-function 'ada-set-default-project-file)) |
|
"Display a buffer with all the Ada buffers and their associated project." |
|
|
(interactive) |
|
|
(save-excursion |
|
|
(set-buffer (get-buffer-create "*Buffer List*")) |
|
|
(setq buffer-read-only nil) |
|
|
(erase-buffer) |
|
|
(setq standard-output (current-buffer)) |
|
|
(princ "The following line is a list showing the associations between |
|
|
directories and project file. It has the format : ((directory_1 . project_file1) |
|
|
(directory2 . project_file2)...)\n\n") |
|
|
(princ ada-xref-default-prj-file) |
|
|
(princ "\n |
|
|
Buffer Mode Project file |
|
|
------ ---- ------------ |
|
|
\n") |
|
|
(let ((bl (buffer-list))) |
|
|
(while bl |
|
|
(let* ((buffer (car bl)) |
|
|
(buffer-name (buffer-name buffer)) |
|
|
this-buffer-mode-name |
|
|
this-buffer-project-file) |
|
|
(save-excursion |
|
|
(set-buffer buffer) |
|
|
(setq this-buffer-mode-name |
|
|
(if (eq buffer standard-output) |
|
|
"Buffer Menu" mode-name)) |
|
|
(if (string= this-buffer-mode-name |
|
|
"Ada") |
|
|
(setq this-buffer-project-file |
|
|
(if ( my-local-variable-if-set-p 'ada-prj-prj-file |
|
|
(current-buffer)) |
|
|
(expand-file-name ada-prj-prj-file) |
|
|
"")))) |
|
|
(if (string= this-buffer-mode-name |
|
|
"Ada") |
|
|
(progn |
|
|
(princ (format "%-19s " buffer-name)) |
|
|
(princ (format "%-6s " this-buffer-mode-name)) |
|
|
(princ this-buffer-project-file) |
|
|
(princ "\n") |
|
|
)) |
|
|
) ;; end let* |
|
|
(setq bl (cdr bl)) |
|
|
) ;; end while |
|
|
);; end let |
|
|
) ;; end save-excursion |
|
|
(display-buffer "*Buffer List*") |
|
|
(other-window 1) |
|
|
) |
|
|
|
|
|
(defun ada-change-prj (filename) |
|
|
"Set FILENAME to be the project file for current buffer." |
|
|
(interactive "fproject file:") |
|
|
|
|
|
;; make sure we are using an Ada file |
|
|
(if (not (string= mode-name "Ada")) |
|
|
(error "You must be in ada-mode to use this function")) |
|
|
|
|
|
(set (make-local-variable 'ada-prj-prj-file) filename) |
|
|
(ada-parse-prj-file filename) |
|
|
) |
|
|
|
|
|
(defun ada-change-default-prj (filename) |
|
|
"Set FILENAME to be the default project file for the current directory." |
|
|
(interactive "ffile name:") |
|
|
(let ((dir (file-name-directory (buffer-file-name))) |
|
|
(prj (expand-file-name filename))) |
|
|
|
|
|
;; Associate the directory with a project file |
|
|
(if (assoc dir ada-xref-default-prj-file) |
|
|
(setcdr (assoc dir ada-xref-default-prj-file) prj) |
|
|
(add-to-list 'ada-xref-default-prj-file (list dir prj))) |
|
|
|
|
|
;; Reparse the project file |
|
|
(ada-parse-prj-file filename))) |
|
|
|
|
1012 |
|
|
1013 |
;; ----- Identlist manipulation ------------------------------------------- |
;; ----- Identlist manipulation ------------------------------------------- |
1014 |
;; An identlist is a vector that is used internally to reference an identifier |
;; An identlist is a vector that is used internally to reference an identifier |
1086 |
(mouse-set-point last-input-event) |
(mouse-set-point last-input-event) |
1087 |
(ada-goto-declaration (point))) |
(ada-goto-declaration (point))) |
1088 |
|
|
1089 |
(defun ada-goto-declaration (pos) |
(defun ada-goto-declaration (pos &optional other-frame) |
1090 |
"Display the declaration of the identifier around POS. |
"Display the declaration of the identifier around POS. |
1091 |
The declaration is shown in another buffer if `ada-xref-other-buffer' is |
The declaration is shown in another buffer if `ada-xref-other-buffer' is |
1092 |
non-nil." |
non-nil. |
1093 |
|
If OTHER-FRAME is non-nil, display the cross-reference in another frame." |
1094 |
(interactive "d") |
(interactive "d") |
1095 |
(ada-require-project-file) |
(ada-require-project-file) |
1096 |
(push-mark pos) |
(push-mark pos) |
1097 |
(ada-xref-push-pos (buffer-file-name) pos) |
(ada-xref-push-pos (buffer-file-name) pos) |
|
(ada-find-in-ali (ada-read-identifier pos))) |
|
1098 |
|
|
1099 |
(defun ada-goto-declaration-other-frame (pos) |
;; 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) |
1108 |
"Display the declaration of the identifier around POS. |
"Display the declaration of the identifier around POS. |
1109 |
The declation is shown in another frame if `ada-xref-other-buffer' is non-nil." |
The declation is shown in another frame if `ada-xref-other-buffer' is non-nil." |
1110 |
(interactive "d") |
(interactive "d") |
1111 |
(ada-require-project-file) |
(ada-goto-declaration pos t)) |
|
(push-mark pos) |
|
|
(ada-xref-push-pos (buffer-file-name) pos) |
|
|
(ada-find-in-ali (ada-read-identifier pos) t)) |
|
1112 |
|
|
1113 |
(defun ada-remote (command) |
(defun ada-remote (command) |
1114 |
"Return the remote version of COMMAND, or COMMAND if remote_machine is nil." |
"Return the remote version of COMMAND, or COMMAND if remote_machine is nil." |
1120 |
machine |
machine |
1121 |
command)))) |
command)))) |
1122 |
|
|
|
(defun ada-get-absolute-dir (dir root-dir) |
|
|
"Returns the absolute directory corresponding to DIR. |
|
|
If DIR is a relative directory, the value of ROOT-DIR is added in front." |
|
|
(if (= (string-to-char dir) ?/) |
|
|
dir |
|
|
(concat root-dir dir))) |
|
|
|
|
1123 |
(defun ada-get-absolute-dir-list (dir-list root-dir) |
(defun ada-get-absolute-dir-list (dir-list root-dir) |
1124 |
"Returns the list of absolute directories found in dir-list. |
"Returns the list of absolute directories found in dir-list. |
1125 |
If a directory is a relative directory, the value of ROOT-DIR is added in |
If a directory is a relative directory, the value of ROOT-DIR is added in |
1126 |
front." |
front." |
1127 |
(mapcar (lambda (x) (ada-get-absolute-dir x root-dir)) dir-list)) |
(mapcar (lambda (x) (expand-file-name x root-dir)) dir-list)) |
1128 |
|
|
1129 |
(defun ada-set-environment () |
(defun ada-set-environment () |
1130 |
"Return the new value for process-environment. |
"Return the new value for process-environment. |
1134 |
(objects (getenv "ADA_OBJECTS_PATH")) |
(objects (getenv "ADA_OBJECTS_PATH")) |
1135 |
(build-dir (ada-xref-get-project-field 'build_dir))) |
(build-dir (ada-xref-get-project-field 'build_dir))) |
1136 |
(if include |
(if include |
1137 |
(set 'include (concat include path-separator))) |
(set 'include (concat path-separator include))) |
1138 |
(if objects |
(if objects |
1139 |
(set 'objects (concat objects path-separator))) |
(set 'objects (concat path-separator objects))) |
1140 |
(cons |
(cons |
1141 |
(concat "ADA_INCLUDE_PATH=" |
(concat "ADA_INCLUDE_PATH=" |
1142 |
include |
(mapconcat (lambda(x) (expand-file-name x build-dir)) |
|
(mapconcat (lambda(x) (ada-get-absolute-dir x build-dir)) |
|
1143 |
(ada-xref-get-project-field 'src_dir) |
(ada-xref-get-project-field 'src_dir) |
1144 |
path-separator)) |
path-separator) |
1145 |
|
include) |
1146 |
(cons |
(cons |
1147 |
(concat "ADA_OBJECTS_PATH=" |
(concat "ADA_OBJECTS_PATH=" |
1148 |
objects |
(mapconcat (lambda(x) (expand-file-name x build-dir)) |
|
(mapconcat (lambda(x) (ada-get-absolute-dir x build-dir)) |
|
1149 |
(ada-xref-get-project-field 'obj_dir) |
(ada-xref-get-project-field 'obj_dir) |
1150 |
path-separator)) |
path-separator) |
1151 |
|
objects) |
1152 |
process-environment)))) |
process-environment)))) |
1153 |
|
|
1154 |
(defun ada-compile-application (&optional arg) |
(defun ada-compile-application (&optional arg) |
1160 |
(process-environment (ada-set-environment)) |
(process-environment (ada-set-environment)) |
1161 |
(compilation-scroll-output t)) |
(compilation-scroll-output t)) |
1162 |
|
|
1163 |
(set 'compilation-search-path |
(setq compilation-search-path (ada-xref-get-src-dir-field)) |
|
(ada-get-absolute-dir-list (ada-xref-get-project-field 'src_dir) |
|
|
(ada-xref-get-project-field 'build_dir))) |
|
1164 |
|
|
1165 |
;; If no project file was found, ask the user |
;; If no project file was found, ask the user |
1166 |
(unless cmd |
(unless cmd |
1167 |
(setq cmd "" arg t)) |
(setq cmd '("") arg t)) |
1168 |
|
|
1169 |
(compile (ada-remote |
;; Make a single command from the list of commands, including the |
1170 |
(if (or ada-xref-confirm-compile arg) |
;; commands to run it on a remote machine. |
1171 |
(read-from-minibuffer "enter command to compile: " cmd) |
(setq cmd (ada-remote (mapconcat 'identity cmd ada-command-separator))) |
1172 |
cmd))) |
|
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)))) |
1183 |
|
|
1184 |
(defun ada-compile-current (&optional arg prj-field) |
(defun ada-compile-current (&optional arg prj-field) |
1185 |
"Recompile the current file. |
"Recompile the current file. |
1193 |
(process-environment (ada-set-environment)) |
(process-environment (ada-set-environment)) |
1194 |
(compilation-scroll-output t)) |
(compilation-scroll-output t)) |
1195 |
|
|
1196 |
(set 'compilation-search-path |
(setq compilation-search-path (ada-xref-get-src-dir-field)) |
|
(ada-get-absolute-dir-list (ada-xref-get-project-field 'src_dir) |
|
|
(ada-xref-get-project-field 'build_dir))) |
|
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 |
|
|
1205 |
;; If no project file was found, ask the user |
;; If no project file was found, ask the user |
1206 |
(if cmd |
(if (or ada-xref-confirm-compile arg) |
1207 |
(set 'cmd (concat cmd " " (ada-convert-file-name (buffer-file-name)))) |
(setq cmd (read-from-minibuffer "enter command to compile: " cmd))) |
1208 |
(setq cmd "" arg t)) |
|
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"))) |
1214 |
|
|
1215 |
(compile (ada-remote |
(compile (ada-quote-cmd cmd)))) |
|
(if (or ada-xref-confirm-compile arg) |
|
|
(read-from-minibuffer "enter command to compile: " cmd) |
|
|
cmd))))) |
|
1216 |
|
|
1217 |
(defun ada-check-current (&optional arg) |
(defun ada-check-current (&optional arg) |
1218 |
"Recompile the current file. |
"Recompile the current file. |
1233 |
(let ((command (ada-xref-get-project-field 'run_cmd))) |
(let ((command (ada-xref-get-project-field 'run_cmd))) |
1234 |
|
|
1235 |
;; Guess the command if it wasn't specified |
;; Guess the command if it wasn't specified |
1236 |
(if (or (not command) (string= command "")) |
(if (not command) |
1237 |
(set 'command (file-name-sans-extension (buffer-name)))) |
(set 'command (list (file-name-sans-extension (buffer-name))))) |
1238 |
|
|
1239 |
|
;; Modify the command to run remotely |
1240 |
|
(setq command (ada-remote (mapconcat 'identity command |
1241 |
|
ada-command-separator))) |
1242 |
|
|
1243 |
;; Ask for the arguments to the command if required |
;; Ask for the arguments to the command if required |
1244 |
(if (or ada-xref-confirm-compile arg) |
(if (or ada-xref-confirm-compile arg) |
1245 |
(set 'command (read-from-minibuffer "Enter command to execute: " command))) |
(setq command (read-from-minibuffer "Enter command to execute: " |
1246 |
|
command))) |
|
;; Modify the command to run remotely |
|
|
(setq command (ada-remote command)) |
|
1247 |
|
|
1248 |
;; Run the command |
;; Run the command |
1249 |
(save-excursion |
(save-excursion |
1250 |
(set-buffer (get-buffer-create "*run*")) |
(set-buffer (get-buffer-create "*run*")) |
1251 |
(set 'buffer-read-only nil) |
(set 'buffer-read-only nil) |
1252 |
|
|
1253 |
(erase-buffer) |
(erase-buffer) |
1254 |
(goto-char (point-min)) |
(start-process "run" (current-buffer) shell-file-name |
1255 |
(insert "\nRunning " command "\n\n") |
"-c" command) |
1256 |
(start-process "run" (current-buffer) shell-file-name "-c" command) |
(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) |
1262 |
) |
) |
1263 |
(display-buffer "*run*") |
(display-buffer "*run*") |
1264 |
|
|
1267 |
(switch-to-buffer "*run*") |
(switch-to-buffer "*run*") |
1268 |
)) |
)) |
1269 |
|
|
1270 |
|
(defun ada-gdb-application (&optional arg executable-name) |
|
(defun ada-gdb-application (&optional arg) |
|
1271 |
"Start the debugger on the application. |
"Start the debugger on the application. |
1272 |
|
EXECUTABLE-NAME, if non-nil, is debugged instead of the file specified in the |
1273 |
|
project file. |
1274 |
If ARG is non-nil, ask the user to confirm the command." |
If ARG is non-nil, ask the user to confirm the command." |
1275 |
(interactive "P") |
(interactive "P") |
1276 |
(let ((buffer (current-buffer)) |
(let ((buffer (current-buffer)) |
1277 |
gdb-buffer |
cmd pre-cmd post-cmd) |
|
cmd) |
|
1278 |
(ada-require-project-file) |
(ada-require-project-file) |
1279 |
(set 'cmd (ada-xref-get-project-field 'debug_cmd)) |
(setq cmd (if executable-name |
1280 |
(let ((machine (ada-xref-get-project-field 'remote_machine))) |
(concat ada-prj-default-debugger " " executable-name) |
1281 |
(if (and machine (not (string= machine ""))) |
(ada-xref-get-project-field 'debug_cmd)) |
1282 |
(error "This feature is not supported yet for remote environments"))) |
pre-cmd (ada-xref-get-project-field 'debug_pre_cmd) |
1283 |
|
post-cmd (ada-xref-get-project-field 'debug_post_cmd)) |
1284 |
|
|
1285 |
;; If the command was not given in the project file, start a bare gdb |
;; If the command was not given in the project file, start a bare gdb |
1286 |
(if (not cmd) |
(if (not cmd) |
1287 |
(set 'cmd (concat ada-prj-default-debugger |
(set 'cmd (concat ada-prj-default-debugger |
1288 |
" " |
" " |
1289 |
(file-name-sans-extension (buffer-file-name))))) |
(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 |
1313 |
(if (or arg ada-xref-confirm-compile) |
(if (or arg ada-xref-confirm-compile) |
1314 |
(set 'cmd (read-from-minibuffer "enter command to debug: " cmd))) |
(set 'cmd (read-from-minibuffer "enter command to debug: " cmd))) |
1315 |
|
|
1316 |
;; Set the variable gud-last-last-frame so that glide-debug can find |
(let (comint-exec |
1317 |
;; the name of the Ada file, and thus of the project file if needed. |
in-post-mode |
1318 |
(if ada-prj-prj-file |
gud-gdb-massage-args) |
1319 |
(set 'gud-last-last-frame (cons ada-prj-prj-file 1))) |
|
1320 |
|
;; Do not add -fullname, since we can have a 'rsh' command in front. |
1321 |
(if (and (string-match "jdb" (comint-arguments cmd 0 0)) |
(fset 'gud-gdb-massage-args (lambda (file args) args)) |
1322 |
(boundp 'jdb)) |
|
1323 |
(funcall (symbol-function 'jdb) cmd) |
(set 'pre-cmd (mapconcat 'identity pre-cmd ada-command-separator)) |
1324 |
(gdb cmd)) |
(if (not (equal pre-cmd "")) |
1325 |
|
(setq pre-cmd (concat pre-cmd ada-command-separator))) |
1326 |
(set 'gdb-buffer (symbol-value 'gud-comint-buffer)) |
|
1327 |
|
(set 'post-cmd (mapconcat 'identity post-cmd "\n")) |
1328 |
;; Switch back to the source buffer |
(if post-cmd |
1329 |
;; and Activate the debug part in the contextual menu |
(set 'post-cmd (concat post-cmd "\n"))) |
1330 |
(switch-to-buffer buffer) |
|
1331 |
|
;; Temporarily replaces the definition of `comint-exec' so that we |
1332 |
(if (functionp 'gud-make-debug-menu) |
;; can execute commands before running gdb. |
1333 |
(funcall (symbol-function 'gud-make-debug-menu))) |
(fset 'comint-exec |
1334 |
|
`(lambda (buffer name command startfile switches) |
1335 |
;; Warning: on Emacs >= 20.3.8, same-window-regexps includes gud-*, |
(let (compilation-buffer-name-function) |
1336 |
;; so the following call to display buffer will select the |
(save-excursion |
1337 |
;; buffer instead of displaying it in another window |
(set 'compilation-buffer-name-function |
1338 |
;; This is why the second argument to display-buffer is 't' |
(lambda(x) (buffer-name buffer))) |
1339 |
(display-buffer gdb-buffer t) |
(compile (ada-quote-cmd |
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 |
|
))) |
1371 |
|
|
1372 |
|
|
1373 |
(defun ada-reread-prj-file (&optional filename) |
(defun ada-reread-prj-file (&optional filename) |
1380 |
(if filename |
(if filename |
1381 |
(ada-parse-prj-file filename) |
(ada-parse-prj-file filename) |
1382 |
(ada-parse-prj-file (ada-prj-find-prj-file))) |
(ada-parse-prj-file (ada-prj-find-prj-file))) |
|
) |
|
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 |
|
) |
1388 |
|
|
1389 |
;; ------ Private routines |
;; ------ Private routines |
1390 |
|
|
1391 |
(defun ada-xref-current (file &optional ali-file-name) |
(defun ada-xref-current (file &optional ali-file-name) |
1392 |
"Update the cross-references for FILE. |
"Update the cross-references for FILE. |
1393 |
This in fact recompiles FILE to create ALI-FILE-NAME." |
This in fact recompiles FILE to create ALI-FILE-NAME. |
1394 |
|
This function returns the name of the file that was recompiled to generate |
1395 |
|
the cross-reference information. Note that the ali file can then be deduced by |
1396 |
|
replacing the file extension with .ali" |
1397 |
;; kill old buffer |
;; kill old buffer |
1398 |
(if (and ali-file-name |
(if (and ali-file-name |
1399 |
(get-file-buffer ali-file-name)) |
(get-file-buffer ali-file-name)) |
1400 |
(kill-buffer (get-file-buffer ali-file-name))) |
(kill-buffer (get-file-buffer ali-file-name))) |
1401 |
;; read the project file |
|
1402 |
(ada-require-project-file) |
(let* ((name (ada-convert-file-name file)) |
1403 |
(let* ((cmd (ada-xref-get-project-field 'comp_cmd)) |
(body-name (or (ada-get-body-name name) name))) |
1404 |
(process-environment (ada-set-environment)) |
|
1405 |
(compilation-scroll-output t) |
;; Always recompile the body when we can. We thus temporarily switch to a |
1406 |
(name (ada-convert-file-name (buffer-file-name))) |
;; buffer than contains the body of the unit |
1407 |
(body-name (ada-get-body-name name))) |
(save-excursion |
1408 |
|
(let ((body-visible (find-buffer-visiting body-name)) |
1409 |
;; Always recompile the body when we can |
process) |
1410 |
(set 'body-name (or body-name name)) |
(if body-visible |
1411 |
|
(set-buffer body-visible) |
1412 |
;; prompt for command to execute |
(find-file body-name)) |
1413 |
(set 'cmd (concat cmd " " body-name)) |
|
1414 |
(compile (ada-remote |
;; Execute the compilation. Note that we must wait for the end of the |
1415 |
(if ada-xref-confirm-compile |
;; process, or the ALI file would still not be available. |
1416 |
(read-from-minibuffer "enter command to compile: " cmd) |
;; Unfortunately, the underlying `compile' command that we use is |
1417 |
cmd))))) |
;; 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)) |
1430 |
|
|
1431 |
(defun ada-find-file-in-dir (file dir-list) |
(defun ada-find-file-in-dir (file dir-list) |
1432 |
"Search for FILE in DIR-LIST." |
"Search for FILE in DIR-LIST." |
1444 |
"Find an .ali file in obj_dir. The current buffer must be the Ada file. |
"Find an .ali file in obj_dir. The current buffer must be the Ada file. |
1445 |
Adds build_dir in front of the search path to conform to gnatmake's behavior, |
Adds build_dir in front of the search path to conform to gnatmake's behavior, |
1446 |
and the standard runtime location at the end." |
and the standard runtime location at the end." |
1447 |
(ada-find-file-in-dir file |
(ada-find-file-in-dir file (ada-xref-get-obj-dir-field))) |
|
(append |
|
|
|
|
|
;; Add ${build_dir} in front of the path |
|
|
(list (ada-xref-get-project-field 'build_dir)) |
|
|
|
|
|
(ada-get-absolute-dir-list |
|
|
(ada-xref-get-project-field 'obj_dir) |
|
|
(ada-xref-get-project-field 'build_dir)) |
|
|
|
|
|
;; Add the standard runtime at the end |
|
|
ada-xref-runtime-library-ali-path))) |
|
1448 |
|
|
1449 |
(defun ada-find-src-file-in-dir (file) |
(defun ada-find-src-file-in-dir (file) |
1450 |
"Find a source file in src_dir. The current buffer must be the Ada file. |
"Find a source file in src_dir. The current buffer must be the Ada file. |
1451 |
Adds src_dir in front of the search path to conform to gnatmake's behavior, |
Adds src_dir in front of the search path to conform to gnatmake's behavior, |
1452 |
and the standard runtime location at the end." |
and the standard runtime location at the end." |
1453 |
(ada-find-file-in-dir file |
(ada-find-file-in-dir file (ada-xref-get-src-dir-field))) |
|
(append |
|
|
|
|
|
;; Add ${build_dir} in front of the path |
|
|
(list (ada-xref-get-project-field 'build_dir)) |
|
|
|
|
|
(ada-get-absolute-dir-list |
|
|
(ada-xref-get-project-field 'src_dir) |
|
|
(ada-xref-get-project-field 'build_dir)) |
|
|
|
|
|
;; Add the standard runtime at the end |
|
|
ada-xref-runtime-library-specs-path))) |
|
|
|
|
1454 |
|
|
1455 |
(defun ada-get-ali-file-name (file) |
(defun ada-get-ali-file-name (file) |
1456 |
"Create the ali file name for the ada-file FILE. |
"Create the ali file name for the ada-file FILE. |
1468 |
;; 3- If the file is not found or step 2 failed: |
;; 3- If the file is not found or step 2 failed: |
1469 |
;; find the name of the "other file", ie the body, and look |
;; find the name of the "other file", ie the body, and look |
1470 |
;; for its associated .ali file by subtituing the extension |
;; 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. |
1479 |
|
|
1480 |
(save-excursion |
(save-excursion |
1481 |
(set-buffer (get-file-buffer file)) |
(set-buffer (get-file-buffer file)) |
1482 |
(let ((short-ali-file-name |
(let ((short-ali-file-name |
1483 |
(concat (file-name-sans-extension (file-name-nondirectory file)) |
(concat (file-name-sans-extension (file-name-nondirectory file)) |
1484 |
".ali")) |
".ali")) |
1485 |
ali-file-name) |
ali-file-name |
1486 |
;; First step |
is-spec) |
1487 |
;; we take the first possible completion |
|
1488 |
(setq ali-file-name (ada-find-ali-file-in-dir short-ali-file-name)) |
;; If we have a non-standard file name, and this is a spec, we first |
1489 |
|
;; look for the .ali file of the body, since this is the one that |
1490 |
;; If we have found the .ali file, but the source file was a spec |
;; contains the most complete information. If not found, we will do what |
1491 |
;; with a non-standard name, search the .ali file for the body if any, |
;; we can with the .ali file for the spec... |
1492 |
;; since the xref information is more complete in that one |
|
1493 |
(unless ali-file-name |
(if (not (string= (file-name-extension file) "ads")) |
1494 |
(if (not (string= (file-name-extension file) "ads")) |
(let ((specs ada-spec-suffixes)) |
1495 |
(let ((is-spec nil) |
(while specs |
1496 |
(specs ada-spec-suffixes) |
(if (string-match (concat (regexp-quote (car specs)) "$") |
1497 |
body-ali) |
file) |
1498 |
(while specs |
(set 'is-spec t)) |
1499 |
(if (string-match (concat (regexp-quote (car specs)) "$") |
(set 'specs (cdr specs))))) |
1500 |
file) |
|
1501 |
(set 'is-spec t)) |
(if is-spec |
1502 |
(set 'specs (cdr specs))) |
(set 'ali-file-name |
1503 |
|
(ada-find-ali-file-in-dir |
1504 |
(if is-spec |
(concat (file-name-sans-extension |
1505 |
(set 'body-ali |
(file-name-nondirectory |
1506 |
(ada-find-ali-file-in-dir |
(ada-other-file-name))) |
1507 |
(concat (file-name-sans-extension |
".ali")))) |
1508 |
(file-name-nondirectory |
|
1509 |
(ada-other-file-name))) |
|
1510 |
".ali")))) |
(setq ali-file-name |
1511 |
(if body-ali |
(or ali-file-name |
1512 |
(set 'ali-file-name body-ali)))) |
|
1513 |
|
;; Else we take the .ali file associated with the unit |
1514 |
;; else we did not find the .ali file |
(ada-find-ali-file-in-dir short-ali-file-name) |
1515 |
;; Second chance: in case the files do not have standard names (such |
|
1516 |
;; as for instance file_s.ada and file_b.ada), try to go to the |
|
1517 |
;; other file and look for its ali file |
;; else we did not find the .ali file Second chance: in case |
1518 |
(setq short-ali-file-name |
;; the files do not have standard names (such as for instance |
1519 |
(concat (file-name-sans-extension |
;; file_s.ada and file_b.ada), try to go to the other file |
1520 |
(file-name-nondirectory (ada-other-file-name))) |
;; and look for its ali file |
1521 |
".ali")) |
(ada-find-ali-file-in-dir |
1522 |
(setq ali-file-name (ada-find-ali-file-in-dir short-ali-file-name)) |
(concat (file-name-sans-extension |
1523 |
|
(file-name-nondirectory (ada-other-file-name))) |
1524 |
;; If still not found, try to recompile the file |
".ali")) |
1525 |
(if (not ali-file-name) |
|
1526 |
(progn |
|
1527 |
;; recompile only if the user asked for this |
;; If we still don't have an ali file, try to get the one |
1528 |
(if ada-xref-create-ali |
;; from the parent unit, in case we have a separate entity. |
1529 |
(ada-xref-current file ali-file-name)) |
(let ((parent-name (file-name-sans-extension |
1530 |
(error "Ali file not found. Recompile your file"))) |
(file-name-nondirectory file)))) |
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")) |
1551 |
|
|
1552 |
;; same if the .ali file is too old and we must recompile it |
(error "Ali file not found. Recompile your file")) |
1553 |
(if (and (file-newer-than-file-p file ali-file-name) |
|
1554 |
ada-xref-create-ali) |
|
1555 |
(ada-xref-current file ali-file-name)) |
;; 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))) |
1559 |
|
|
1560 |
;; else returns the correct absolute file name |
;; Always return the correct absolute file name |
1561 |
(expand-file-name ali-file-name)) |
(expand-file-name ali-file-name)) |
1562 |
)) |
)) |
1563 |
|
|
1564 |
(defun ada-get-ada-file-name (file original-file) |
(defun ada-get-ada-file-name (file original-file) |
1565 |
"Create the complete file name (+directory) for FILE. |
"Create the complete file name (+directory) for FILE. |
1598 |
(count-lines begin (point)))) |
(count-lines begin (point)))) |
1599 |
|
|
1600 |
(defun ada-read-identifier (pos) |
(defun ada-read-identifier (pos) |
1601 |
"Returns the identlist around POS and switch to the .ali buffer." |
"Returns the identlist around POS and switch to the .ali buffer. |
1602 |
|
The returned list represents the entity, and can be manipulated through the |
1603 |
;; If there's a compilation in progress, it's probably because the |
macros `ada-name-of', `ada-line-of', `ada-column-of', `ada-file-of',..." |
|
;; .ali file didn't exist. So we should wait... |
|
|
(if compilation-in-progress |
|
|
(progn |
|
|
(message "Compilation in progress. Try again when it is finished") |
|
|
(set 'quit-flag t))) |
|
1604 |
|
|
1605 |
;; If at end of buffer (e.g the buffer is empty), error |
;; If at end of buffer (e.g the buffer is empty), error |
1606 |
(if (>= (point) (point-max)) |
(if (>= (point) (point-max)) |
1705 |
;; if we did not find it, it may be because the first reference |
;; if we did not find it, it may be because the first reference |
1706 |
;; is not required to have a 'unit_number|' item included. |
;; is not required to have a 'unit_number|' item included. |
1707 |
;; Or maybe we are already on the declaration... |
;; Or maybe we are already on the declaration... |
1708 |
(unless (re-search-forward (concat "^\\([a-zA-Z0-9_.\"]+[ *]\\)*" |
(unless (re-search-forward |
1709 |
(ada-line-of identlist) |
(concat |
1710 |
"[^0-9]" |
"^\\(\\([a-zA-Z0-9_.]+\\|\"[<>=+*-/a-z]\"\\)[ *]\\)*" |
1711 |
(ada-column-of identlist)) |
(ada-line-of identlist) |
1712 |
nil t) |
"[^0-9]" |
1713 |
|
(ada-column-of identlist)) |
1714 |
|
nil t) |
1715 |
|
|
1716 |
;; If still not found, then either the declaration is unknown |
;; If still not found, then either the declaration is unknown |
1717 |
;; or the source file has been modified since the ali file was |
;; or the source file has been modified since the ali file was |
1763 |
) |
) |
1764 |
|
|
1765 |
(if (re-search-backward "^X [0-9]+ \\([a-zA-Z0-9_.-]+\\)" nil t) |
(if (re-search-backward "^X [0-9]+ \\([a-zA-Z0-9_.-]+\\)" nil t) |
1766 |
(ada-set-declare-file |
|
1767 |
identlist |
;; If we can find the file |
1768 |
(ada-get-ada-file-name (match-string 1) |
(condition-case err |
1769 |
(ada-file-of identlist)))) |
(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 |
|
)) |
1779 |
|
|
1780 |
(ada-set-references identlist current-line) |
(ada-set-references identlist current-line) |
1781 |
)) |
)) |
1836 |
|
|
1837 |
;; more than one => display choice list |
;; more than one => display choice list |
1838 |
(t |
(t |
1839 |
(with-output-to-temp-buffer "*choice list*" |
(save-window-excursion |
1840 |
|
(with-output-to-temp-buffer "*choice list*" |
1841 |
(princ "Identifier is overloaded and Xref information is not up to date.\n") |
|
1842 |
(princ "Possible declarations are:\n\n") |
(princ "Identifier is overloaded and Xref information is not up to date.\n") |
1843 |
(princ " no. in file at line col\n") |
(princ "Possible declarations are:\n\n") |
1844 |
(princ " --- --------------------- ---- ----\n") |
(princ " no. in file at line col\n") |
1845 |
(let ((counter 1)) |
(princ " --- --------------------- ---- ----\n") |
1846 |
(while (<= counter len) |
(let ((counter 0)) |
1847 |
(princ (format " %2d) %-21s %4s %4s\n" |
(while (< counter len) |
1848 |
counter |
(princ (format " %2d) %-21s %4s %4s\n" |
1849 |
|
(1+ counter) |
1850 |
(ada-get-ada-file-name |
(ada-get-ada-file-name |
1851 |
(nth 1 (nth (1- counter) declist)) |
(nth 1 (nth counter declist)) |
1852 |
(ada-file-of identlist)) |
(ada-file-of identlist)) |
1853 |
(nth 2 (nth (1- counter) declist)) |
(nth 2 (nth counter declist)) |
1854 |
(nth 3 (nth (1- counter) declist)) |
(nth 3 (nth counter declist)) |
1855 |
)) |
)) |
1856 |
(setq counter (1+ counter)) |
(setq counter (1+ counter)) |
1857 |
) ; end of while |
) ; end of while |
1858 |
) ; end of let |
) ; end of let |
1859 |
) ; end of with-output-to ... |
) ; end of with-output-to ... |
1860 |
(setq choice nil) |
(setq choice nil) |
1861 |
(while (or |
(while (or |
1862 |
(not choice) |
(not choice) |
1863 |
(not (integerp choice)) |
(not (integerp choice)) |
1864 |
(< choice 1) |
(< choice 1) |
1865 |
(> choice len)) |
(> choice len)) |
1866 |
(setq choice (string-to-int |
(setq choice |
1867 |
(read-from-minibuffer "Enter No. of your choice: ")))) |
(string-to-int |
1868 |
|
(read-from-minibuffer "Enter No. of your choice: ")))) |
1869 |
|
) |
1870 |
(set-buffer ali-buffer) |
(set-buffer ali-buffer) |
1871 |
(goto-line (car (nth (1- choice) declist))) |
(goto-line (car (nth (1- choice) declist))) |
1872 |
)))))) |
)))))) |
1879 |
|
|
1880 |
(ada-get-all-references identlist) |
(ada-get-all-references identlist) |
1881 |
(let ((ali-line (ada-references-of identlist)) |
(let ((ali-line (ada-references-of identlist)) |
1882 |
|
(locations nil) |
1883 |
|
(start 0) |
1884 |
file line col) |
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))) |
1926 |
|
|
1927 |
;; If we were on a declaration, go to the body |
(while locations |
1928 |
(if (ada-on-declaration identlist) |
(if (and (string= (caar locations) (ada-line-of identlist)) |
1929 |
(if (string-match "\\([0-9]+\\)[bc]\\([0-9]+\\)" ali-line) |
(string= (nth 1 (car locations)) (ada-column-of identlist)) |
1930 |
(progn |
(string= (file-name-nondirectory (nth 2 (car locations))) |
1931 |
(setq line (match-string 1 ali-line) |
(file-name-nondirectory (ada-file-of identlist)))) |
1932 |
col (match-string 2 ali-line)) |
(setq locations (cadr locations) |
1933 |
;; it there was a file number in the same line |
line (car locations) |
1934 |
(if (string-match "\\([0-9]+\\)|\\([^|bc]+\\)?[bc]" ali-line) |
col (nth 1 locations) |
1935 |
(let ((file-number (match-string 1 ali-line))) |
file (nth 2 locations) |
1936 |
(goto-char (point-min)) |
locations nil) |
1937 |
(re-search-forward "^D \\([a-zA-Z0-9_.-]+\\)" nil t |
(set 'locations (cdr locations)))) |
1938 |
(string-to-number file-number)) |
|
1939 |
(set 'file (match-string 1)) |
;; Find the file in the source path |
1940 |
) |
(set 'file (ada-get-ada-file-name file (ada-file-of identlist))) |
1941 |
;; Else get the nearest file |
|
1942 |
(set 'file (ada-declare-file-of identlist)) |
;; Kill the .ali buffer |
1943 |
) |
(kill-buffer (current-buffer)) |
|
) |
|
|
(error "No body found")) |
|
|
|
|
|
;; Else we were not on the declaration, find the place for it |
|
|
(string-match "\\([0-9]+\\)[a-zA-Z+]\\([0-9]+\\)[ *]" ali-line) |
|
|
(setq line (match-string 1 ali-line) |
|
|
col (match-string 2 ali-line) |
|
|
file (ada-declare-file-of identlist)) |
|
|
) |
|
1944 |
|
|
1945 |
;; Now go to the buffer |
;; Now go to the buffer |
1946 |
(ada-xref-change-buffer |
(ada-xref-change-buffer file |
1947 |
(ada-get-ada-file-name file (ada-file-of identlist)) |
(string-to-number line) |
1948 |
(string-to-number line) |
(1- (string-to-number col)) |
1949 |
(1- (string-to-number col)) |
identlist |
1950 |
identlist |
other-frame) |
|
other-frame) |
|
1951 |
)) |
)) |
1952 |
|
|
1953 |
|
(defun ada-find-in-src-path (identlist &optional other-frame) |
1954 |
|
"More general function for cross-references. |
1955 |
|
This 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 |
1957 |
|
exist. |
1958 |
|
This function attempts to find the possible declarations for the identifier |
1959 |
|
anywhere in the object path. |
1960 |
|
This command requires the external `egrep' program to be available. |
1961 |
|
|
1962 |
|
This works well when one is using an external librarie and wants |
1963 |
|
to find the declaration and documentation of the subprograms one is |
1964 |
|
is 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 |
|
|
2071 |
(defun ada-xref-change-buffer |
(defun ada-xref-change-buffer |
2072 |
(file line column identlist &optional other-frame) |
(file line column identlist &optional other-frame) |
2073 |
"Select and display FILE, at LINE and COLUMN. The new file is |
"Select and display FILE, at LINE and COLUMN. |
|
associated with the same project file as the one for IDENTLIST. |
|
2074 |
If we do not end on the same identifier as IDENTLIST, find the closest |
If we do not end on the same identifier as IDENTLIST, find the closest |
2075 |
match. Kills the .ali buffer at the end. |
match. Kills the .ali buffer at the end. |
2076 |
If OTHER-FRAME is non-nil, creates a new frame to show the file." |
If OTHER-FRAME is non-nil, creates a new frame to show the file." |
2077 |
|
|
2078 |
(let (prj-file |
(let (declaration-buffer) |
|
declaration-buffer |
|
|
(ali-buffer (current-buffer))) |
|
|
|
|
|
;; get the current project file for the source ada file |
|
|
(save-excursion |
|
|
(set-buffer (get-file-buffer (ada-file-of identlist))) |
|
|
(set 'prj-file ada-prj-prj-file)) |
|
2079 |
|
|
2080 |
;; Select and display the destination buffer |
;; Select and display the destination buffer |
2081 |
(if ada-xref-other-buffer |
(if ada-xref-other-buffer |
2088 |
(find-file file) |
(find-file file) |
2089 |
) |
) |
2090 |
|
|
|
;; If the new buffer is not already associated with a project file, do it |
|
|
(unless (my-local-variable-if-set-p 'ada-prj-prj-file (current-buffer)) |
|
|
(set (make-local-variable 'ada-prj-prj-file) prj-file)) |
|
|
|
|
2091 |
;; move the cursor to the correct position |
;; move the cursor to the correct position |
2092 |
(push-mark) |
(push-mark) |
2093 |
(goto-line line) |
(goto-line line) |
2098 |
;; this is probably the right one. |
;; this is probably the right one. |
2099 |
(unless (looking-at (ada-name-of identlist)) |
(unless (looking-at (ada-name-of identlist)) |
2100 |
(ada-xref-search-nearest (ada-name-of identlist))) |
(ada-xref-search-nearest (ada-name-of identlist))) |
2101 |
|
)) |
|
(kill-buffer ali-buffer))) |
|
2102 |
|
|
2103 |
|
|
2104 |
(defun ada-xref-search-nearest (name) |
(defun ada-xref-search-nearest (name) |
2225 |
|
|
2226 |
(save-some-buffers nil nil) |
(save-some-buffers nil nil) |
2227 |
|
|
2228 |
(ada-require-project-file) |
;; 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 |
|
|
2235 |
|
|
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 |
(delete-region (point-min) (point-max)) |
;; 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) |
2246 |
|
|
2247 |
;; Call the external process gnatstub |
;; Call the external process gnatstub |
2248 |
(let* ((gnatstub-opts (ada-treat-cmd-string ada-gnatstub-opts)) |
(let* ((gnatstub-opts (ada-treat-cmd-string ada-gnatstub-opts)) |
2249 |
(filename (buffer-file-name (car (cdr (buffer-list))))) |
(filename (buffer-file-name (car (buffer-list)))) |
2250 |
(output (concat (file-name-sans-extension filename) ".adb")) |
(output (concat (file-name-sans-extension filename) ".adb")) |
2251 |
(gnatstub-cmd (concat "gnatstub " gnatstub-opts " " filename)) |
(gnatstub-cmd (concat "gnatstub " gnatstub-opts " " filename)) |
2252 |
(buffer (get-buffer-create "*gnatstub*"))) |
(buffer (get-buffer-create "*gnatstub*"))) |
2273 |
|
|
2274 |
;; Else clean up the output |
;; Else clean up the output |
2275 |
|
|
|
;; Kill the temporary buffer created by find-file |
|
|
(set-buffer-modified-p nil) |
|
|
(kill-buffer (current-buffer)) |
|
|
|
|
2276 |
(if (file-exists-p output) |
(if (file-exists-p output) |
2277 |
(progn |
(progn |
2278 |
(find-file output) |
(find-file output) |
2283 |
) |
) |
2284 |
))) |
))) |
2285 |
|
|
|
|
|
2286 |
(defun ada-xref-initialize () |
(defun ada-xref-initialize () |
2287 |
"Function called by `ada-mode-hook' to initialize the ada-xref.el package. |
"Function called by `ada-mode-hook' to initialize the ada-xref.el package. |
2288 |
For instance, it creates the gnat-specific menus, sets some hooks for |
For instance, it creates the gnat-specific menus, sets some hooks for |
2303 |
|
|
2304 |
;; ----- Add to ada-mode-hook --------------------------------------------- |
;; ----- Add to ada-mode-hook --------------------------------------------- |
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 |
|
|
2319 |
;; Set the keymap once and for all, so that the keys set by the user in his |
;; Set the keymap once and for all, so that the keys set by the user in his |
2320 |
;; config file are not overwritten every time we open a new file. |
;; config file are not overwritten every time we open a new file. |
2321 |
(ada-add-ada-menu) |
(ada-add-ada-menu) |
2323 |
|
|
2324 |
(add-hook 'ada-mode-hook 'ada-xref-initialize) |
(add-hook 'ada-mode-hook 'ada-xref-initialize) |
2325 |
|
|
|
;; Use ddd as the default debugger if it was found |
|
|
(if (ada-find-file-in-dir "ddd" exec-path) |
|
|
(set 'ada-prj-default-debugger "ddd --tty -fullname -toolbar")) |
|
|
|
|
2326 |
;; Initializes the cross references to the runtime library |
;; Initializes the cross references to the runtime library |
2327 |
(ada-initialize-runtime-library) |
(ada-initialize-runtime-library "") |
2328 |
|
|
2329 |
;; Add these standard directories to the search path |
;; Add these standard directories to the search path |
2330 |
(set 'ada-search-directories |
(set 'ada-search-directories |