1 ;; @(#) ada-xref.el --- use Gnat for lookup and completion in Ada mode
3 ;; Copyright (C) 1994-1999 Free Software Foundation, Inc.
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
12 ;; This file is not part of GNU Emacs.
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)
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.
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.
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.
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
39 ;;; - `ada-goto-declaration': shows the declaration of the selected
40 ;;; identifier (the one under the cursor), either in the same buffer or in
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
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.
58 ;;; You need Emacs >= 20.2 to run this package
60 ;; ----- Requirements -----------------------------------------------------
65 ;; ----- Dynamic byte compilation -----------------------------------------
66 (defvar byte-compile-dynamic nil)
67 (make-local-variable 'byte-compile-dynamic)
68 (setq byte-compile-dynamic t)
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)
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)
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)
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)
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)
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)
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)
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)
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")
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")
128 (defvar ada-check-switch " -gnats "
129 "Switch added to the command line to check the current file")
131 (defvar ada-project-file-extension ".adp"
132 "The extension used for project files")
134 (defconst is-windows (memq system-type (quote (windows-nt)))
135 "true if we are running on windows NT or windows 95")
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.")
141 (defconst ada-xref-pos-ring-max 16
142 "Number of positions kept in the list ada-xref-pos-ring")
144 (defvar ada-operator-re
145 "\\+\\|-\\|/\\|\\*\\|=\\|mod\\|and\\|not\\|or\\|xor\\|<=\\|<\\|>=\\|>"
146 "Regexp to match for operators")
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
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
164 (defvar ada-prj-bind-opt nil
165 "Switches to use on the command line for the default bind
167 (defvar ada-prj-link-opt nil
168 "Switches to use on the command line for the default link
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")
188 ;; ----- Keybindings ------------------------------------------------------
190 (defun ada-add-keymap ()
191 "Add new key bindings when using ada-xrel.el"
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))
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)
217 ;; ----- Menus --------------------------------------------------------------
218 (defun ada-add-ada-menu ()
219 "Add some items to the standard Ada mode menu (the menu defined in
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])
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]
253 (add-menu-button '("Ada" "Edit") ["--------" nil t]
255 (add-menu-button '("Ada" "Help") ["Gnat User Guide" (info "gnat_ug")])
256 (add-menu-button '("Ada" "Help") ["Gnat Reference Manual"
258 (add-menu-button '("Ada" "Help") ["Gcc Documentation" (info "gcc")])
259 (add-menu-button '("Ada" "Help") ["Gdb Documentation" (info "gdb")])
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
278 '(["Associate" ada-change-prj t]
279 ["Set Default" ada-set-default-project-file t]
280 ["List" ada-buffer-list t])))
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])))
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))
308 (define-key edit-submenu [rem] '("----" . nil))
309 (define-key edit-submenu [Complete] '("Complete Identifier"
310 . ada-complete-identifier))
314 ;; ----- Utilities -------------------------------------------------
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))))
321 (defun my-local-variable-if-set-p (variable &optional buffer)
322 (and (local-variable-p variable buffer)
325 (symbol-value variable))))
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)))
333 (defun ada-xref-goto-previous-reference ()
334 "Go to the previous cross-reference we were on"
336 (if ada-xref-pos-ring
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))))))
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"
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)
355 ;; ------ Handling the project file -----------------------------
357 (defun ada-replace-substring (cmd-string search-for replace-with)
358 "Replace all instances of SEARCH-FOR with REPLACE-WITH in
360 (while (string-match search-for cmd-string)
361 (setq cmd-string (replace-match replace-with t t cmd-string)))
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
369 (if ( my-local-variable-if-set-p 'ada-prj-src-dir (current-buffer))
370 (if (string-match "\\(-[^-\$I]*I\\)\${src_dir}" cmd-string)
372 (let ((str-def (substring cmd-string (match-beginning 1)
375 (ada-replace-substring cmd-string
376 "\\(-[^-\$I]*I\\)\${src_dir}"
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)
383 (let ((str-def (substring cmd-string (match-beginning 1)
386 (ada-replace-substring cmd-string
387 "\\(-[^-\$O]*O\\)\${obj_dir}"
389 (lambda (x) (concat str-def x))
392 (if ( my-local-variable-if-set-p 'ada-prj-remote-machine (current-buffer))
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))
398 (ada-replace-substring cmd-string "\${comp_opt}"
400 (if ( my-local-variable-if-set-p 'ada-prj-bind-opt (current-buffer))
402 (ada-replace-substring cmd-string "\${bind_opt}"
404 (if ( my-local-variable-if-set-p 'ada-prj-link-opt (current-buffer))
406 (ada-replace-substring cmd-string "\${link_opt}"
408 (if ( my-local-variable-if-set-p 'ada-prj-main (current-buffer))
410 (ada-replace-substring cmd-string "\${main}"
412 (if ( my-local-variable-if-set-p 'ada-prj-cross-prefix (current-buffer))
414 (ada-replace-substring cmd-string "\${cross_prefix}"
415 ada-prj-cross-prefix)))
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))
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
440 (concat ".*" (regexp-quote ada-project-file-extension) "$")))
442 (default (assoc dir ada-xref-default-prj-file))
447 ((my-local-variable-if-set-p 'ada-prj-prj-file (current-buffer))
450 (default ;; directory default project file
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)
458 ((file-exists-p first-choice)
461 ((= (length prj-files) 1)
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")
472 (while (<= counter (length prj-files))
473 (princ (format " %2d) %s\n"
475 (nth (1- counter) prj-files)))
476 (setq counter (1+ counter))
479 ) ; end of with-output-to ...
483 (not (integerp choice))
485 (> choice (length prj-files)))
486 (setq choice (string-to-int
487 (read-from-minibuffer "Enter No. of your choice: "
489 (nth (1- choice) prj-files))
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))
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))
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"
507 (let ((tmp-src-dir 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))
524 ;; tries to find a project file in the current directory
529 ;; first look for the src_dir lines
531 (goto-char (point-min))
533 (re-search-forward "^src_dir=\\(.*\\)" nil t)
535 (setq tmp-src-dir (cons
536 (file-name-as-directory
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
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)))
581 ;; kills the project file buffer, and go back to the ada buffer
583 (set-buffer ada-buffer)
586 ;; creates local variables (with default values if needed)
587 (set (make-local-variable 'ada-prj-prj-file) prj-file)
589 (set (make-local-variable 'ada-prj-src-dir)
590 (if tmp-src-dir (reverse tmp-src-dir) '("./")))
592 (set (make-local-variable 'ada-prj-obj-dir)
593 (if tmp-obj-dir (reverse tmp-obj-dir) '("./")))
595 (set (make-local-variable 'ada-prj-comp-opt)
596 (if tmp-comp-opt tmp-comp-opt ""))
598 (set (make-local-variable 'ada-prj-bind-opt)
599 (if tmp-bind-opt tmp-bind-opt ""))
601 (set (make-local-variable 'ada-prj-link-opt)
602 (if tmp-link-opt tmp-link-opt ""))
604 (set (make-local-variable 'ada-prj-cross-prefix)
606 (if (or (string= tmp-cross-prefix "")
607 (= (aref tmp-cross-prefix (1- (length tmp-cross-prefix))) ?-))
609 (concat tmp-cross-prefix "-"))
612 (set (make-local-variable 'ada-prj-main)
613 (if tmp-main tmp-main
614 (substring (buffer-file-name) 0 -4)))
616 (set (make-local-variable 'ada-prj-remote-machine)
617 (ada-treat-cmd-string
618 (if tmp-remote-machine tmp-remote-machine "")))
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))))
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))))
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}"))))
635 (set (make-local-variable 'ada-prj-debug-cmd)
636 (ada-treat-cmd-string
637 (if tmp-debug-cmd tmp-debug-cmd
639 "${cross_prefix}gdb ${main}.exe"
640 "${cross_prefix}gdb ${main}"))))
642 ;; Add each directory in src_dir to the default prj list
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)
650 ada-xref-default-prj-file))))
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))
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)
666 (defun ada-find-references (&optional pos)
667 "Find every references to the entity under POS
668 Calls gnatfind to find every references"
672 (ada-require-project-file)
674 (let* ((identlist (ada-read-identifier pos))
675 (alifile (ada-get-ali-file-name (ada-file-of identlist))))
677 (set-buffer (get-file-buffer (ada-file-of identlist)))
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)
685 (ada-find-any-references (ada-name-of identlist)
686 (ada-file-of identlist)
687 (ada-line-of identlist)
688 (ada-column-of identlist))))
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)
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)))))
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)))
705 (compile-internal command
709 ;; Hide the "Compilation" menu
711 (set-buffer "*gnatfind*")
712 (local-unset-key [menu-bar compilation-menu]))
716 (defun ada-buffer-list ()
717 "Display a buffer with all the ada-mode buffers and their associated prj file"
720 (set-buffer (get-buffer-create "*Buffer List*"))
721 (setq buffer-read-only nil)
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)
729 Buffer Mode Project file
730 ------ ---- ------------
732 (let ((bl (buffer-list)))
734 (let* ((buffer (car bl))
735 (buffer-name (buffer-name buffer))
736 this-buffer-mode-name
737 this-buffer-project-file)
740 (setq this-buffer-mode-name
741 (if (eq buffer standard-output)
742 "Buffer Menu" mode-name))
743 (if (string= this-buffer-mode-name
745 (setq this-buffer-project-file
746 (if ( my-local-variable-if-set-p 'ada-prj-prj-file
748 (expand-file-name ada-prj-prj-file)
750 (if (string= this-buffer-mode-name
753 (princ (format "%-19s " buffer-name))
754 (princ (format "%-6s " this-buffer-mode-name))
755 (princ this-buffer-project-file)
762 ) ;; end save-excursion
763 (display-buffer "*Buffer List*")
767 (defun ada-change-prj (filename)
768 "Change the project file associated with the current buffer"
769 (interactive "fproject file:")
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"))
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))
779 ;; ask the user for the new file name
780 (setq ada-prj-prj-file filename)
782 ;; force emacs to reread the prj file next-time
783 (ada-reread-prj-file)
786 (defun ada-change-default-prj (filename)
787 "Change the default project file used for all ada files from the
789 (interactive "ffile name:")
790 (let ((dir (file-name-directory (buffer-file-name)))
791 (prj (expand-file-name filename)))
793 ;; If the directory is already associated with a project file
794 (if (assoc dir ada-xref-default-prj-file)
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)))
800 ;; Reparse the project file
801 (ada-parse-prj-file ada-prj-default-project-file)))
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
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))
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))
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)))
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
839 (ada-require-project-file)
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))
852 ;; we are already in the .ali buffer
853 (goto-char (point-max))
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)))
859 (setq completed (try-completion "" symalist))
864 ;; deletes the incomplete identifier in the buffer
866 (looking-at "[a-zA-Z0-9_]+")
868 ;; inserts the completed symbol
872 ;; ----- Cross-referencing ----------------------------------------
874 (defun ada-point-and-xref ()
875 "Calls `mouse-set-point' and then `ada-goto-declaration'."
877 (mouse-set-point last-input-event)
878 (ada-goto-declaration (point)))
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"
884 (ada-require-project-file)
886 (ada-xref-push-pos (buffer-file-name) pos)
887 (ada-find-in-ali (ada-read-identifier pos)))
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"
893 (ada-require-project-file)
895 (ada-xref-push-pos (buffer-file-name) pos)
896 (ada-find-in-ali (ada-read-identifier pos) t))
898 (defun ada-compile (command)
899 "Start a compilation, on the machine specified in the project file,
900 using command COMMAND"
902 (if (and (my-local-variable-if-set-p 'ada-prj-remote-machine (current-buffer))
903 (not (string= ada-prj-remote-machine "")))
905 (concat "rsh " ada-prj-remote-machine " '"
909 (defun ada-compile-application ()
910 "Compiles the whole application, using the command find in the gnat.prj file"
912 (ada-require-project-file)
914 ;; prompt for command to execute
916 (if ada-xref-confirm-compile
917 (read-from-minibuffer "enter command to compile: "
922 (defun ada-compile-current ()
923 "Recompile the current file"
925 (ada-require-project-file)
927 ;; prompt for command to execute
929 (if ada-xref-confirm-compile
930 (read-from-minibuffer "enter command to compile: "
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)))))
936 (defun ada-check-current ()
937 "Recompile the current file"
939 (ada-require-project-file)
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)))))
945 (if ada-xref-confirm-compile
946 (read-from-minibuffer "enter command to compile: " command)
950 (defun ada-run-application ()
951 "Run the application"
953 (ada-require-project-file)
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"))
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)))
966 ;; Ask for the arguments to the command
968 (read-from-minibuffer "Enter command to execute: "
973 (set-buffer (get-buffer-create "*run*"))
974 (goto-char (point-max))
975 (insert "\nRunning " command "\n\n")
977 (comint-arguments command 0 0)
979 (comint-arguments command 1 nil))
981 (display-buffer "*run*")
983 ;; change to buffer *run* for interactive programs
985 (switch-to-buffer "*run*")
990 (defun ada-gdb-application ()
991 "Run the application"
995 (let ((buffer (current-buffer))
997 (ada-require-project-file)
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"))
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
1010 (set 'gdb-buffer (current-buffer))
1012 ;; Switch back to the source buffer
1013 ;; and Activate the debug part in the contextual menu
1014 (switch-to-buffer buffer)
1016 (if (functionp 'gud-make-debug-menu)
1017 (gud-make-debug-menu))
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)
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"
1035 ;; do this for every buffer
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")
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))))
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)))
1056 ;; ------ Private routines
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."
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
1072 (if ada-xref-confirm-compile
1073 (read-from-minibuffer "enter command to execute gcc: "
1078 (defun ada-first-non-nil (list)
1079 "Returns the first non-nil element of the list"
1082 ((car list) (car list))
1083 (t (ada-first-non-nil (cdr list)))
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"
1092 (if (file-exists-p (concat (file-name-directory x)
1094 (concat (file-name-directory x) file)
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"
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
1117 (set-buffer (get-file-buffer file))
1118 (let ((short-ali-file-name
1119 (concat (file-name-sans-extension (file-name-nondirectory file))
1123 ;; we take the first possible completion
1124 (setq ali-file-name (ada-find-ali-file-in-dir short-ali-file-name))
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"))
1132 (specs ada-spec-suffixes)
1135 (if (string-match (concat (regexp-quote (car specs)) "$")
1138 (set 'specs (cdr specs)))
1142 (ada-find-ali-file-in-dir
1143 (concat (file-name-sans-extension
1144 (file-name-nondirectory
1145 (ada-other-file-name)))
1148 (set 'ali-file-name body-ali))))
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)))
1158 (setq ali-file-name (ada-find-ali-file-in-dir short-ali-file-name))
1160 ;; If still not found, try to recompile the file
1161 (if (not ali-file-name)
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")))
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))
1174 ;; else returns the correct absolute file name
1175 (expand-file-name ali-file-name))
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"
1184 (set-buffer (get-file-buffer original-file))
1185 ;; we choose the first possible completion and we
1186 ;; return the absolute file name
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))
1197 (expand-file-name filename)
1199 (file-name-nondirectory file)
1200 " not found in src_dir. Please check your project file")))
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))
1209 (let ((begin (re-search-forward "^D")))
1211 (re-search-forward (concat "^D " (file-name-nondirectory file)))
1212 (count-lines begin (point))))
1214 (defun ada-read-identifier (pos)
1215 "Returns the identlist around POS and switch to the .ali buffer"
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
1221 (message "Compilation in progress. Try again when it is finished")
1222 (set 'quit-flag t)))
1224 ;; If at end of buffer (e.g the buffer is empty), error
1225 (if (>= (point) (point-max))
1226 (error "No identifier on point"))
1228 ;; goto first character of the identifier/operator (skip backward < and >
1229 ;; since they are part of multiple character operators
1231 (skip-chars-backward "a-zA-Z0-9_<>")
1233 ;; check if it really is an identifier
1234 (if (ada-in-comment-p)
1235 (error "Inside comment"))
1237 (let (identifier identlist)
1238 ;; Just in front of a string => we could have an operator declaration,
1239 ;; as in "+", "-", ..
1240 (if (= (char-after) ?\")
1243 ;; if looking at an operator
1244 (if (looking-at ada-operator-re)
1246 (if (and (= (char-before) ?\")
1247 (= (char-after (+ (length (match-string 0)) (point))) ?\"))
1249 (set 'identifier (concat "\"" (match-string 0) "\"")))
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")))
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))
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)"
1274 (let ((ali-buffer (ada-get-ali-buffer (ada-file-of identlist)))
1276 (set-buffer ali-buffer)
1277 (goto-char (point-min))
1278 (ada-set-on-declaration identlist nil)
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
1284 (if (re-search-forward
1285 (concat "^X [0-9]+ " (file-name-nondirectory (ada-file-of identlist)))
1287 (let ((bound (save-excursion (re-search-forward "^X " nil t))))
1288 (set 'declaration-found
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))
1298 ;; If declaration is still nil, then we were not on a declaration, and
1299 ;; have to fall back on other algorithms
1301 (unless declaration-found
1303 ;; Since we alread know the number of the file, search for a direct
1305 (goto-char (point-min))
1306 (set 'declaration-found t)
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)
1315 (ada-column-of identlist))
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)
1324 (ada-column-of identlist))
1327 ;; If still not found, then either the declaration is unknown
1328 ;; or the source file has been modified since the ali file was
1330 (set 'declaration-found nil)
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
1339 ;; while we have a continuation line, go up one line
1340 (while (looking-at "^\\.")
1342 (unless (looking-at (concat "[0-9]+.[0-9]+[ *]"
1343 (ada-name-of identlist) " "))
1344 (set 'declaration-found nil))))
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
1350 (unless declaration-found
1351 (unless (ada-xref-find-in-modified-ali identlist)
1352 ;; no more idea to find the declaration. Give up
1354 (kill-buffer ali-buffer)
1355 (error (concat "No declaration of " (ada-name-of identlist)
1361 ;; Now that we have found a suitable line in the .ali file, get the
1362 ;; information available
1364 (if declaration-found
1365 (let ((current-line (buffer-substring
1366 (point) (save-excursion (end-of-line) (point)))))
1370 (while (looking-at "^\\.\\(.*\\)")
1371 (set 'current-line (concat current-line (match-string 1)))
1375 (if (re-search-backward "^X [0-9]+ \\([a-zA-Z0-9_.-]+\\)" nil t)
1376 (ada-set-declare-file
1378 (ada-get-ada-file-name (match-string 1)
1379 (ada-file-of identlist))))
1381 (ada-set-references identlist current-line)
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"
1391 (unless (= (string-to-char (ada-name-of identlist)) ?\")
1393 (let ((declist '()) ;;; ( (line_in_ali_file line_in_ada) ( ... ))
1394 (my-regexp (concat "[ *]"
1395 (regexp-quote (ada-name-of identlist)) " "))
1402 (goto-char (point-max))
1403 (while (re-search-backward my-regexp nil t)
1405 (set 'line-ali (count-lines (point-min) (point)))
1407 ;; have a look at the line and column numbers
1408 (if (looking-at "^\\([0-9]+\\).\\([0-9]+\\)[ *]")
1410 (setq line-ada (match-string 1))
1411 (setq col-ada (match-string 2)))
1412 (setq line-ada "--")
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)
1418 'declist (list line-ali (match-string 1) line-ada col-ada))
1423 ;; how many possible declarations have we found ?
1424 (setq len (length declist))
1428 (kill-buffer (current-buffer))
1429 (error (concat "No declaration of "
1430 (ada-name-of identlist)
1431 " recorded in .ali file")))
1433 ;; one => should be the right one
1435 (goto-line (caar declist)))
1437 ;; more than one => display choice list
1439 (with-output-to-temp-buffer "*choice list*"
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")
1446 (while (<= counter len)
1447 (princ (format " %2d) %-21s %4s %4s\n"
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))
1455 (setq counter (1+ counter))
1458 ) ; end of with-output-to ...
1462 (not (integerp choice))
1465 (setq choice (string-to-int
1466 (read-from-minibuffer "Enter No. of your choice: "))))
1467 (goto-line (car (nth (1- choice) declist)))
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"
1476 (ada-get-all-references identlist)
1477 (let ((ali-line (ada-references-of identlist))
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)
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))
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))
1499 (error "No body found"))
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))
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))
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"
1526 (ali-buffer (current-buffer)))
1528 ;; get the current project file for the source ada file
1530 (set-buffer (get-file-buffer (ada-file-of identlist)))
1531 (set 'prj-file ada-prj-prj-file))
1533 ;; Select and display the destination buffer
1534 (if ada-xref-other-buffer
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)
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))
1547 (make-local-variable 'ada-prj-prj-file)
1548 (set 'ada-prj-prj-file prj-file)))
1550 ;; move the cursor to the correct position
1553 (move-to-column column)
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)))
1561 (kill-buffer ali-buffer)))
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))
1571 (goto-char (point-max))
1573 ;; loop - look for all declarations of name in this file
1574 (while (search-backward name nil t)
1576 ;; check if it really is a complete Ada identifier
1578 (not (save-excursion
1579 (goto-char (match-end 0))
1581 (not (ada-in-string-or-comment-p))
1583 ;; variable declaration ?
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 ?
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]\\>"))))
1593 ;; check if it is nearer than the ones before if any
1595 (< (abs (- (point) orgpos)) diff))
1597 (setq newpos (point)
1598 diff (abs (- newpos orgpos))))))
1603 (message "ATTENTION: this declaration is only a (good) guess ...")
1608 ;; Find the parent library file of the current file
1609 (defun ada-goto-parent ()
1610 "go to the parent library file"
1612 (ada-require-project-file)
1614 (let ((buffer (ada-get-ali-buffer (buffer-file-name)))
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))
1625 (kill-buffer buffer)
1626 (error "No parent unit !"))
1627 (setq unit-name (match-string 1 unit-name))
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]+"
1635 (setq body-name (match-string 1))
1636 (setq ali-name (match-string 2))
1637 (kill-buffer buffer)
1640 (setq ali-name (ada-find-ali-file-in-dir ali-name))
1643 ;; Tries to open the new ali file to find the spec file
1646 (find-file ali-name)
1647 (goto-char (point-min))
1648 (re-search-forward (concat "^U " unit-name "%s[ \t]+"
1650 (setq body-name (match-string 1))
1651 (kill-buffer (current-buffer))
1656 (find-file body-name)
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.
1664 (setq krunch-buf (generate-new-buffer "*gkrunch*"))
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
1674 (goto-char (point-min))
1677 (kill-buffer krunch-buf)))
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'."
1688 (save-some-buffers nil nil)
1690 (ada-require-project-file)
1692 (delete-region (point-min) (point-max))
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*")))
1703 (compilation-minor-mode 1)
1705 (insert gnatstub-cmd)
1708 ;; call gnatstub to create the body file
1709 (call-process shell-file-name nil buffer nil "-c" gnatstub-cmd)
1713 (goto-char (point-min))
1714 (search-forward "command not found" nil t))
1716 (message "gnatstub was not found -- using the basic algorithm")
1718 (kill-buffer buffer)
1721 ;; Else clean up the output
1723 ;; Kill the temporary buffer created by find-file
1724 (set-buffer-modified-p nil)
1725 (kill-buffer (current-buffer))
1727 (if (file-exists-p output)
1730 (kill-buffer buffer))
1732 ;; display the error buffer
1733 (display-buffer buffer)
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
1743 (make-local-hook 'ff-file-created-hooks)
1744 (setq ff-file-created-hooks 'ada-make-body-gnatstub)
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)
1751 ;; Completion for file names in the mini buffer should ignore .ali files
1752 (add-to-list 'completion-ignored-extensions ".ali")
1756 ;; ----- Add to ada-mode-hook ---------------------------------------------
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.
1762 (add-hook 'ada-mode-hook 'ada-xref-initialize)
1766 ;;; ada-xref.el ends here