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