Mercurial > emacs
comparison lisp/progmodes/ada-xref.el @ 25899:e5e3310746eb
New file. Use Gnat for lookup and completion in Ada mode
author | Gerd Moellmann <gerd@gnu.org> |
---|---|
date | Thu, 07 Oct 1999 14:25:59 +0000 |
parents | |
children | 1be4a89d81d3 |
comparison
equal
deleted
inserted
replaced
25898:a39db912a76f | 25899:e5e3310746eb |
---|---|
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 |