Commit | Line | Data |
---|---|---|
797aab3c GM |
1 | ;; @(#) ada-xref.el --- use Gnat for lookup and completion in Ada mode |
2 | ||
3 | ;; Copyright (C) 1994-1999 Free Software Foundation, Inc. | |
4 | ||
5 | ;; Author: Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de> | |
6 | ;; Rolf Ebert <ebert@inf.enst.fr> | |
7 | ;; Emmanuel Briot <briot@gnat.com> | |
8 | ;; Maintainer: Emmanuel Briot <briot@gnat.com> | |
9 | ;; Ada Core Technologies's version: $Revision: 1.75 $ | |
10 | ;; Keywords: languages ada xref | |
11 | ||
12 | ;; This file is not part of GNU Emacs. | |
13 | ||
14 | ;; This program is free software; you can redistribute it and/or modify | |
15 | ;; it under the terms of the GNU General Public License as published by | |
16 | ;; the Free Software Foundation; either version 2, or (at your option) | |
17 | ;; any later version. | |
18 | ||
19 | ;; This program is distributed in the hope that it will be useful, | |
20 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
21 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
22 | ;; GNU General Public License for more details. | |
23 | ||
24 | ;; You should have received a copy of the GNU General Public License | |
25 | ;; along with GNU Emacs; see the file COPYING. If not, write to | |
26 | ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
27 | ||
28 | ;;; Commentary: | |
29 | ;;; This Package provides a set of functions to use the output of the | |
30 | ;;; cross reference capabilities of the GNAT Ada compiler | |
31 | ;;; for lookup and completion in Ada mode. | |
32 | ;;; | |
33 | ;;; The functions provided are the following ones : | |
34 | ;;; - `ada-complete-identifier': completes the current identifier as much as | |
35 | ;;; possible, depending of the known identifier in the unit | |
36 | ;;; - `ada-point-and-xref': moves the mouse pointer and shows the declaration | |
37 | ;;; of the selected identifier (either in the same buffer or in another | |
38 | ;;; buffer | |
39 | ;;; - `ada-goto-declaration': shows the declaration of the selected | |
40 | ;;; identifier (the one under the cursor), either in the same buffer or in | |
41 | ;;; another buffer | |
42 | ;;; - `ada-goto-declaration-other-frame': same as previous, but opens a new | |
43 | ;; frame to show the declaration | |
44 | ;;; - `ada-compile-application': recompile your whole application, provided | |
45 | ;;; that a project file exists in your directory | |
46 | ;;; - `ada-run-application': run your application directly from emacs | |
47 | ;;; - `ada-reread-prj-file': force emacs to read your project file again. | |
48 | ;;; Otherwise, this file is only read the first time emacs needs some | |
49 | ;;; informations, which are then kept in memory | |
50 | ;;; - `ada-change-prj': change the prj file associated with a buffer | |
51 | ;;; - `ada-change-default-prj': change the default project file used for | |
52 | ;;; every new buffer | |
53 | ;;; | |
54 | ;;; If a file *.`adp' exists in the ada-file directory, then it is | |
55 | ;;; read for configuration informations. It is read only the first | |
56 | ;;; time a cross-reference is asked for, and is not read later. | |
57 | ||
58 | ;;; You need Emacs >= 20.2 to run this package | |
59 | ||
60 | ;; ----- Requirements ----------------------------------------------------- | |
61 | ||
62 | (require 'compile) | |
63 | (require 'comint) | |
64 | ||
65 | ;; ----- Dynamic byte compilation ----------------------------------------- | |
66 | (defvar byte-compile-dynamic nil) | |
67 | (make-local-variable 'byte-compile-dynamic) | |
68 | (setq byte-compile-dynamic t) | |
69 | ||
70 | ;; ------ Use variables | |
71 | (defcustom ada-xref-other-buffer t | |
72 | "*if non-nil then either use a buffer in the same frame or another frame. | |
73 | If Nil, always jump to the declaration in the same buffer" | |
74 | :type 'boolean :group 'ada) | |
75 | ||
76 | (defcustom ada-xref-create-ali t | |
77 | "*if non-nil, run gcc whenever it is needed | |
78 | if nil, the cross-reference mode will never run gcc" | |
79 | :type 'boolean :group 'ada) | |
80 | ||
81 | (defcustom ada-xref-confirm-compile nil | |
82 | "*if non-nil, ask for command confirmation before compiling or | |
83 | running the application" | |
84 | :type 'boolean :group 'ada) | |
85 | ||
86 | (defcustom ada-krunch-args "0" | |
87 | "*Maximum number of characters for filename create by gnatkr | |
88 | Set to 0, if you don't use crunched filenames." | |
89 | :type 'string :group 'ada) | |
90 | ||
91 | (defcustom ada-prj-default-comp-cmd "${cross_prefix}gcc -c -g -gnatq ${comp_opt} -I${src_dir}" | |
92 | "*Default command to be used to compile a single file. | |
93 | Emacs will add the filename at the end of this command. | |
94 | This is the same syntax as in the project file." | |
95 | :type 'string :group 'ada) | |
96 | ||
97 | (defcustom ada-prj-default-make-cmd | |
98 | (concat "${cross_prefix}gnatmake ${main} -aI${src_dir} -aO${obj_dir} " | |
99 | "-g -gnatq -cargs ${comp_opt} " | |
100 | "-bargs ${bind_opt} -largs ${link_opt}") | |
101 | "*Default command to be used to compile the application. | |
102 | This is the same syntax as in the project file." | |
103 | :type 'string :group 'ada) | |
104 | ||
105 | (defcustom ada-prj-default-project-file "" | |
106 | "*Non nil means always use this project file, no matter what the | |
107 | directory is. Emacs will not try to use the standard algorithm to | |
108 | find the project file. | |
109 | Note: you can use M-<TAB> in the customization buffer for completion" | |
110 | :type '(file :must-match t) :group 'ada) | |
111 | ||
112 | (defcustom ada-gnatstub-opts "-q -I${src_dir}" | |
113 | "*List of the options to pass to gnatsub when generating the body from | |
114 | a spec file. This has the same syntax as in the project file (with | |
115 | variable substitution" | |
116 | :type 'string :group 'ada) | |
117 | ||
118 | (defcustom ada-always-ask-project nil | |
119 | "*Non-nil means ask for the name of a project file to use when none is | |
120 | found by the standard algorithm. | |
121 | Nil means use default values when no project file was found") | |
122 | ||
123 | ;; ------- Nothing to be modified by the user below this | |
124 | (defvar ada-last-prj-file "" | |
125 | "Name of the last project file entered by the user, when the | |
126 | default algorithm did not find any possible project file") | |
127 | ||
128 | (defvar ada-check-switch " -gnats " | |
129 | "Switch added to the command line to check the current file") | |
130 | ||
131 | (defvar ada-project-file-extension ".adp" | |
132 | "The extension used for project files") | |
133 | ||
134 | (defconst is-windows (memq system-type (quote (windows-nt))) | |
135 | "true if we are running on windows NT or windows 95") | |
136 | ||
137 | (defvar ada-xref-pos-ring '() | |
138 | "This is the list of all the positions we went to with the | |
139 | cross-references features. This is used to go back to these positions.") | |
140 | ||
141 | (defconst ada-xref-pos-ring-max 16 | |
142 | "Number of positions kept in the list ada-xref-pos-ring") | |
143 | ||
144 | (defvar ada-operator-re | |
145 | "\\+\\|-\\|/\\|\\*\\|=\\|mod\\|and\\|not\\|or\\|xor\\|<=\\|<\\|>=\\|>" | |
146 | "Regexp to match for operators") | |
147 | ||
148 | (defvar ada-xref-default-prj-file nil | |
149 | "name of the default prj file, per directory. | |
150 | Every directory is potentially associated with a default project file | |
151 | If it is nil, then the first prj file loaded will be the default for this | |
152 | emacs session") | |
153 | ||
154 | ;; These variables will be overwritted by buffer-local variables | |
155 | (defvar ada-prj-prj-file nil | |
156 | "Name of the project file for the current ada buffer") | |
157 | (defvar ada-prj-src-dir nil | |
158 | "List of directories to look into for ada sources") | |
159 | (defvar ada-prj-obj-dir nil | |
160 | "List of directories to look into for object and .ali files") | |
161 | (defvar ada-prj-comp-opt nil | |
162 | "Switches to use on the command line for the default compile | |
163 | command (gcc)") | |
164 | (defvar ada-prj-bind-opt nil | |
165 | "Switches to use on the command line for the default bind | |
166 | command (gnatbind)") | |
167 | (defvar ada-prj-link-opt nil | |
168 | "Switches to use on the command line for the default link | |
169 | command (gnatlink)") | |
170 | (defvar ada-prj-comp-cmd nil | |
171 | "Command to use to compile the current file only") | |
172 | (defvar ada-prj-make-cmd nil | |
173 | "Command to use to compile the whole current application") | |
174 | (defvar ada-prj-run-cmd nil | |
175 | "Command to use to run the current application") | |
176 | (defvar ada-prj-debug-cmd nil | |
177 | "Command to use to run the debugger") | |
178 | (defvar ada-prj-main nil | |
179 | "Name of the main programm of the current application") | |
180 | (defvar ada-prj-remote-machine nil | |
181 | "Name of the machine to log on before a compilation") | |
182 | (defvar ada-prj-cross-prefix nil | |
183 | "Prefix to be added to the gnatmake, gcc, ... commands when | |
184 | using a cross-compilation environment. | |
185 | A '-' is automatically added at the end if not already present. | |
186 | For instance, the compiler is called `ada-prj-cross-prefix'gnatmake") | |
187 | ||
188 | ;; ----- Keybindings ------------------------------------------------------ | |
189 | ||
190 | (defun ada-add-keymap () | |
191 | "Add new key bindings when using ada-xrel.el" | |
192 | (interactive) | |
193 | (if ada-xemacs | |
194 | (progn | |
195 | (define-key ada-mode-map '(shift button3) 'ada-point-and-xref) | |
196 | (define-key ada-mode-map '(control tab) 'ada-complete-identifier)) | |
197 | (define-key ada-mode-map [C-tab] 'ada-complete-identifier) | |
198 | (define-key ada-mode-map [S-mouse-3] 'ada-point-and-xref)) | |
199 | ||
200 | (define-key ada-mode-map "\C-co" 'ff-find-other-file) | |
201 | (define-key ada-mode-map "\C-c5\C-d" 'ada-goto-declaration-other-frame) | |
202 | (define-key ada-mode-map "\C-c\C-d" 'ada-goto-declaration) | |
203 | (define-key ada-mode-map "\C-c\C-s" 'ada-xref-goto-previous-reference) | |
204 | (define-key ada-mode-map "\C-c\C-x" 'ada-reread-prj-file) | |
205 | (define-key ada-mode-map [f10] 'next-error) | |
206 | (define-key ada-mode-map "\C-c\C-c" 'ada-compile-application) | |
207 | (define-key ada-mode-map "\C-cb" 'ada-buffer-list) | |
208 | (define-key ada-mode-map "\C-cc" 'ada-change-prj) | |
209 | (define-key ada-mode-map "\C-cd" 'ada-change-default-prj) | |
210 | (define-key ada-mode-map "\C-cg" 'ada-gdb-application) | |
211 | (define-key ada-mode-map "\C-cr" 'ada-run-application) | |
212 | (define-key ada-mode-map "\C-c\C-o" 'ada-goto-parent) | |
213 | (define-key ada-mode-map "\C-c\C-r" 'ada-find-references) | |
214 | (define-key ada-mode-map "\C-c\C-v" 'ada-check-current) | |
215 | ) | |
216 | ||
217 | ;; ----- Menus -------------------------------------------------------------- | |
218 | (defun ada-add-ada-menu () | |
219 | "Add some items to the standard Ada mode menu (the menu defined in | |
220 | ada-mode.el)" | |
221 | (interactive) | |
222 | ||
223 | (if ada-xemacs | |
224 | (progn | |
225 | (add-menu-button '("Ada") ["Check file" ada-check-current t] "Goto") | |
226 | (add-menu-button '("Ada") ["Compile file" ada-compile-current t] "Goto") | |
227 | (add-menu-button '("Ada") ["Build" ada-compile-application t] "Goto") | |
228 | (add-menu-button '("Ada") ["Run" ada-run-application t] "Goto") | |
229 | (add-menu-button '("Ada") ["Debug" ada-gdb-application t] "Goto") | |
230 | (add-menu-button '("Ada") ["--" nil t] "Goto") | |
231 | (add-submenu '("Ada") '("Project" | |
232 | ["Associate" ada-change-prj t] | |
233 | ["Set Default" ada-set-default-project-file t] | |
234 | ["List" ada-buffer-list t]) | |
235 | "Goto") | |
236 | (add-menu-button '("Ada" "Goto") ["Goto Parent Unit" ada-goto-parent t] | |
237 | "Next compilation error") | |
238 | (add-menu-button '("Ada" "Goto") ["Goto References to any entity" ada-find-any-references t] | |
239 | "Next compilation error") | |
240 | (add-menu-button '("Ada" "Goto") ["List References" ada-find-references t] | |
241 | "Next compilation error") | |
242 | (add-menu-button '("Ada" "Goto") ["Goto Declaration Other Frame" | |
243 | ada-goto-declaration-other-frame t] | |
244 | "Next compilation error") | |
245 | (add-menu-button '("Ada" "Goto") ["Goto Declaration/Body" ada-goto-declaration t] | |
246 | "Next compilation error") | |
247 | (add-menu-button '("Ada" "Goto") ["Goto Previous Reference" ada-xref-goto-previous-reference t] | |
248 | "Next compilation error") | |
249 | (add-menu-button '("Ada" "Goto") ["--" nil t] | |
250 | "Next compilation error") | |
251 | (add-menu-button '("Ada" "Edit") ["Complete Identifier" ada-complete-identifier t] | |
252 | "Indent Line") | |
253 | (add-menu-button '("Ada" "Edit") ["--------" nil t] | |
254 | "Indent Line") | |
255 | (add-menu-button '("Ada" "Help") ["Gnat User Guide" (info "gnat_ug")]) | |
256 | (add-menu-button '("Ada" "Help") ["Gnat Reference Manual" | |
257 | (info "gnat_rm")]) | |
258 | (add-menu-button '("Ada" "Help") ["Gcc Documentation" (info "gcc")]) | |
259 | (add-menu-button '("Ada" "Help") ["Gdb Documentation" (info "gdb")]) | |
260 | ) | |
261 | ||
262 | ;; for Emacs | |
263 | (define-key-after (lookup-key ada-mode-map [menu-bar Ada]) [Check] | |
264 | '("Check file" . ada-check-current) 'Customize) | |
265 | (define-key-after (lookup-key ada-mode-map [menu-bar Ada]) [Compile] | |
266 | '("Compile file" . ada-compile-current) 'Check) | |
267 | (define-key-after (lookup-key ada-mode-map [menu-bar Ada]) [Build] | |
268 | '("Build" . ada-compile-application) 'Compile) | |
269 | (define-key-after (lookup-key ada-mode-map [menu-bar Ada]) [Run] | |
270 | '("Run" . ada-run-application) 'Build) | |
271 | (define-key-after (lookup-key ada-mode-map [menu-bar Ada]) [Debug] | |
272 | '("Debug" . ada-gdb-application) 'Run) | |
273 | (define-key-after (lookup-key ada-mode-map [menu-bar Ada]) [rem] | |
274 | '("--" . nil) 'Debug) | |
275 | (define-key-after (lookup-key ada-mode-map [menu-bar Ada]) [Project] | |
276 | (cons "Project" (easy-menu-create-menu | |
277 | "Project" | |
278 | '(["Associate" ada-change-prj t] | |
279 | ["Set Default" ada-set-default-project-file t] | |
280 | ["List" ada-buffer-list t]))) | |
281 | 'rem) | |
282 | ||
283 | (let ((help-submenu (lookup-key ada-mode-map [menu-bar Ada Help])) | |
284 | (goto-submenu (lookup-key ada-mode-map [menu-bar Ada Goto])) | |
285 | (edit-submenu (lookup-key ada-mode-map [menu-bar Ada Edit]))) | |
286 | ||
287 | (define-key help-submenu [Gnat_ug] | |
288 | '("Gnat User Guide" . (lambda() (interactive) (info "gnat_ug")))) | |
289 | (define-key help-submenu [Gnat_rm] | |
290 | '("Gnat Reference Manual" . (lambda() (interactive) (info "gnat_rm")))) | |
291 | (define-key help-submenu [Gcc] | |
292 | '("Gcc Documentation" . (lambda() (interactive) (info "gcc")))) | |
293 | (define-key help-submenu [gdb] | |
294 | '("Ada Aware Gdb Documentation" . (lambda() (interactive) (info "gdb")))) | |
295 | (define-key goto-submenu [rem] '("----" . nil)) | |
296 | (define-key goto-submenu [Parent] '("Goto Parent Unit" . ada-goto-parent)) | |
297 | (define-key goto-submenu [References-any] | |
298 | '("Goto References to any entity" . ada-find-any-references)) | |
299 | (define-key goto-submenu [References] | |
300 | '("List References" . ada-find-references)) | |
301 | (define-key goto-submenu [Prev] | |
302 | '("Goto Previous Reference" . ada-xref-goto-previous-reference)) | |
303 | (define-key goto-submenu [Decl-other] | |
304 | '("Goto Declaration Other Frame" . ada-goto-declaration-other-frame)) | |
305 | (define-key goto-submenu [Decl] | |
306 | '("Goto Declaration/Body" . ada-goto-declaration)) | |
307 | ||
308 | (define-key edit-submenu [rem] '("----" . nil)) | |
309 | (define-key edit-submenu [Complete] '("Complete Identifier" | |
310 | . ada-complete-identifier)) | |
311 | ) | |
312 | )) | |
313 | ||
314 | ;; ----- Utilities ------------------------------------------------- | |
315 | ||
316 | (defun ada-require-project-file () | |
317 | "If no project file is assigned to this buffer, load one" | |
318 | (if (not ( my-local-variable-if-set-p 'ada-prj-src-dir (current-buffer))) | |
319 | (ada-parse-prj-file (ada-prj-find-prj-file)))) | |
320 | ||
321 | (defun my-local-variable-if-set-p (variable &optional buffer) | |
322 | (and (local-variable-p variable buffer) | |
323 | (save-excursion | |
324 | (set-buffer buffer) | |
325 | (symbol-value variable)))) | |
326 | ||
327 | (defun ada-xref-push-pos (filename position) | |
328 | "Push (FILENAME, POSITION) on the position ring for cross-references" | |
329 | (setq ada-xref-pos-ring (cons (list position filename) ada-xref-pos-ring)) | |
330 | (if (> (length ada-xref-pos-ring) ada-xref-pos-ring-max) | |
331 | (setcdr (nthcdr (1- ada-xref-pos-ring-max) ada-xref-pos-ring) nil))) | |
332 | ||
333 | (defun ada-xref-goto-previous-reference () | |
334 | "Go to the previous cross-reference we were on" | |
335 | (interactive) | |
336 | (if ada-xref-pos-ring | |
337 | (progn | |
338 | (let ((pos (car ada-xref-pos-ring))) | |
339 | (setq ada-xref-pos-ring (cdr ada-xref-pos-ring)) | |
340 | (find-file (car (cdr pos))) | |
341 | (goto-char (car pos)))))) | |
342 | ||
343 | (defun ada-convert-file-name (name) | |
344 | "Function to convert from the buffer file name to the name given in | |
345 | argument to the ada-compile-current function. This function is | |
346 | overridden on VMS to convert from VMS filename to Unix filenames" | |
347 | name) | |
348 | ||
349 | (defun ada-set-default-project-file (name) | |
350 | (interactive "fName of project file:") | |
351 | (set 'ada-prj-default-project-file name) | |
352 | (ada-reread-prj-file t) | |
353 | ) | |
354 | ||
355 | ;; ------ Handling the project file ----------------------------- | |
356 | ||
357 | (defun ada-replace-substring (cmd-string search-for replace-with) | |
358 | "Replace all instances of SEARCH-FOR with REPLACE-WITH in | |
359 | string CMD-STRING" | |
360 | (while (string-match search-for cmd-string) | |
361 | (setq cmd-string (replace-match replace-with t t cmd-string))) | |
362 | cmd-string) | |
363 | ||
364 | (defun ada-treat-cmd-string (cmd-string) | |
365 | "Replace meta-sequences like ${...} with the appropriate value in CMD-STRING. | |
366 | The current buffer must be the one where all local variable are definied (that | |
367 | is the ada source)" | |
368 | ||
369 | (if ( my-local-variable-if-set-p 'ada-prj-src-dir (current-buffer)) | |
370 | (if (string-match "\\(-[^-\$I]*I\\)\${src_dir}" cmd-string) | |
371 | (progn | |
372 | (let ((str-def (substring cmd-string (match-beginning 1) | |
373 | (match-end 1)))) | |
374 | (setq cmd-string | |
375 | (ada-replace-substring cmd-string | |
376 | "\\(-[^-\$I]*I\\)\${src_dir}" | |
377 | (mapconcat | |
378 | (lambda (x) (concat str-def x)) | |
379 | ada-prj-src-dir " "))))))) | |
380 | (if ( my-local-variable-if-set-p 'ada-prj-obj-dir (current-buffer)) | |
381 | (if (string-match "\\(-[^-\$O]*O\\)\${obj_dir}" cmd-string) | |
382 | (progn | |
383 | (let ((str-def (substring cmd-string (match-beginning 1) | |
384 | (match-end 1)))) | |
385 | (setq cmd-string | |
386 | (ada-replace-substring cmd-string | |
387 | "\\(-[^-\$O]*O\\)\${obj_dir}" | |
388 | (mapconcat | |
389 | (lambda (x) (concat str-def x)) | |
390 | ada-prj-obj-dir | |
391 | " "))))))) | |
392 | (if ( my-local-variable-if-set-p 'ada-prj-remote-machine (current-buffer)) | |
393 | (setq cmd-string | |
394 | (ada-replace-substring cmd-string "\${remote_machine}" | |
395 | ada-prj-remote-machine))) | |
396 | (if ( my-local-variable-if-set-p 'ada-prj-comp-opt (current-buffer)) | |
397 | (setq cmd-string | |
398 | (ada-replace-substring cmd-string "\${comp_opt}" | |
399 | ada-prj-comp-opt))) | |
400 | (if ( my-local-variable-if-set-p 'ada-prj-bind-opt (current-buffer)) | |
401 | (setq cmd-string | |
402 | (ada-replace-substring cmd-string "\${bind_opt}" | |
403 | ada-prj-bind-opt))) | |
404 | (if ( my-local-variable-if-set-p 'ada-prj-link-opt (current-buffer)) | |
405 | (setq cmd-string | |
406 | (ada-replace-substring cmd-string "\${link_opt}" | |
407 | ada-prj-link-opt))) | |
408 | (if ( my-local-variable-if-set-p 'ada-prj-main (current-buffer)) | |
409 | (setq cmd-string | |
410 | (ada-replace-substring cmd-string "\${main}" | |
411 | ada-prj-main))) | |
412 | (if ( my-local-variable-if-set-p 'ada-prj-cross-prefix (current-buffer)) | |
413 | (setq cmd-string | |
414 | (ada-replace-substring cmd-string "\${cross_prefix}" | |
415 | ada-prj-cross-prefix))) | |
416 | cmd-string) | |
417 | ||
418 | ||
419 | (defun ada-prj-find-prj-file (&optional no-user-question) | |
420 | "Find the prj file associated with the current buffer | |
421 | The rules are the following ones : | |
422 | - If the buffer is already associated with a prj file, use this one | |
423 | - else if there's a default prj file for the same directory use it | |
424 | - else if a prj file with the same filename exists, use it | |
425 | - else if there's only one prj file in the directory, use it | |
426 | - else if there are more than one prj file, ask the user | |
427 | - else if there is no prj file and no-user-question is nil, ask the user | |
428 | for the project file to use." | |
429 | (let* ((current-file (buffer-file-name)) | |
430 | (first-choice (concat | |
431 | (file-name-sans-extension current-file) | |
432 | ada-project-file-extension)) | |
433 | (dir (file-name-directory current-file)) | |
434 | ||
435 | ;; on Emacs 20.2, directory-files does not work if | |
436 | ;; parse-sexp-lookup-properties is set | |
437 | (parse-sexp-lookup-properties nil) | |
438 | (prj-files (directory-files | |
439 | dir t | |
440 | (concat ".*" (regexp-quote ada-project-file-extension) "$"))) | |
441 | (choice nil) | |
442 | (default (assoc dir ada-xref-default-prj-file)) | |
443 | ) | |
444 | ||
445 | (cond | |
446 | ||
447 | ((my-local-variable-if-set-p 'ada-prj-prj-file (current-buffer)) | |
448 | ada-prj-prj-file) | |
449 | ||
450 | (default ;; directory default project file | |
451 | (cdr default)) | |
452 | ||
453 | ;; global default project file | |
454 | ((and ada-prj-default-project-file | |
455 | (not (string= ada-prj-default-project-file ""))) | |
456 | ada-prj-default-project-file) | |
457 | ||
458 | ((file-exists-p first-choice) | |
459 | first-choice) | |
460 | ||
461 | ((= (length prj-files) 1) | |
462 | (car prj-files)) | |
463 | ||
464 | ((> (length prj-files) 1) | |
465 | ;; more than one possible prj file => ask the user | |
466 | (with-output-to-temp-buffer "*choice list*" | |
467 | (princ "There are more than one possible project file. Which one should\n") | |
468 | (princ "I use ?\n\n") | |
469 | (princ " no. file name \n") | |
470 | (princ " --- ------------------------\n") | |
471 | (let ((counter 1)) | |
472 | (while (<= counter (length prj-files)) | |
473 | (princ (format " %2d) %s\n" | |
474 | counter | |
475 | (nth (1- counter) prj-files))) | |
476 | (setq counter (1+ counter)) | |
477 | ) ; end of while | |
478 | ) ; end of let | |
479 | ) ; end of with-output-to ... | |
480 | (setq choice nil) | |
481 | (while (or | |
482 | (not choice) | |
483 | (not (integerp choice)) | |
484 | (< choice 1) | |
485 | (> choice (length prj-files))) | |
486 | (setq choice (string-to-int | |
487 | (read-from-minibuffer "Enter No. of your choice: " | |
488 | )))) | |
489 | (nth (1- choice) prj-files)) | |
490 | ||
491 | ((= (length prj-files) 0) | |
492 | ;; no project file found. Ask the user about it (the default value | |
493 | ;; is the last one the user entered. | |
494 | (if (or no-user-question (not ada-always-ask-project)) | |
495 | nil | |
496 | (setq ada-last-prj-file | |
497 | (read-file-name "project file:" nil ada-last-prj-file)) | |
498 | (if (string= ada-last-prj-file "") nil ada-last-prj-file)) | |
499 | ) | |
500 | ))) | |
501 | ||
502 | ||
503 | (defun ada-parse-prj-file (prj-file) | |
504 | "Reads and parses the PRJ-FILE file if it was found. | |
505 | The current buffer should be the ada-file buffer" | |
506 | ||
507 | (let ((tmp-src-dir nil) | |
508 | (tmp-obj-dir nil) | |
509 | (tmp-comp-opt nil) | |
510 | (tmp-bind-opt nil) | |
511 | (tmp-link-opt nil) | |
512 | (tmp-main nil) | |
513 | (tmp-comp-cmd nil) | |
514 | (tmp-make-cmd nil) | |
515 | (tmp-run-cmd nil) | |
516 | (tmp-debug-cmd nil) | |
517 | (tmp-remote-machine nil) | |
518 | (tmp-cross-prefix nil) | |
519 | (tmp-cd-cmd (if prj-file | |
520 | (concat "cd " (file-name-directory prj-file) " && ") | |
521 | (concat "cd " (file-name-directory (buffer-file-name (current-buffer))) " && "))) | |
522 | (ada-buffer (current-buffer)) | |
523 | ) | |
524 | ;; tries to find a project file in the current directory | |
525 | (if prj-file | |
526 | (progn | |
527 | (find-file prj-file) | |
528 | ||
529 | ;; first look for the src_dir lines | |
530 | (widen) | |
531 | (goto-char (point-min)) | |
532 | (while | |
533 | (re-search-forward "^src_dir=\\(.*\\)" nil t) | |
534 | (progn | |
535 | (setq tmp-src-dir (cons | |
536 | (file-name-as-directory | |
537 | (match-string 1)) | |
538 | tmp-src-dir | |
539 | )))) | |
540 | ;; then for the obj_dir lines | |
541 | (goto-char (point-min)) | |
542 | (while (re-search-forward "^obj_dir=\\(.*\\)" nil t) | |
543 | (setq tmp-obj-dir (cons | |
544 | (file-name-as-directory | |
545 | (match-string 1)) | |
546 | tmp-obj-dir | |
547 | ))) | |
548 | ||
549 | ;; then for the options lines | |
550 | (goto-char (point-min)) | |
551 | (if (re-search-forward "^comp_opt=\\(.*\\)" nil t) | |
552 | (setq tmp-comp-opt (match-string 1))) | |
553 | (goto-char (point-min)) | |
554 | (if (re-search-forward "^bind_opt=\\(.*\\)" nil t) | |
555 | (setq tmp-bind-opt (match-string 1))) | |
556 | (goto-char (point-min)) | |
557 | (if (re-search-forward "^link_opt=\\(.*\\)" nil t) | |
558 | (setq tmp-link-opt (match-string 1))) | |
559 | (goto-char (point-min)) | |
560 | (if (re-search-forward "^main=\\(.*\\)" nil t) | |
561 | (setq tmp-main (match-string 1))) | |
562 | (goto-char (point-min)) | |
563 | (if (re-search-forward "^comp_cmd=\\(.*\\)" nil t) | |
564 | (setq tmp-comp-cmd (match-string 1))) | |
565 | (goto-char (point-min)) | |
566 | (if (re-search-forward "^remote_machine=\\(.*\\)" nil t) | |
567 | (setq tmp-remote-machine (match-string 1))) | |
568 | (goto-char (point-min)) | |
569 | (if (re-search-forward "^cross_prefix=\\(.*\\)" nil t) | |
570 | (setq tmp-cross-prefix (match-string 1))) | |
571 | (goto-char (point-min)) | |
572 | (if (re-search-forward "^make_cmd=\\(.*\\)" nil t) | |
573 | (setq tmp-make-cmd (match-string 1))) | |
574 | (goto-char (point-min)) | |
575 | (if (re-search-forward "^run_cmd=\\(.*\\)" nil t) | |
576 | (setq tmp-run-cmd (match-string 1))) | |
577 | (goto-char (point-min)) | |
578 | (if (re-search-forward "^debug_cmd=\\(.*\\)" nil t) | |
579 | (setq tmp-debug-cmd (match-string 1))) | |
580 | ||
581 | ;; kills the project file buffer, and go back to the ada buffer | |
582 | (kill-buffer nil) | |
583 | (set-buffer ada-buffer) | |
584 | )) | |
585 | ||
586 | ;; creates local variables (with default values if needed) | |
587 | (set (make-local-variable 'ada-prj-prj-file) prj-file) | |
588 | ||
589 | (set (make-local-variable 'ada-prj-src-dir) | |
590 | (if tmp-src-dir (reverse tmp-src-dir) '("./"))) | |
591 | ||
592 | (set (make-local-variable 'ada-prj-obj-dir) | |
593 | (if tmp-obj-dir (reverse tmp-obj-dir) '("./"))) | |
594 | ||
595 | (set (make-local-variable 'ada-prj-comp-opt) | |
596 | (if tmp-comp-opt tmp-comp-opt "")) | |
597 | ||
598 | (set (make-local-variable 'ada-prj-bind-opt) | |
599 | (if tmp-bind-opt tmp-bind-opt "")) | |
600 | ||
601 | (set (make-local-variable 'ada-prj-link-opt) | |
602 | (if tmp-link-opt tmp-link-opt "")) | |
603 | ||
604 | (set (make-local-variable 'ada-prj-cross-prefix) | |
605 | (if tmp-cross-prefix | |
606 | (if (or (string= tmp-cross-prefix "") | |
607 | (= (aref tmp-cross-prefix (1- (length tmp-cross-prefix))) ?-)) | |
608 | tmp-cross-prefix | |
609 | (concat tmp-cross-prefix "-")) | |
610 | "")) | |
611 | ||
612 | (set (make-local-variable 'ada-prj-main) | |
613 | (if tmp-main tmp-main | |
614 | (substring (buffer-file-name) 0 -4))) | |
615 | ||
616 | (set (make-local-variable 'ada-prj-remote-machine) | |
617 | (ada-treat-cmd-string | |
618 | (if tmp-remote-machine tmp-remote-machine ""))) | |
619 | ||
620 | (set (make-local-variable 'ada-prj-comp-cmd) | |
621 | (ada-treat-cmd-string | |
622 | (if tmp-comp-cmd tmp-comp-cmd | |
623 | (concat tmp-cd-cmd ada-prj-default-comp-cmd)))) | |
624 | ||
625 | (set (make-local-variable 'ada-prj-make-cmd) | |
626 | (ada-treat-cmd-string | |
627 | (if tmp-make-cmd tmp-make-cmd | |
628 | (concat tmp-cd-cmd ada-prj-default-make-cmd)))) | |
629 | ||
630 | (set (make-local-variable 'ada-prj-run-cmd) | |
631 | (ada-treat-cmd-string | |
632 | (if tmp-run-cmd tmp-run-cmd | |
633 | (if is-windows "${main}.exe" "${main}")))) | |
634 | ||
635 | (set (make-local-variable 'ada-prj-debug-cmd) | |
636 | (ada-treat-cmd-string | |
637 | (if tmp-debug-cmd tmp-debug-cmd | |
638 | (if is-windows | |
639 | "${cross_prefix}gdb ${main}.exe" | |
640 | "${cross_prefix}gdb ${main}")))) | |
641 | ||
642 | ;; Add each directory in src_dir to the default prj list | |
643 | (if prj-file | |
644 | (mapcar (lambda (x) | |
645 | (if (not (assoc (expand-file-name x) | |
646 | ada-xref-default-prj-file)) | |
647 | (setq ada-xref-default-prj-file | |
648 | (cons (cons (expand-file-name x) | |
649 | prj-file) | |
650 | ada-xref-default-prj-file)))) | |
651 | ada-prj-src-dir)) | |
652 | ||
653 | ;; Add the directories to the search path for ff-find-other-file | |
654 | ;; Do not add the '/' or '\' at the end | |
655 | (set (make-local-variable 'ff-search-directories) | |
656 | (append (mapcar 'directory-file-name ada-prj-src-dir) | |
657 | ada-search-directories)) | |
658 | ||
659 | ;; Sets up the compilation-search-path so that Emacs is able to | |
660 | ;; go to the source of the errors in a compilation buffer | |
661 | (setq compilation-search-path ada-prj-src-dir) | |
662 | ||
663 | )) | |
664 | ||
665 | ||
666 | (defun ada-find-references (&optional pos) | |
667 | "Find every references to the entity under POS | |
668 | Calls gnatfind to find every references" | |
669 | (interactive "") | |
670 | (unless pos | |
671 | (set 'pos (point))) | |
672 | (ada-require-project-file) | |
673 | ||
674 | (let* ((identlist (ada-read-identifier pos)) | |
675 | (alifile (ada-get-ali-file-name (ada-file-of identlist)))) | |
676 | ||
677 | (set-buffer (get-file-buffer (ada-file-of identlist))) | |
678 | ||
679 | ;; if the file is more recent than the executable | |
680 | (if (or (buffer-modified-p (current-buffer)) | |
681 | (file-newer-than-file-p (ada-file-of identlist) alifile)) | |
682 | (ada-find-any-references (ada-name-of identlist) | |
683 | (ada-file-of identlist) | |
684 | nil nil) | |
685 | (ada-find-any-references (ada-name-of identlist) | |
686 | (ada-file-of identlist) | |
687 | (ada-line-of identlist) | |
688 | (ada-column-of identlist)))) | |
689 | ) | |
690 | ||
691 | (defun ada-find-any-references (entity &optional file line column) | |
692 | "Search for references to any entity" | |
693 | (interactive "sEntity name: ") | |
694 | (ada-require-project-file) | |
695 | ||
696 | (let* ((command (concat "gnatfind -rf " entity | |
697 | (if file (concat ":" (file-name-nondirectory file))) | |
698 | (if line (concat ":" line)) | |
699 | (if column (concat ":" column))))) | |
700 | ||
701 | ;; If a project file is defined, use it | |
702 | (if (my-local-variable-if-set-p 'ada-prj-prj-file (current-buffer)) | |
703 | (setq command (concat command " -p" ada-prj-prj-file))) | |
704 | ||
705 | (compile-internal command | |
706 | "No more references" | |
707 | "gnatfind") | |
708 | ||
709 | ;; Hide the "Compilation" menu | |
710 | (save-excursion | |
711 | (set-buffer "*gnatfind*") | |
712 | (local-unset-key [menu-bar compilation-menu])) | |
713 | ) | |
714 | ) | |
715 | ||
716 | (defun ada-buffer-list () | |
717 | "Display a buffer with all the ada-mode buffers and their associated prj file" | |
718 | (interactive) | |
719 | (save-excursion | |
720 | (set-buffer (get-buffer-create "*Buffer List*")) | |
721 | (setq buffer-read-only nil) | |
722 | (erase-buffer) | |
723 | (setq standard-output (current-buffer)) | |
724 | (princ "The following line is a list showing the associations between | |
725 | directories and project file. It has the format : ((directory_1 . project_file1) | |
726 | (directory2 . project_file2)...)\n\n") | |
727 | (princ ada-xref-default-prj-file) | |
728 | (princ "\n | |
729 | Buffer Mode Project file | |
730 | ------ ---- ------------ | |
731 | \n") | |
732 | (let ((bl (buffer-list))) | |
733 | (while bl | |
734 | (let* ((buffer (car bl)) | |
735 | (buffer-name (buffer-name buffer)) | |
736 | this-buffer-mode-name | |
737 | this-buffer-project-file) | |
738 | (save-excursion | |
739 | (set-buffer buffer) | |
740 | (setq this-buffer-mode-name | |
741 | (if (eq buffer standard-output) | |
742 | "Buffer Menu" mode-name)) | |
743 | (if (string= this-buffer-mode-name | |
744 | "Ada") | |
745 | (setq this-buffer-project-file | |
746 | (if ( my-local-variable-if-set-p 'ada-prj-prj-file | |
747 | (current-buffer)) | |
748 | (expand-file-name ada-prj-prj-file) | |
749 | "")))) | |
750 | (if (string= this-buffer-mode-name | |
751 | "Ada") | |
752 | (progn | |
753 | (princ (format "%-19s " buffer-name)) | |
754 | (princ (format "%-6s " this-buffer-mode-name)) | |
755 | (princ this-buffer-project-file) | |
756 | (princ "\n") | |
757 | )) | |
758 | ) ;; end let* | |
759 | (setq bl (cdr bl)) | |
760 | ) ;; end while | |
761 | );; end let | |
762 | ) ;; end save-excursion | |
763 | (display-buffer "*Buffer List*") | |
764 | (other-window 1) | |
765 | ) | |
766 | ||
767 | (defun ada-change-prj (filename) | |
768 | "Change the project file associated with the current buffer" | |
769 | (interactive "fproject file:") | |
770 | ||
771 | ;; make sure we are using an Ada file | |
772 | (if (not (string= mode-name "Ada")) | |
773 | (error "You must be in ada-mode to use this function")) | |
774 | ||
775 | ;; create the local variable if necessay | |
776 | (if (not ( my-local-variable-if-set-p 'ada-prj-prj-file (current-buffer))) | |
777 | (make-local-variable 'ada-prj-prj-file)) | |
778 | ||
779 | ;; ask the user for the new file name | |
780 | (setq ada-prj-prj-file filename) | |
781 | ||
782 | ;; force emacs to reread the prj file next-time | |
783 | (ada-reread-prj-file) | |
784 | ) | |
785 | ||
786 | (defun ada-change-default-prj (filename) | |
787 | "Change the default project file used for all ada files from the | |
788 | current directory" | |
789 | (interactive "ffile name:") | |
790 | (let ((dir (file-name-directory (buffer-file-name))) | |
791 | (prj (expand-file-name filename))) | |
792 | ||
793 | ;; If the directory is already associated with a project file | |
794 | (if (assoc dir ada-xref-default-prj-file) | |
795 | ||
796 | (setcdr (assoc dir ada-xref-default-prj-file) prj) | |
797 | ;; Else create a new element in the list | |
798 | (add-to-list 'ada-xref-default-prj-file (list dir prj))) | |
799 | ||
800 | ;; Reparse the project file | |
801 | (ada-parse-prj-file ada-prj-default-project-file))) | |
802 | ||
803 | ||
804 | ;; ----- Identlist manipulation ------------------------------------------- | |
805 | ;; An identlist is a vector that is used internally to reference an identifier | |
806 | ;; To facilitate its use, we provide the following macros | |
807 | ||
808 | (defmacro ada-make-identlist () (make-vector 8 nil)) | |
809 | (defmacro ada-name-of (identlist) (list 'aref identlist 0)) | |
810 | (defmacro ada-line-of (identlist) (list 'aref identlist 1)) | |
811 | (defmacro ada-column-of (identlist) (list 'aref identlist 2)) | |
812 | (defmacro ada-file-of (identlist) (list 'aref identlist 3)) | |
813 | (defmacro ada-ali-index-of (identlist) (list 'aref identlist 4)) | |
814 | (defmacro ada-declare-file-of (identlist) (list 'aref identlist 5)) | |
815 | (defmacro ada-references-of (identlist) (list 'aref identlist 6)) | |
816 | (defmacro ada-on-declaration (identlist) (list 'aref identlist 7)) | |
817 | ||
818 | (defmacro ada-set-name (identlist name) (list 'aset identlist 0 name)) | |
819 | (defmacro ada-set-line (identlist line) (list 'aset identlist 1 line)) | |
820 | (defmacro ada-set-column (identlist col) (list 'aset identlist 2 col)) | |
821 | (defmacro ada-set-file (identlist file) (list 'aset identlist 3 file)) | |
822 | (defmacro ada-set-ali-index (identlist index) (list 'aset identlist 4 index)) | |
823 | (defmacro ada-set-declare-file (identlist file) (list 'aset identlist 5 file)) | |
824 | (defmacro ada-set-references (identlist ref) (list 'aset identlist 6 ref)) | |
825 | (defmacro ada-set-on-declaration (ident value) (list 'aset ident 7 value)) | |
826 | ||
827 | (defsubst ada-get-ali-buffer (file) | |
828 | "Reads the ali file into a new buffer, and returns this buffer's name" | |
829 | (find-file-noselect (ada-get-ali-file-name file))) | |
830 | ||
831 | ||
832 | ||
833 | ;; ----- Identifier Completion -------------------------------------------- | |
834 | (defun ada-complete-identifier (pos) | |
835 | "Tries to complete the identifier around POS. | |
836 | The feature is only available if the files where compiled not using the -gnatx | |
837 | option" | |
838 | (interactive "d") | |
839 | (ada-require-project-file) | |
840 | ||
841 | ;; Initialize function-local variablesand jump to the .ali buffer | |
842 | ;; Note that for regexp search is case insensitive too | |
843 | (let* ((curbuf (current-buffer)) | |
844 | (identlist (ada-read-identifier pos)) | |
845 | (sofar (concat "^[0-9]+[a-zA-Z][0-9]+[ *]\\(" | |
846 | (regexp-quote (ada-name-of identlist)) | |
847 | "[a-zA-Z0-9_]*\\)")) | |
848 | (completed nil) | |
849 | (symalist nil) | |
850 | (insertpos nil)) | |
851 | ||
852 | ;; we are already in the .ali buffer | |
853 | (goto-char (point-max)) | |
854 | ||
855 | ;; build an alist of possible completions | |
856 | (while (re-search-backward sofar nil t) | |
857 | (setq symalist (cons (cons (match-string 1) nil) symalist))) | |
858 | ||
859 | (setq completed (try-completion "" symalist)) | |
860 | ||
861 | ;; kills .ali buffer | |
862 | (kill-buffer nil) | |
863 | ||
864 | ;; deletes the incomplete identifier in the buffer | |
865 | (set-buffer curbuf) | |
866 | (looking-at "[a-zA-Z0-9_]+") | |
867 | (replace-match "") | |
868 | ;; inserts the completed symbol | |
869 | (insert completed) | |
870 | )) | |
871 | ||
872 | ;; ----- Cross-referencing ---------------------------------------- | |
873 | ||
874 | (defun ada-point-and-xref () | |
875 | "Calls `mouse-set-point' and then `ada-goto-declaration'." | |
876 | (interactive) | |
877 | (mouse-set-point last-input-event) | |
878 | (ada-goto-declaration (point))) | |
879 | ||
880 | (defun ada-goto-declaration (pos) | |
881 | "Displays the declaration of the identifier around POS. | |
882 | The declaration is shown in another buffer if `ada-xref-other-buffer' is non-nil" | |
883 | (interactive "d") | |
884 | (ada-require-project-file) | |
885 | (push-mark pos) | |
886 | (ada-xref-push-pos (buffer-file-name) pos) | |
887 | (ada-find-in-ali (ada-read-identifier pos))) | |
888 | ||
889 | (defun ada-goto-declaration-other-frame (pos) | |
890 | "Displays the declaration of the identifier around point. | |
891 | The declation is shown in another frame if `ada-xref-other-buffer' is non-nil" | |
892 | (interactive "d") | |
893 | (ada-require-project-file) | |
894 | (push-mark pos) | |
895 | (ada-xref-push-pos (buffer-file-name) pos) | |
896 | (ada-find-in-ali (ada-read-identifier pos) t)) | |
897 | ||
898 | (defun ada-compile (command) | |
899 | "Start a compilation, on the machine specified in the project file, | |
900 | using command COMMAND" | |
901 | ||
902 | (if (and (my-local-variable-if-set-p 'ada-prj-remote-machine (current-buffer)) | |
903 | (not (string= ada-prj-remote-machine ""))) | |
904 | (set 'command | |
905 | (concat "rsh " ada-prj-remote-machine " '" | |
906 | command "'"))) | |
907 | (compile command)) | |
908 | ||
909 | (defun ada-compile-application () | |
910 | "Compiles the whole application, using the command find in the gnat.prj file" | |
911 | (interactive) | |
912 | (ada-require-project-file) | |
913 | ||
914 | ;; prompt for command to execute | |
915 | (ada-compile | |
916 | (if ada-xref-confirm-compile | |
917 | (read-from-minibuffer "enter command to compile: " | |
918 | ada-prj-make-cmd) | |
919 | ada-prj-make-cmd)) | |
920 | ) | |
921 | ||
922 | (defun ada-compile-current () | |
923 | "Recompile the current file" | |
924 | (interactive) | |
925 | (ada-require-project-file) | |
926 | ||
927 | ;; prompt for command to execute | |
928 | (ada-compile | |
929 | (if ada-xref-confirm-compile | |
930 | (read-from-minibuffer "enter command to compile: " | |
931 | (concat | |
932 | ada-prj-comp-cmd " " (ada-convert-file-name (buffer-file-name)))) | |
933 | (concat ada-prj-comp-cmd " " (ada-convert-file-name (buffer-file-name))))) | |
934 | ) | |
935 | ||
936 | (defun ada-check-current () | |
937 | "Recompile the current file" | |
938 | (interactive) | |
939 | (ada-require-project-file) | |
940 | ||
941 | ;; prompt for command to execute | |
942 | (let ((command (concat ada-prj-comp-cmd ada-check-switch | |
943 | (ada-convert-file-name (buffer-file-name))))) | |
944 | (compile | |
945 | (if ada-xref-confirm-compile | |
946 | (read-from-minibuffer "enter command to compile: " command) | |
947 | command)))) | |
948 | ||
949 | ||
950 | (defun ada-run-application () | |
951 | "Run the application" | |
952 | (interactive) | |
953 | (ada-require-project-file) | |
954 | ||
955 | (if (and (my-local-variable-if-set-p 'ada-prj-cross-prefix (current-buffer)) | |
956 | (not (string= ada-prj-cross-prefix ""))) | |
957 | (error "This feature is not supported yet for cross-compilation environments")) | |
958 | ||
959 | (let ((command ada-prj-run-cmd) | |
960 | (buffer (current-buffer))) | |
961 | ;; Search the command name if necessary | |
962 | (if (not (my-local-variable-if-set-p 'ada-prj-run-cmd (current-buffer))) | |
963 | (setq command (file-name-sans-extension (buffer-name))) | |
964 | ) | |
965 | ||
966 | ;; Ask for the arguments to the command | |
967 | (setq command | |
968 | (read-from-minibuffer "Enter command to execute: " | |
969 | command)) | |
970 | ||
971 | ;; Run the command | |
972 | (save-excursion | |
973 | (set-buffer (get-buffer-create "*run*")) | |
974 | (goto-char (point-max)) | |
975 | (insert "\nRunning " command "\n\n") | |
976 | (make-comint "run" | |
977 | (comint-arguments command 0 0) | |
978 | nil | |
979 | (comint-arguments command 1 nil)) | |
980 | ) | |
981 | (display-buffer "*run*") | |
982 | ||
983 | ;; change to buffer *run* for interactive programs | |
984 | (other-window 1) | |
985 | (switch-to-buffer "*run*") | |
986 | ) | |
987 | ) | |
988 | ||
989 | ||
990 | (defun ada-gdb-application () | |
991 | "Run the application" | |
992 | (interactive) | |
993 | ||
994 | (require 'gud) | |
995 | (let ((buffer (current-buffer)) | |
996 | gdb-buffer) | |
997 | (ada-require-project-file) | |
998 | ||
999 | (if (and (my-local-variable-if-set-p 'ada-prj-cross-prefix buffer) | |
1000 | (not (string= ada-prj-cross-prefix ""))) | |
1001 | (error "This feature is not supported yet for cross-compilation environments")) | |
1002 | ||
1003 | ;; If the command to use was given in the project file | |
1004 | (if (my-local-variable-if-set-p 'ada-prj-debug-cmd buffer) | |
1005 | (gdb ada-prj-debug-cmd) | |
1006 | ;; Else the user will have to enter the command himself | |
1007 | (gdb "") | |
1008 | ) | |
1009 | ||
1010 | (set 'gdb-buffer (current-buffer)) | |
1011 | ||
1012 | ;; Switch back to the source buffer | |
1013 | ;; and Activate the debug part in the contextual menu | |
1014 | (switch-to-buffer buffer) | |
1015 | ||
1016 | (if (functionp 'gud-make-debug-menu) | |
1017 | (gud-make-debug-menu)) | |
1018 | ||
1019 | ;; Warning: on Emacs >= 20.3.8, same-window-regexps includes gud-*, | |
1020 | ;; so the following call to display buffer will select the | |
1021 | ;; buffer instead of displaying it in another window | |
1022 | ;; This is why the second argument to display-buffer is 't' | |
1023 | (display-buffer gdb-buffer t) | |
1024 | )) | |
1025 | ||
1026 | ||
1027 | (defun ada-reread-prj-file (&optional for-all-buffer) | |
1028 | "Forces emacs to read the project file again. | |
1029 | Otherwise, this file is only read once, and never read again | |
1030 | If `for-all-buffer' is non-nil, or the function was called with \C-u prefix, | |
1031 | then do this for every opened buffer" | |
1032 | (interactive "P") | |
1033 | (if for-all-buffer | |
1034 | ||
1035 | ;; do this for every buffer | |
1036 | (mapcar (lambda (x) | |
1037 | (save-excursion | |
1038 | (set-buffer x) | |
1039 | ;; if we have the ada-mode and there is a real file | |
1040 | ;; associated with the buffer | |
1041 | (if (and (string= mode-name "Ada") | |
1042 | (buffer-file-name)) | |
1043 | (progn | |
1044 | (kill-local-variable 'ada-prj-src-dir) | |
1045 | (kill-local-variable 'ada-prj-obj-dir) | |
1046 | (ada-parse-prj-file (ada-prj-find-prj-file)))) | |
1047 | )) | |
1048 | (buffer-list)) | |
1049 | ||
1050 | ;; else do this just for the current buffer | |
1051 | (kill-local-variable 'ada-prj-src-dir) | |
1052 | (kill-local-variable 'ada-prj-obj-dir) | |
1053 | (ada-parse-prj-file (ada-prj-find-prj-file))) | |
1054 | ) | |
1055 | ||
1056 | ;; ------ Private routines | |
1057 | ||
1058 | (defun ada-xref-current (file &optional ali-file-name) | |
1059 | "Creates a new ali file from the FILE source file, | |
1060 | assuming the ali file will be called ALI-FILE-NAME. | |
1061 | Uses the function `compile' to execute the commands | |
1062 | defined in the project file." | |
1063 | ;; kill old buffer | |
1064 | (if (and ali-file-name | |
1065 | (get-file-buffer ali-file-name)) | |
1066 | (kill-buffer (get-file-buffer ali-file-name))) | |
1067 | ;; prompt for command to execute | |
1068 | (setq compile-command (concat ada-prj-comp-cmd | |
1069 | " " | |
1070 | file)) | |
1071 | (compile | |
1072 | (if ada-xref-confirm-compile | |
1073 | (read-from-minibuffer "enter command to execute gcc: " | |
1074 | compile-command) | |
1075 | compile-command)) | |
1076 | ) | |
1077 | ||
1078 | (defun ada-first-non-nil (list) | |
1079 | "Returns the first non-nil element of the list" | |
1080 | (cond | |
1081 | ((not list) nil) | |
1082 | ((car list) (car list)) | |
1083 | (t (ada-first-non-nil (cdr list))) | |
1084 | )) | |
1085 | ||
1086 | ||
1087 | (defun ada-find-ali-file-in-dir (file) | |
1088 | "Search for FILE in obj_dir | |
1089 | The current buffer must be the Ada file" | |
1090 | (ada-first-non-nil | |
1091 | (mapcar (lambda (x) | |
1092 | (if (file-exists-p (concat (file-name-directory x) | |
1093 | file)) | |
1094 | (concat (file-name-directory x) file) | |
1095 | nil)) | |
1096 | ada-prj-obj-dir)) | |
1097 | ) | |
1098 | ||
1099 | (defun ada-get-ali-file-name (file) | |
1100 | "create the ali file name for the ada-file FILE | |
1101 | The file is searched for in every directory shown in the | |
1102 | obj_dir lines of the project file" | |
1103 | ||
1104 | ;; This function has to handle the special case of non-standard | |
1105 | ;; file names (i.e. not .adb or .ads) | |
1106 | ;; The trick is the following: | |
1107 | ;; 1- replace the extension of the current file with .ali, | |
1108 | ;; and look for this file | |
1109 | ;; 2- If this file is found: | |
1110 | ;; grep the "^U" lines, and make sure we are not reading the | |
1111 | ;; .ali file for a spec file. If we are, go to step 3. | |
1112 | ;; 3- If the file is not found or step 2 failed: | |
1113 | ;; find the name of the "other file", ie the body, and look | |
1114 | ;; for its associated .ali file by subtituing the extension | |
1115 | ||
1116 | (save-excursion | |
1117 | (set-buffer (get-file-buffer file)) | |
1118 | (let ((short-ali-file-name | |
1119 | (concat (file-name-sans-extension (file-name-nondirectory file)) | |
1120 | ".ali")) | |
1121 | (ali-file-name "")) | |
1122 | ;; First step | |
1123 | ;; we take the first possible completion | |
1124 | (setq ali-file-name (ada-find-ali-file-in-dir short-ali-file-name)) | |
1125 | ||
1126 | ;; If we have found the .ali file, but the source file was a spec | |
1127 | ;; with a non-standard name, search the .ali file for the body if any, | |
1128 | ;; since the xref information is more complete in that one | |
1129 | (unless ali-file-name | |
1130 | (if (not (string= (file-name-extension file) ".ads")) | |
1131 | (let ((is-spec nil) | |
1132 | (specs ada-spec-suffixes) | |
1133 | body-ali) | |
1134 | (while specs | |
1135 | (if (string-match (concat (regexp-quote (car specs)) "$") | |
1136 | file) | |
1137 | (set 'is-spec t)) | |
1138 | (set 'specs (cdr specs))) | |
1139 | ||
1140 | (if is-spec | |
1141 | (set 'body-ali | |
1142 | (ada-find-ali-file-in-dir | |
1143 | (concat (file-name-sans-extension | |
1144 | (file-name-nondirectory | |
1145 | (ada-other-file-name))) | |
1146 | ".ali")))) | |
1147 | (if body-ali | |
1148 | (set 'ali-file-name body-ali)))) | |
1149 | ||
1150 | ;; else we did not find the .ali file | |
1151 | ;; Second chance: in case the files do not have standard names (such | |
1152 | ;; as for instance file_s.ada and file_b.ada), try to go to the | |
1153 | ;; other file and look for its ali file | |
1154 | (setq short-ali-file-name | |
1155 | (concat (file-name-sans-extension | |
1156 | (file-name-nondirectory (ada-other-file-name))) | |
1157 | ".ali")) | |
1158 | (setq ali-file-name (ada-find-ali-file-in-dir short-ali-file-name)) | |
1159 | ||
1160 | ;; If still not found, try to recompile the file | |
1161 | (if (not ali-file-name) | |
1162 | (progn | |
1163 | ;; recompile only if the user asked for this | |
1164 | (if ada-xref-create-ali | |
1165 | (ada-xref-current file ali-file-name)) | |
1166 | (error "Ali file not found. Recompile your file"))) | |
1167 | ) | |
1168 | ||
1169 | ;; same if the .ali file is too old and we must recompile it | |
1170 | (if (and (file-newer-than-file-p file ali-file-name) | |
1171 | ada-xref-create-ali) | |
1172 | (ada-xref-current file ali-file-name)) | |
1173 | ||
1174 | ;; else returns the correct absolute file name | |
1175 | (expand-file-name ali-file-name)) | |
1176 | )) | |
1177 | ||
1178 | (defun ada-get-ada-file-name (file original-file) | |
1179 | "Create the complete file name (+directory) for FILE | |
1180 | The original file (where the user was) is ORIGINAL-FILE. | |
1181 | Search in project file for possible paths" | |
1182 | ||
1183 | (save-excursion | |
1184 | (set-buffer (get-file-buffer original-file)) | |
1185 | ;; we choose the first possible completion and we | |
1186 | ;; return the absolute file name | |
1187 | (let ((filename | |
1188 | (ada-first-non-nil (mapcar (lambda (x) | |
1189 | (if (file-exists-p (concat (file-name-directory x) | |
1190 | (file-name-nondirectory file))) | |
1191 | (concat (file-name-directory x) | |
1192 | (file-name-nondirectory file)) | |
1193 | nil)) | |
1194 | ada-prj-src-dir)))) | |
1195 | ||
1196 | (if filename | |
1197 | (expand-file-name filename) | |
1198 | (error (concat | |
1199 | (file-name-nondirectory file) | |
1200 | " not found in src_dir. Please check your project file"))) | |
1201 | ||
1202 | ))) | |
1203 | ||
1204 | (defun ada-find-file-number-in-ali (file) | |
1205 | "Returns the file number for FILE in the associated ali file" | |
1206 | (set-buffer (ada-get-ali-buffer file)) | |
1207 | (goto-char (point-min)) | |
1208 | ||
1209 | (let ((begin (re-search-forward "^D"))) | |
1210 | (beginning-of-line) | |
1211 | (re-search-forward (concat "^D " (file-name-nondirectory file))) | |
1212 | (count-lines begin (point)))) | |
1213 | ||
1214 | (defun ada-read-identifier (pos) | |
1215 | "Returns the identlist around POS and switch to the .ali buffer" | |
1216 | ||
1217 | ;; If there's a compilation in progress, it's probably because the | |
1218 | ;; .ali file didn't exist. So we should wait... | |
1219 | (if compilation-in-progress | |
1220 | (progn | |
1221 | (message "Compilation in progress. Try again when it is finished") | |
1222 | (set 'quit-flag t))) | |
1223 | ||
1224 | ;; If at end of buffer (e.g the buffer is empty), error | |
1225 | (if (>= (point) (point-max)) | |
1226 | (error "No identifier on point")) | |
1227 | ||
1228 | ;; goto first character of the identifier/operator (skip backward < and > | |
1229 | ;; since they are part of multiple character operators | |
1230 | (goto-char pos) | |
1231 | (skip-chars-backward "a-zA-Z0-9_<>") | |
1232 | ||
1233 | ;; check if it really is an identifier | |
1234 | (if (ada-in-comment-p) | |
1235 | (error "Inside comment")) | |
1236 | ||
1237 | (let (identifier identlist) | |
1238 | ;; Just in front of a string => we could have an operator declaration, | |
1239 | ;; as in "+", "-", .. | |
1240 | (if (= (char-after) ?\") | |
1241 | (forward-char 1)) | |
1242 | ||
1243 | ;; if looking at an operator | |
1244 | (if (looking-at ada-operator-re) | |
1245 | (progn | |
1246 | (if (and (= (char-before) ?\") | |
1247 | (= (char-after (+ (length (match-string 0)) (point))) ?\")) | |
1248 | (forward-char -1)) | |
1249 | (set 'identifier (concat "\"" (match-string 0) "\""))) | |
1250 | ||
1251 | (if (ada-in-string-p) | |
1252 | (error "Inside string or character constant")) | |
1253 | (if (looking-at (concat ada-keywords "[^a-zA-Z_]")) | |
1254 | (error "No cross-reference available for reserved keyword")) | |
1255 | (if (looking-at "[a-zA-Z0-9_]+") | |
1256 | (set 'identifier (match-string 0)) | |
1257 | (error "No identifier around"))) | |
1258 | ||
1259 | ;; Build the identlist | |
1260 | (set 'identlist (ada-make-identlist)) | |
1261 | (ada-set-name identlist (downcase identifier)) | |
1262 | (ada-set-line identlist | |
1263 | (number-to-string (count-lines (point-min) (point)))) | |
1264 | (ada-set-column identlist | |
1265 | (number-to-string (1+ (current-column)))) | |
1266 | (ada-set-file identlist (buffer-file-name)) | |
1267 | identlist | |
1268 | )) | |
1269 | ||
1270 | (defun ada-get-all-references (identlist) | |
1271 | "Completes and returns the identlist with the information extracted | |
1272 | from the ali file (definition file and places where it is referenced)" | |
1273 | ||
1274 | (let ((ali-buffer (ada-get-ali-buffer (ada-file-of identlist))) | |
1275 | declaration-found) | |
1276 | (set-buffer ali-buffer) | |
1277 | (goto-char (point-min)) | |
1278 | (ada-set-on-declaration identlist nil) | |
1279 | ||
1280 | ;; First attempt: we might already be on the declaration of the identifier | |
1281 | ;; We want to look for the declaration only in a definite interval (after | |
1282 | ;; the "^X ..." line for the current file, and before the next "^X" line | |
1283 | ||
1284 | (if (re-search-forward | |
1285 | (concat "^X [0-9]+ " (file-name-nondirectory (ada-file-of identlist))) | |
1286 | nil t) | |
1287 | (let ((bound (save-excursion (re-search-forward "^X " nil t)))) | |
1288 | (set 'declaration-found | |
1289 | (re-search-forward | |
1290 | (concat "^" (ada-line-of identlist) | |
1291 | "." (ada-column-of identlist) | |
1292 | "[ *]" (regexp-quote (ada-name-of identlist)) | |
1293 | " \\(.*\\)$") bound t)) | |
1294 | (if declaration-found | |
1295 | (ada-set-on-declaration identlist t)) | |
1296 | )) | |
1297 | ||
1298 | ;; If declaration is still nil, then we were not on a declaration, and | |
1299 | ;; have to fall back on other algorithms | |
1300 | ||
1301 | (unless declaration-found | |
1302 | ||
1303 | ;; Since we alread know the number of the file, search for a direct | |
1304 | ;; reference to it | |
1305 | (goto-char (point-min)) | |
1306 | (set 'declaration-found t) | |
1307 | (ada-set-ali-index | |
1308 | identlist | |
1309 | (number-to-string (ada-find-file-number-in-ali | |
1310 | (ada-file-of identlist)))) | |
1311 | (unless (re-search-forward (concat (ada-ali-index-of identlist) | |
1312 | "|\\([0-9]+.[0-9]+ \\)*" | |
1313 | (ada-line-of identlist) | |
1314 | "[^0-9]" | |
1315 | (ada-column-of identlist)) | |
1316 | nil t) | |
1317 | ||
1318 | ;; if we did not find it, it may be because the first reference | |
1319 | ;; is not required to have a 'unit_number|' item included. | |
1320 | ;; Or maybe we are already on the declaration... | |
1321 | (unless (re-search-forward (concat "^\\([a-zA-Z0-9_.\"]+[ *]\\)*" | |
1322 | (ada-line-of identlist) | |
1323 | "[^0-9]" | |
1324 | (ada-column-of identlist)) | |
1325 | nil t) | |
1326 | ||
1327 | ;; If still not found, then either the declaration is unknown | |
1328 | ;; or the source file has been modified since the ali file was | |
1329 | ;; created | |
1330 | (set 'declaration-found nil) | |
1331 | ) | |
1332 | ) | |
1333 | ||
1334 | ;; Last check to be completly sure we have found the correct line (the | |
1335 | ;; ali might not be up to date for instance) | |
1336 | (if declaration-found | |
1337 | (progn | |
1338 | (beginning-of-line) | |
1339 | ;; while we have a continuation line, go up one line | |
1340 | (while (looking-at "^\\.") | |
1341 | (previous-line 1)) | |
1342 | (unless (looking-at (concat "[0-9]+.[0-9]+[ *]" | |
1343 | (ada-name-of identlist) " ")) | |
1344 | (set 'declaration-found nil)))) | |
1345 | ||
1346 | ;; Still no success ! The ali file must be too old, and we need to | |
1347 | ;; use a basic algorithm based on guesses. Note that this only happens | |
1348 | ;; if the user does not want us to automatically recompile files | |
1349 | ;; automatically | |
1350 | (unless declaration-found | |
1351 | (unless (ada-xref-find-in-modified-ali identlist) | |
1352 | ;; no more idea to find the declaration. Give up | |
1353 | (progn | |
1354 | (kill-buffer ali-buffer) | |
1355 | (error (concat "No declaration of " (ada-name-of identlist) | |
1356 | " found.")) | |
1357 | ))) | |
1358 | ) | |
1359 | ||
1360 | ||
1361 | ;; Now that we have found a suitable line in the .ali file, get the | |
1362 | ;; information available | |
1363 | (beginning-of-line) | |
1364 | (if declaration-found | |
1365 | (let ((current-line (buffer-substring | |
1366 | (point) (save-excursion (end-of-line) (point))))) | |
1367 | (save-excursion | |
1368 | (next-line 1) | |
1369 | (beginning-of-line) | |
1370 | (while (looking-at "^\\.\\(.*\\)") | |
1371 | (set 'current-line (concat current-line (match-string 1))) | |
1372 | (next-line 1)) | |
1373 | ) | |
1374 | ||
1375 | (if (re-search-backward "^X [0-9]+ \\([a-zA-Z0-9_.-]+\\)" nil t) | |
1376 | (ada-set-declare-file | |
1377 | identlist | |
1378 | (ada-get-ada-file-name (match-string 1) | |
1379 | (ada-file-of identlist)))) | |
1380 | ||
1381 | (ada-set-references identlist current-line) | |
1382 | )) | |
1383 | )) | |
1384 | ||
1385 | (defun ada-xref-find-in-modified-ali (identlist) | |
1386 | "Find the matching position for IDENTLIST in the current ali buffer. | |
1387 | This function is only called when the file was not up-to-date, so we need | |
1388 | to make some guesses. | |
1389 | This function is disabled for operators, and only works for identifiers" | |
1390 | ||
1391 | (unless (= (string-to-char (ada-name-of identlist)) ?\") | |
1392 | (progn | |
1393 | (let ((declist '()) ;;; ( (line_in_ali_file line_in_ada) ( ... )) | |
1394 | (my-regexp (concat "[ *]" | |
1395 | (regexp-quote (ada-name-of identlist)) " ")) | |
1396 | (line-ada "--") | |
1397 | (col-ada "--") | |
1398 | (line-ali 0) | |
1399 | (len 0) | |
1400 | (choice 0)) | |
1401 | ||
1402 | (goto-char (point-max)) | |
1403 | (while (re-search-backward my-regexp nil t) | |
1404 | (save-excursion | |
1405 | (set 'line-ali (count-lines (point-min) (point))) | |
1406 | (beginning-of-line) | |
1407 | ;; have a look at the line and column numbers | |
1408 | (if (looking-at "^\\([0-9]+\\).\\([0-9]+\\)[ *]") | |
1409 | (progn | |
1410 | (setq line-ada (match-string 1)) | |
1411 | (setq col-ada (match-string 2))) | |
1412 | (setq line-ada "--") | |
1413 | (setq col-ada "--") | |
1414 | ) | |
1415 | ;; construct a list with the file names and the positions within | |
1416 | (if (re-search-backward "^X [0-9]+ \\([a-zA-Z0-9._-]+\\)" nil t) | |
1417 | (add-to-list | |
1418 | 'declist (list line-ali (match-string 1) line-ada col-ada)) | |
1419 | ) | |
1420 | ) | |
1421 | ) | |
1422 | ||
1423 | ;; how many possible declarations have we found ? | |
1424 | (setq len (length declist)) | |
1425 | (cond | |
1426 | ;; none => error | |
1427 | ((= len 0) | |
1428 | (kill-buffer (current-buffer)) | |
1429 | (error (concat "No declaration of " | |
1430 | (ada-name-of identlist) | |
1431 | " recorded in .ali file"))) | |
1432 | ||
1433 | ;; one => should be the right one | |
1434 | ((= len 1) | |
1435 | (goto-line (caar declist))) | |
1436 | ||
1437 | ;; more than one => display choice list | |
1438 | (t | |
1439 | (with-output-to-temp-buffer "*choice list*" | |
1440 | ||
1441 | (princ "Identifier is overloaded and Xref information is not up to date.\n") | |
1442 | (princ "Possible declarations are:\n\n") | |
1443 | (princ " no. in file at line col\n") | |
1444 | (princ " --- --------------------- ---- ----\n") | |
1445 | (let ((counter 1)) | |
1446 | (while (<= counter len) | |
1447 | (princ (format " %2d) %-21s %4s %4s\n" | |
1448 | counter | |
1449 | (ada-get-ada-file-name | |
1450 | (nth 1 (nth (1- counter) declist)) | |
1451 | (ada-file-of identlist)) | |
1452 | (nth 2 (nth (1- counter) declist)) | |
1453 | (nth 3 (nth (1- counter) declist)) | |
1454 | )) | |
1455 | (setq counter (1+ counter)) | |
1456 | ) ; end of while | |
1457 | ) ; end of let | |
1458 | ) ; end of with-output-to ... | |
1459 | (setq choice nil) | |
1460 | (while (or | |
1461 | (not choice) | |
1462 | (not (integerp choice)) | |
1463 | (< choice 1) | |
1464 | (> choice len)) | |
1465 | (setq choice (string-to-int | |
1466 | (read-from-minibuffer "Enter No. of your choice: ")))) | |
1467 | (goto-line (car (nth (1- choice) declist))) | |
1468 | )))))) | |
1469 | ||
1470 | ||
1471 | (defun ada-find-in-ali (identlist &optional other-frame) | |
1472 | "Look in the .ali file for the definition of the identifier | |
1473 | if OTHER-FRAME is non nil, and `ada-xref-other-buffer' is non nil, | |
1474 | opens a new window to show the declaration" | |
1475 | ||
1476 | (ada-get-all-references identlist) | |
1477 | (let ((ali-line (ada-references-of identlist)) | |
1478 | file line col) | |
1479 | ||
1480 | ;; If we were on a declaration, go to the body | |
1481 | (if (ada-on-declaration identlist) | |
1482 | (if (string-match "\\([0-9]+\\)[bc]\\([0-9]+\\)" ali-line) | |
1483 | (progn | |
1484 | (setq line (match-string 1 ali-line) | |
1485 | col (match-string 2 ali-line)) | |
1486 | ;; it there was a file number in the same line | |
1487 | (if (string-match "\\([0-9]+\\)|\\([^|bc]+\\)?[bc]" ali-line) | |
1488 | (let ((file-number (match-string 1 ali-line))) | |
1489 | (goto-char (point-min)) | |
1490 | (re-search-forward "^D \\([a-zA-Z0-9_.-]+\\)" nil t | |
1491 | (string-to-number file-number)) | |
1492 | (set 'file (match-string 1)) | |
1493 | ) | |
1494 | ;; Else get the nearest file | |
1495 | (re-search-backward "^X [0-9]+ \\([a-zA-Z0-9_.-]+\\)" nil t) | |
1496 | (set 'file (match-string 1)) | |
1497 | ) | |
1498 | ) | |
1499 | (error "No body found")) | |
1500 | ||
1501 | ;; Else we were not on the declaration, find the place for it | |
1502 | (string-match "\\([0-9]+\\)[a-zA-Z+]\\([0-9]+\\)[ *]" ali-line) | |
1503 | (setq line (match-string 1 ali-line) | |
1504 | col (match-string 2 ali-line) | |
1505 | file (ada-declare-file-of identlist)) | |
1506 | ) | |
1507 | ||
1508 | ;; Now go to the buffer | |
1509 | (ada-xref-change-buffer | |
1510 | (ada-get-ada-file-name file (ada-file-of identlist)) | |
1511 | (string-to-number line) | |
1512 | (1- (string-to-number col)) | |
1513 | identlist | |
1514 | other-frame) | |
1515 | )) | |
1516 | ||
1517 | (defun ada-xref-change-buffer | |
1518 | (file line column identlist &optional other-frame) | |
1519 | "Select and display FILE, at LINE and COLUMN. The new file is | |
1520 | associated with the same project file as the one for IDENTLIST. | |
1521 | If we do not end on the same identifier as IDENTLIST, find the closest | |
1522 | match. Kills the .ali buffer at the end" | |
1523 | ||
1524 | (let (prj-file | |
1525 | declaration-buffer | |
1526 | (ali-buffer (current-buffer))) | |
1527 | ||
1528 | ;; get the current project file for the source ada file | |
1529 | (save-excursion | |
1530 | (set-buffer (get-file-buffer (ada-file-of identlist))) | |
1531 | (set 'prj-file ada-prj-prj-file)) | |
1532 | ||
1533 | ;; Select and display the destination buffer | |
1534 | (if ada-xref-other-buffer | |
1535 | (if other-frame | |
1536 | (find-file-other-frame file) | |
1537 | (set 'declaration-buffer (find-file-noselect file)) | |
1538 | (set-buffer declaration-buffer) | |
1539 | (switch-to-buffer-other-window declaration-buffer) | |
1540 | ) | |
1541 | (find-file file) | |
1542 | ) | |
1543 | ||
1544 | ;; If the new buffer is not already associated with a project file, do it | |
1545 | (unless (my-local-variable-if-set-p 'ada-prj-prj-file (current-buffer)) | |
1546 | (progn | |
1547 | (make-local-variable 'ada-prj-prj-file) | |
1548 | (set 'ada-prj-prj-file prj-file))) | |
1549 | ||
1550 | ;; move the cursor to the correct position | |
1551 | (push-mark) | |
1552 | (goto-line line) | |
1553 | (move-to-column column) | |
1554 | ||
1555 | ;; If we are not on the identifier, the ali file was not up-to-date. | |
1556 | ;; Try to find the nearest position where the identifier is found, | |
1557 | ;; this is probably the right one. | |
1558 | (unless (looking-at (ada-name-of identlist)) | |
1559 | (ada-xref-search-nearest (ada-name-of identlist))) | |
1560 | ||
1561 | (kill-buffer ali-buffer))) | |
1562 | ||
1563 | ||
1564 | (defun ada-xref-search-nearest (name) | |
1565 | "Searches for NAME nearest to the position recorded in the Xref file. | |
1566 | It returns the position of the declaration in the buffer or nil if not found." | |
1567 | (let ((orgpos (point)) | |
1568 | (newpos nil) | |
1569 | (diff nil)) | |
1570 | ||
1571 | (goto-char (point-max)) | |
1572 | ||
1573 | ;; loop - look for all declarations of name in this file | |
1574 | (while (search-backward name nil t) | |
1575 | ||
1576 | ;; check if it really is a complete Ada identifier | |
1577 | (if (and | |
1578 | (not (save-excursion | |
1579 | (goto-char (match-end 0)) | |
1580 | (looking-at "_"))) | |
1581 | (not (ada-in-string-or-comment-p)) | |
1582 | (or | |
1583 | ;; variable declaration ? | |
1584 | (save-excursion | |
1585 | (skip-chars-forward "a-zA-Z_0-9" ) | |
1586 | (ada-goto-next-non-ws) | |
1587 | (looking-at ":[^=]")) | |
1588 | ;; procedure, function, task or package declaration ? | |
1589 | (save-excursion | |
1590 | (ada-goto-previous-word) | |
1591 | (looking-at "\\<[pP][rR][oO][cC][eE][dD][uU][rR][eE]\\>\\|\\<[fF][uU][nN][cC][tT][iI][oO][nN]\\>\\|\\<[tT][yY][pP][eE]\\>\\|\\<[tT][aA][sS][kK]\\>\\|\\<[pP][aA][cC][kK][aA][gG][eE]\\>\\|\\<[bB][oO][dD][yY]\\>")))) | |
1592 | ||
1593 | ;; check if it is nearer than the ones before if any | |
1594 | (if (or (not diff) | |
1595 | (< (abs (- (point) orgpos)) diff)) | |
1596 | (progn | |
1597 | (setq newpos (point) | |
1598 | diff (abs (- newpos orgpos)))))) | |
1599 | ) | |
1600 | ||
1601 | (if newpos | |
1602 | (progn | |
1603 | (message "ATTENTION: this declaration is only a (good) guess ...") | |
1604 | (goto-char newpos)) | |
1605 | nil))) | |
1606 | ||
1607 | ||
1608 | ;; Find the parent library file of the current file | |
1609 | (defun ada-goto-parent () | |
1610 | "go to the parent library file" | |
1611 | (interactive) | |
1612 | (ada-require-project-file) | |
1613 | ||
1614 | (let ((buffer (ada-get-ali-buffer (buffer-file-name))) | |
1615 | (unit-name nil) | |
1616 | (body-name nil) | |
1617 | (ali-name nil)) | |
1618 | (save-excursion | |
1619 | (set-buffer buffer) | |
1620 | (goto-char (point-min)) | |
1621 | (re-search-forward "^U \\([^ \t%]+\\)%[bs][ \t]+\\([^ \t]+\\)") | |
1622 | (setq unit-name (match-string 1)) | |
1623 | (if (not (string-match "\\(.*\\)\\.[^.]+" unit-name)) | |
1624 | (progn | |
1625 | (kill-buffer buffer) | |
1626 | (error "No parent unit !")) | |
1627 | (setq unit-name (match-string 1 unit-name)) | |
1628 | ) | |
1629 | ||
1630 | ;; look for the file name for the parent unit specification | |
1631 | (goto-char (point-min)) | |
1632 | (re-search-forward (concat "^W " unit-name | |
1633 | "%s[ \t]+\\([^ \t]+\\)[ \t]+" | |
1634 | "\\([^ \t\n]+\\)")) | |
1635 | (setq body-name (match-string 1)) | |
1636 | (setq ali-name (match-string 2)) | |
1637 | (kill-buffer buffer) | |
1638 | ) | |
1639 | ||
1640 | (setq ali-name (ada-find-ali-file-in-dir ali-name)) | |
1641 | ||
1642 | (save-excursion | |
1643 | ;; Tries to open the new ali file to find the spec file | |
1644 | (if ali-name | |
1645 | (progn | |
1646 | (find-file ali-name) | |
1647 | (goto-char (point-min)) | |
1648 | (re-search-forward (concat "^U " unit-name "%s[ \t]+" | |
1649 | "\\([^ \t]+\\)")) | |
1650 | (setq body-name (match-string 1)) | |
1651 | (kill-buffer (current-buffer)) | |
1652 | ) | |
1653 | ) | |
1654 | ) | |
1655 | ||
1656 | (find-file body-name) | |
1657 | )) | |
1658 | ||
1659 | (defun ada-make-filename-from-adaname (adaname) | |
1660 | "Determine the filename of a package/procedure from its own Ada name." | |
1661 | ;; this is done simply by calling `gnatkr', when we work with GNAT. It | |
1662 | ;; must be a more complex function in other compiler environments. | |
1663 | (let (krunch-buf) | |
1664 | (setq krunch-buf (generate-new-buffer "*gkrunch*")) | |
1665 | (save-excursion | |
1666 | (set-buffer krunch-buf) | |
1667 | ;; send adaname to external process `gnatkr'. | |
1668 | (call-process "gnatkr" nil krunch-buf nil | |
1669 | adaname ada-krunch-args) | |
1670 | ;; fetch output of that process | |
1671 | (setq adaname (buffer-substring | |
1672 | (point-min) | |
1673 | (progn | |
1674 | (goto-char (point-min)) | |
1675 | (end-of-line) | |
1676 | (point)))) | |
1677 | (kill-buffer krunch-buf))) | |
1678 | adaname | |
1679 | ) | |
1680 | ||
1681 | ||
1682 | (defun ada-make-body-gnatstub () | |
1683 | "Create an Ada package body in the current buffer. | |
1684 | This function uses the `gnatstub' program to create the body. | |
1685 | This function typically is to be hooked into `ff-file-created-hooks'." | |
1686 | (interactive) | |
1687 | ||
1688 | (save-some-buffers nil nil) | |
1689 | ||
1690 | (ada-require-project-file) | |
1691 | ||
1692 | (delete-region (point-min) (point-max)) | |
1693 | ||
1694 | ;; Call the external process gnatstub | |
1695 | (let* ((gnatstub-opts (ada-treat-cmd-string ada-gnatstub-opts)) | |
1696 | (filename (buffer-file-name (car (cdr (buffer-list))))) | |
1697 | (output (concat (file-name-sans-extension filename) ".adb")) | |
1698 | (gnatstub-cmd (concat "gnatstub " gnatstub-opts " " filename)) | |
1699 | (buffer (get-buffer-create "*gnatstub*"))) | |
1700 | ||
1701 | (save-excursion | |
1702 | (set-buffer buffer) | |
1703 | (compilation-minor-mode 1) | |
1704 | (erase-buffer) | |
1705 | (insert gnatstub-cmd) | |
1706 | (newline) | |
1707 | ) | |
1708 | ;; call gnatstub to create the body file | |
1709 | (call-process shell-file-name nil buffer nil "-c" gnatstub-cmd) | |
1710 | ||
1711 | (if (save-excursion | |
1712 | (set-buffer buffer) | |
1713 | (goto-char (point-min)) | |
1714 | (search-forward "command not found" nil t)) | |
1715 | (progn | |
1716 | (message "gnatstub was not found -- using the basic algorithm") | |
1717 | (sleep-for 2) | |
1718 | (kill-buffer buffer) | |
1719 | (ada-make-body)) | |
1720 | ||
1721 | ;; Else clean up the output | |
1722 | ||
1723 | ;; Kill the temporary buffer created by find-file | |
1724 | (set-buffer-modified-p nil) | |
1725 | (kill-buffer (current-buffer)) | |
1726 | ||
1727 | (if (file-exists-p output) | |
1728 | (progn | |
1729 | (find-file output) | |
1730 | (kill-buffer buffer)) | |
1731 | ||
1732 | ;; display the error buffer | |
1733 | (display-buffer buffer) | |
1734 | ) | |
1735 | ))) | |
1736 | ||
1737 | ||
1738 | (defun ada-xref-initialize () | |
1739 | "Function called by ada-mode-hook to initialize the ada-xref.el package. | |
1740 | For instance, it creates the gnat-specific menus, set some hooks for | |
1741 | find-file...." | |
1742 | (ada-add-ada-menu) | |
1743 | (make-local-hook 'ff-file-created-hooks) | |
1744 | (setq ff-file-created-hooks 'ada-make-body-gnatstub) | |
1745 | ||
1746 | ;; Read the project file and update the search path | |
1747 | ;; before looking for the other file | |
1748 | (make-local-hook 'ff-pre-find-hooks) | |
1749 | (add-hook 'ff-pre-find-hooks 'ada-require-project-file) | |
1750 | ||
1751 | ;; Completion for file names in the mini buffer should ignore .ali files | |
1752 | (add-to-list 'completion-ignored-extensions ".ali") | |
1753 | ) | |
1754 | ||
1755 | ||
1756 | ;; ----- Add to ada-mode-hook --------------------------------------------- | |
1757 | ||
1758 | ;; Set the keymap once and for all, so that the keys set by the user in his | |
1759 | ;; config file are not overwritten every time we open a new file. | |
1760 | (ada-add-keymap) | |
1761 | ||
1762 | (add-hook 'ada-mode-hook 'ada-xref-initialize) | |
1763 | ||
1764 | (provide 'ada-xref) | |
1765 | ||
1766 | ;;; ada-xref.el ends here |