| 1 | ;; ada-xref.el --- for lookup and completion in Ada mode |
| 2 | |
| 3 | ;; Copyright (C) 1994-2012 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de> |
| 6 | ;; Rolf Ebert <ebert@inf.enst.fr> |
| 7 | ;; Emmanuel Briot <briot@gnat.com> |
| 8 | ;; Maintainer: Stephen Leake <stephen_leake@stephe-leake.org> |
| 9 | ;; Keywords: languages ada xref |
| 10 | ;; Package: ada-mode |
| 11 | |
| 12 | ;; This file is part of GNU Emacs. |
| 13 | |
| 14 | ;; GNU Emacs 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 3 of the License, or |
| 17 | ;; (at your option) any later version. |
| 18 | |
| 19 | ;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>. |
| 26 | |
| 27 | ;;; Commentary: |
| 28 | ;;; This Package provides a set of functions to use the output of the |
| 29 | ;;; cross reference capabilities of the GNAT Ada compiler |
| 30 | ;;; for lookup and completion in Ada mode. |
| 31 | ;;; |
| 32 | ;;; If a file *.`adp' exists in the ada-file directory, then it is |
| 33 | ;;; read for configuration information. It is read only the first |
| 34 | ;;; time a cross-reference is asked for, and is not read later. |
| 35 | |
| 36 | ;;; You need Emacs >= 20.2 to run this package |
| 37 | |
| 38 | |
| 39 | ;;; History: |
| 40 | ;; |
| 41 | |
| 42 | ;;; Code: |
| 43 | |
| 44 | ;; ----- Requirements ----------------------------------------------------- |
| 45 | |
| 46 | (require 'compile) |
| 47 | (require 'comint) |
| 48 | (require 'find-file) |
| 49 | (require 'ada-mode) |
| 50 | |
| 51 | ;; ------ User variables |
| 52 | (defcustom ada-xref-other-buffer t |
| 53 | "*If nil, always display the cross-references in the same buffer. |
| 54 | Otherwise create either a new buffer or a new frame." |
| 55 | :type 'boolean :group 'ada) |
| 56 | |
| 57 | (defcustom ada-xref-create-ali nil |
| 58 | "*If non-nil, run gcc whenever the cross-references are not up-to-date. |
| 59 | If nil, the cross-reference mode never runs gcc." |
| 60 | :type 'boolean :group 'ada) |
| 61 | |
| 62 | (defcustom ada-xref-confirm-compile nil |
| 63 | "*If non-nil, ask for confirmation before compiling or running the application." |
| 64 | :type 'boolean :group 'ada) |
| 65 | |
| 66 | (defcustom ada-krunch-args "0" |
| 67 | "*Maximum number of characters for filenames created by `gnatkr'. |
| 68 | Set to 0, if you don't use crunched filenames. This should be a string." |
| 69 | :type 'string :group 'ada) |
| 70 | |
| 71 | (defcustom ada-gnat-cmd "gnat" |
| 72 | "Default GNAT project file parser. |
| 73 | Will be run with args \"list -v -Pfile.gpr\". |
| 74 | Default is standard GNAT distribution; alternate \"gnatpath\" |
| 75 | is faster, available from Ada mode web site." |
| 76 | :type 'string :group 'ada) |
| 77 | |
| 78 | (defcustom ada-gnatls-args '("-v") |
| 79 | "*Arguments to pass to `gnatls' to find location of the runtime. |
| 80 | Typical use is to pass `--RTS=soft-floats' on some systems that support it. |
| 81 | |
| 82 | You can also add `-I-' if you do not want the current directory to be included. |
| 83 | Otherwise, going from specs to bodies and back will first look for files in the |
| 84 | current directory. This only has an impact if you are not using project files, |
| 85 | but only ADA_INCLUDE_PATH." |
| 86 | :type '(repeat string) :group 'ada) |
| 87 | |
| 88 | (defcustom ada-prj-default-comp-opt "-gnatq -gnatQ" |
| 89 | "Default compilation options." |
| 90 | :type 'string :group 'ada) |
| 91 | |
| 92 | (defcustom ada-prj-default-bind-opt "" |
| 93 | "Default binder options." |
| 94 | :type 'string :group 'ada) |
| 95 | |
| 96 | (defcustom ada-prj-default-link-opt "" |
| 97 | "Default linker options." |
| 98 | :type 'string :group 'ada) |
| 99 | |
| 100 | (defcustom ada-prj-default-gnatmake-opt "-g" |
| 101 | "Default options for `gnatmake'." |
| 102 | :type 'string :group 'ada) |
| 103 | |
| 104 | (defcustom ada-prj-default-gpr-file "" |
| 105 | "Default GNAT project file. |
| 106 | If non-empty, this file is parsed to set the source and object directories for |
| 107 | the Ada mode project." |
| 108 | :type 'string :group 'ada) |
| 109 | |
| 110 | (defcustom ada-prj-ada-project-path-sep |
| 111 | (cond ((boundp 'path-separator) path-separator) ; 20.3+ |
| 112 | ((memq system-type '(windows-nt ms-dos)) ";") |
| 113 | (t ":")) |
| 114 | "Default separator for ada_project_path project variable." |
| 115 | :type 'string :group 'ada) |
| 116 | |
| 117 | (defcustom ada-prj-gnatfind-switches "-rf" |
| 118 | "Default switches to use for `gnatfind'. |
| 119 | You should modify this variable, for instance to add `-a', if you are working |
| 120 | in an environment where most ALI files are write-protected. |
| 121 | The command `gnatfind' is used every time you choose the menu |
| 122 | \"Show all references\"." |
| 123 | :type 'string :group 'ada) |
| 124 | |
| 125 | (defcustom ada-prj-default-check-cmd |
| 126 | (concat "${cross_prefix}gnatmake -u -c -gnatc ${gnatmake_opt} ${full_current}" |
| 127 | " -cargs ${comp_opt}") |
| 128 | "*Default command to be used to compile a single file. |
| 129 | Emacs will substitute the current filename for ${full_current}, or add |
| 130 | the filename at the end. This is the same syntax as in the project file." |
| 131 | :type 'string :group 'ada) |
| 132 | |
| 133 | (defcustom ada-prj-default-comp-cmd |
| 134 | (concat "${cross_prefix}gnatmake -u -c ${gnatmake_opt} ${full_current} -cargs" |
| 135 | " ${comp_opt}") |
| 136 | "*Default command to be used to compile a single file. |
| 137 | Emacs will substitute the current filename for ${full_current}, or add |
| 138 | the filename at the end. This is the same syntax as in the project file." |
| 139 | :type 'string :group 'ada) |
| 140 | |
| 141 | (defcustom ada-prj-default-debugger "${cross_prefix}gdb" |
| 142 | "*Default name of the debugger." |
| 143 | :type 'string :group 'ada) |
| 144 | |
| 145 | (defcustom ada-prj-default-make-cmd |
| 146 | (concat "${cross_prefix}gnatmake -o ${main} ${main} ${gnatmake_opt} " |
| 147 | "-cargs ${comp_opt} -bargs ${bind_opt} -largs ${link_opt}") |
| 148 | "*Default command to be used to compile the application. |
| 149 | This is the same syntax as in the project file." |
| 150 | :type 'string :group 'ada) |
| 151 | |
| 152 | (defcustom ada-prj-default-project-file "" |
| 153 | "*Name of the current project file. |
| 154 | Emacs will not try to use the search algorithm to find the project file if |
| 155 | this string is not empty. It is set whenever a project file is found." |
| 156 | :type '(file :must-match t) :group 'ada) |
| 157 | |
| 158 | (defcustom ada-gnatstub-opts "-q -I${src_dir}" |
| 159 | "*Options to pass to `gnatsub' to generate the body of a package. |
| 160 | This has the same syntax as in the project file (with variable substitution)." |
| 161 | :type 'string :group 'ada) |
| 162 | |
| 163 | (defcustom ada-always-ask-project nil |
| 164 | "*If nil, use default values when no project file was found. |
| 165 | Otherwise, ask the user for the name of the project file to use." |
| 166 | :type 'boolean :group 'ada) |
| 167 | |
| 168 | (defconst ada-on-ms-windows (memq system-type '(windows-nt)) |
| 169 | "True if we are running on Windows.") |
| 170 | |
| 171 | (defcustom ada-tight-gvd-integration nil |
| 172 | "*If non-nil, a new Emacs frame will be swallowed in GVD when debugging. |
| 173 | If GVD is not the debugger used, nothing happens." |
| 174 | :type 'boolean :group 'ada) |
| 175 | |
| 176 | (defcustom ada-xref-search-with-egrep t |
| 177 | "*If non-nil, use egrep to find the possible declarations for an entity. |
| 178 | This alternate method is used when the exact location was not found in the |
| 179 | information provided by GNAT. However, it might be expensive if you have a lot |
| 180 | of sources, since it will search in all the files in your project." |
| 181 | :type 'boolean :group 'ada) |
| 182 | |
| 183 | (defvar ada-load-project-hook nil |
| 184 | "Hook that is run when loading a project file. |
| 185 | Each function in this hook takes one argument FILENAME, that is the name of |
| 186 | the project file to load. |
| 187 | This hook should be used to support new formats for the project files. |
| 188 | |
| 189 | If the function can load the file with the given filename, it should create a |
| 190 | buffer that contains a conversion of the file to the standard format of the |
| 191 | project files, and return that buffer. (The usual \"src_dir=\" or \"obj_dir=\" |
| 192 | lines.) It should return nil if it doesn't know how to convert that project |
| 193 | file.") |
| 194 | |
| 195 | |
| 196 | ;; ------- Nothing to be modified by the user below this |
| 197 | (defvar ada-last-prj-file "" |
| 198 | "Name of the last project file entered by the user.") |
| 199 | |
| 200 | (defconst ada-prj-file-extension ".adp" |
| 201 | "The extension used for project files.") |
| 202 | |
| 203 | (defvar ada-xref-runtime-library-specs-path '() |
| 204 | "Directories where the specs for the standard library is found. |
| 205 | This is used for cross-references.") |
| 206 | |
| 207 | (defvar ada-xref-runtime-library-ali-path '() |
| 208 | "Directories where the ali for the standard library is found. |
| 209 | This is used for cross-references.") |
| 210 | |
| 211 | (defvar ada-xref-pos-ring '() |
| 212 | "List of positions selected by the cross-references functions. |
| 213 | Used to go back to these positions.") |
| 214 | |
| 215 | (defvar ada-cd-command |
| 216 | (if (string-match "cmdproxy.exe" shell-file-name) |
| 217 | "cd /d" |
| 218 | "cd") |
| 219 | "Command to use to change to a specific directory. |
| 220 | On Windows systems using `cmdproxy.exe' as the shell, |
| 221 | we need to use `/d' or the drive is never changed.") |
| 222 | |
| 223 | (defvar ada-command-separator (if ada-on-ms-windows " && " "\n") |
| 224 | "Separator to use between multiple commands to `compile' or `start-process'. |
| 225 | `cmdproxy.exe' doesn't recognize multiple-line commands, so we have to use |
| 226 | \"&&\" for now.") |
| 227 | |
| 228 | (defconst ada-xref-pos-ring-max 16 |
| 229 | "Number of positions kept in the list `ada-xref-pos-ring'.") |
| 230 | |
| 231 | (defvar ada-operator-re |
| 232 | "\\+\\|-\\|/\\|\\*\\*\\|\\*\\|=\\|&\\|abs\\|mod\\|rem\\|and\\|not\\|or\\|xor\\|<=\\|<\\|>=\\|>" |
| 233 | "Regexp to match for operators.") |
| 234 | |
| 235 | (defvar ada-xref-project-files '() |
| 236 | "Associative list of project files with properties. |
| 237 | It has the format: (project project ...) |
| 238 | A project has the format: (project-file . project-plist) |
| 239 | \(See 'apropos plist' for operations on property lists). |
| 240 | See `ada-default-prj-properties' for the list of valid properties. |
| 241 | The current project is retrieved with `ada-xref-current-project'. |
| 242 | Properties are retrieved with `ada-xref-get-project-field', set with |
| 243 | `ada-xref-set-project-field'. If project properties are accessed with no |
| 244 | project file, a (nil . default-properties) entry is created.") |
| 245 | |
| 246 | |
| 247 | ;; ----- Identlist manipulation ------------------------------------------- |
| 248 | ;; An identlist is a vector that is used internally to reference an identifier |
| 249 | ;; To facilitate its use, we provide the following macros |
| 250 | |
| 251 | (defmacro ada-make-identlist () (make-vector 8 nil)) |
| 252 | (defmacro ada-name-of (identlist) (list 'aref identlist 0)) |
| 253 | (defmacro ada-line-of (identlist) (list 'aref identlist 1)) |
| 254 | (defmacro ada-column-of (identlist) (list 'aref identlist 2)) |
| 255 | (defmacro ada-file-of (identlist) (list 'aref identlist 3)) |
| 256 | (defmacro ada-ali-index-of (identlist) (list 'aref identlist 4)) |
| 257 | (defmacro ada-declare-file-of (identlist) (list 'aref identlist 5)) |
| 258 | (defmacro ada-references-of (identlist) (list 'aref identlist 6)) |
| 259 | (defmacro ada-on-declaration (identlist) (list 'aref identlist 7)) |
| 260 | |
| 261 | (defmacro ada-set-name (identlist name) (list 'aset identlist 0 name)) |
| 262 | (defmacro ada-set-line (identlist line) (list 'aset identlist 1 line)) |
| 263 | (defmacro ada-set-column (identlist col) (list 'aset identlist 2 col)) |
| 264 | (defmacro ada-set-file (identlist file) (list 'aset identlist 3 file)) |
| 265 | (defmacro ada-set-ali-index (identlist index) (list 'aset identlist 4 index)) |
| 266 | (defmacro ada-set-declare-file (identlist file) (list 'aset identlist 5 file)) |
| 267 | (defmacro ada-set-references (identlist ref) (list 'aset identlist 6 ref)) |
| 268 | (defmacro ada-set-on-declaration (ident value) (list 'aset ident 7 value)) |
| 269 | |
| 270 | (defsubst ada-get-ali-buffer (file) |
| 271 | "Read the ali file FILE into a new buffer, and return the buffer's name." |
| 272 | (find-file-noselect (ada-get-ali-file-name file))) |
| 273 | |
| 274 | |
| 275 | ;; ----------------------------------------------------------------------- |
| 276 | |
| 277 | (defun ada-quote-cmd (cmd) |
| 278 | "Duplicate all `\\' characters in CMD so that it can be passed to `compile'." |
| 279 | (mapconcat 'identity (split-string cmd "\\\\") "\\\\")) |
| 280 | |
| 281 | (defun ada-find-executable (exec-name) |
| 282 | "Find the full path to the executable file EXEC-NAME. |
| 283 | If not found, throw an error. |
| 284 | On Windows systems, this will properly handle .exe extension as well." |
| 285 | (let ((result (or (ada-find-file-in-dir exec-name exec-path) |
| 286 | (ada-find-file-in-dir (concat exec-name ".exe") exec-path)))) |
| 287 | (if result |
| 288 | result |
| 289 | (error "'%s' not found in path" exec-name)))) |
| 290 | |
| 291 | (defun ada-initialize-runtime-library (cross-prefix) |
| 292 | "Initialize the variables for the runtime library location. |
| 293 | CROSS-PREFIX is the prefix to use for the `gnatls' command." |
| 294 | (let ((gnatls |
| 295 | (condition-case nil |
| 296 | ;; if gnatls not found, just give up (may not be using GNAT) |
| 297 | (ada-find-executable (concat cross-prefix "gnatls")) |
| 298 | (error nil)))) |
| 299 | (if gnatls |
| 300 | (save-excursion |
| 301 | (setq ada-xref-runtime-library-specs-path '() |
| 302 | ada-xref-runtime-library-ali-path '()) |
| 303 | (set-buffer (get-buffer-create "*gnatls*")) |
| 304 | (widen) |
| 305 | (erase-buffer) |
| 306 | ;; Even if we get an error, delete the *gnatls* buffer |
| 307 | (unwind-protect |
| 308 | (let ((status (apply 'call-process gnatls (append '(nil t nil) ada-gnatls-args)))) |
| 309 | (goto-char (point-min)) |
| 310 | |
| 311 | ;; Since we didn't provide all the inputs gnatls expects, it returns status 4 |
| 312 | (if (/= 4 status) |
| 313 | (error (buffer-substring (point) (line-end-position)))) |
| 314 | |
| 315 | ;; Source path |
| 316 | |
| 317 | (search-forward "Source Search Path:") |
| 318 | (forward-line 1) |
| 319 | (while (not (looking-at "^$")) |
| 320 | (back-to-indentation) |
| 321 | (if (looking-at "<Current_Directory>") |
| 322 | (add-to-list 'ada-xref-runtime-library-specs-path ".") |
| 323 | (add-to-list 'ada-xref-runtime-library-specs-path |
| 324 | (buffer-substring-no-properties |
| 325 | (point) |
| 326 | (point-at-eol)))) |
| 327 | (forward-line 1)) |
| 328 | |
| 329 | ;; Object path |
| 330 | |
| 331 | (search-forward "Object Search Path:") |
| 332 | (forward-line 1) |
| 333 | (while (not (looking-at "^$")) |
| 334 | (back-to-indentation) |
| 335 | (if (looking-at "<Current_Directory>") |
| 336 | (add-to-list 'ada-xref-runtime-library-ali-path ".") |
| 337 | (add-to-list 'ada-xref-runtime-library-ali-path |
| 338 | (buffer-substring-no-properties |
| 339 | (point) |
| 340 | (point-at-eol)))) |
| 341 | (forward-line 1)) |
| 342 | ) |
| 343 | (kill-buffer nil)))) |
| 344 | |
| 345 | (set 'ada-xref-runtime-library-specs-path |
| 346 | (reverse ada-xref-runtime-library-specs-path)) |
| 347 | (set 'ada-xref-runtime-library-ali-path |
| 348 | (reverse ada-xref-runtime-library-ali-path)) |
| 349 | )) |
| 350 | |
| 351 | (defun ada-gnat-parse-gpr (plist gpr-file) |
| 352 | "Set gpr_file, src_dir and obj_dir properties in PLIST by parsing GPR-FILE. |
| 353 | Return new value of PLIST. |
| 354 | GPR_FILE must be full path to file, normalized. |
| 355 | src_dir, obj_dir will include compiler runtime. |
| 356 | Assumes environment variable ADA_PROJECT_PATH is set properly." |
| 357 | (with-current-buffer (get-buffer-create "*gnatls*") |
| 358 | (erase-buffer) |
| 359 | |
| 360 | ;; this can take a long time; let the user know what's up |
| 361 | (message "Parsing %s ..." gpr-file) |
| 362 | |
| 363 | ;; Even if we get an error, delete the *gnatls* buffer |
| 364 | (unwind-protect |
| 365 | (let* ((cross-prefix (plist-get plist 'cross_prefix)) |
| 366 | (gnat (concat cross-prefix ada-gnat-cmd)) |
| 367 | ;; Putting quotes around gpr-file confuses gnatpath on Lynx; not clear why |
| 368 | (gpr-opt (concat "-P" gpr-file)) |
| 369 | (src-dir '()) |
| 370 | (obj-dir '()) |
| 371 | (status (call-process gnat nil t nil "list" "-v" gpr-opt))) |
| 372 | (goto-char (point-min)) |
| 373 | |
| 374 | (if (/= 0 status) |
| 375 | (error (buffer-substring (point) (line-end-position)))) |
| 376 | |
| 377 | ;; Source path |
| 378 | |
| 379 | (search-forward "Source Search Path:") |
| 380 | (forward-line 1) ; first directory in list |
| 381 | (while (not (looking-at "^$")) ; terminate on blank line |
| 382 | (back-to-indentation) ; skip whitespace |
| 383 | (add-to-list 'src-dir |
| 384 | (if (looking-at "<Current_Directory>") |
| 385 | default-directory |
| 386 | (expand-file-name |
| 387 | (buffer-substring-no-properties |
| 388 | (point) (line-end-position))))) |
| 389 | (forward-line 1)) |
| 390 | |
| 391 | ;; Object path |
| 392 | |
| 393 | (search-forward "Object Search Path:") |
| 394 | (forward-line 1) |
| 395 | (while (not (looking-at "^$")) |
| 396 | (back-to-indentation) |
| 397 | (add-to-list 'obj-dir |
| 398 | (if (looking-at "<Current_Directory>") |
| 399 | default-directory |
| 400 | (expand-file-name |
| 401 | (buffer-substring-no-properties |
| 402 | (point) (line-end-position))))) |
| 403 | (forward-line 1)) |
| 404 | |
| 405 | ;; Set properties |
| 406 | (setq plist (plist-put plist 'gpr_file gpr-file)) |
| 407 | (setq plist (plist-put plist 'src_dir src-dir)) |
| 408 | (plist-put plist 'obj_dir obj-dir) |
| 409 | ) |
| 410 | (kill-buffer nil) |
| 411 | (message "Parsing %s ... done" gpr-file) |
| 412 | ) |
| 413 | )) |
| 414 | |
| 415 | (defun ada-treat-cmd-string (cmd-string) |
| 416 | "Replace variable references ${var} in CMD-STRING with the appropriate value. |
| 417 | Also replace standard environment variables $var. |
| 418 | Assumes project exists. |
| 419 | As a special case, ${current} is replaced with the name of the current |
| 420 | file, minus extension but with directory, and ${full_current} is |
| 421 | replaced by the name including the extension." |
| 422 | |
| 423 | (while (string-match "\\(-[^-\$IO]*[IO]\\)?\${\\([^}]+\\)}" cmd-string) |
| 424 | (let (value |
| 425 | (name (match-string 2 cmd-string))) |
| 426 | (cond |
| 427 | ((string= name "current") |
| 428 | (setq value (file-name-sans-extension (buffer-file-name)))) |
| 429 | ((string= name "full_current") |
| 430 | (setq value (buffer-file-name))) |
| 431 | (t |
| 432 | (save-match-data |
| 433 | (setq value (ada-xref-get-project-field (intern name)))))) |
| 434 | |
| 435 | ;; Check if there is an environment variable with the same name |
| 436 | (if (null value) |
| 437 | (if (not (setq value (getenv name))) |
| 438 | (message "%s" (concat "No project or environment variable " name " found")))) |
| 439 | |
| 440 | (cond |
| 441 | ((null value) |
| 442 | (setq cmd-string (replace-match "" t t cmd-string))) |
| 443 | ((stringp value) |
| 444 | (setq cmd-string (replace-match value t t cmd-string))) |
| 445 | ((listp value) |
| 446 | (let ((prefix (match-string 1 cmd-string))) |
| 447 | (setq cmd-string (replace-match |
| 448 | (mapconcat (lambda(x) (concat prefix x)) value " ") |
| 449 | t t cmd-string))))) |
| 450 | )) |
| 451 | (substitute-in-file-name cmd-string)) |
| 452 | |
| 453 | |
| 454 | (defun ada-xref-get-project-field (field) |
| 455 | "Extract the value of FIELD from the current project file. |
| 456 | Project variables are substituted. |
| 457 | |
| 458 | Note that for src_dir and obj_dir, you should rather use |
| 459 | `ada-xref-get-src-dir-field' or `ada-xref-get-obj-dir-field' |
| 460 | which will in addition return the default paths." |
| 461 | |
| 462 | (let* ((project-plist (cdr (ada-xref-current-project))) |
| 463 | (value (plist-get project-plist field))) |
| 464 | |
| 465 | (cond |
| 466 | ((eq field 'gnatmake_opt) |
| 467 | (let ((gpr-file (plist-get project-plist 'gpr_file))) |
| 468 | (if (not (string= gpr-file "")) |
| 469 | (setq value (concat "-P\"" gpr-file "\" " value))))) |
| 470 | |
| 471 | ;; FIXME: check for src_dir, obj_dir here, rather than requiring user to do it |
| 472 | (t |
| 473 | nil)) |
| 474 | |
| 475 | ;; Substitute the ${...} constructs in all the strings, including |
| 476 | ;; inside lists |
| 477 | (cond |
| 478 | ((stringp value) |
| 479 | (ada-treat-cmd-string value)) |
| 480 | ((null value) |
| 481 | nil) |
| 482 | ((listp value) |
| 483 | (mapcar (lambda(x) (if x (ada-treat-cmd-string x) x)) value)) |
| 484 | (t |
| 485 | value) |
| 486 | ) |
| 487 | )) |
| 488 | |
| 489 | (defun ada-xref-get-src-dir-field () |
| 490 | "Return the full value for src_dir, including the default directories. |
| 491 | All the directories are returned as absolute directories." |
| 492 | |
| 493 | (let ((build-dir (ada-xref-get-project-field 'build_dir))) |
| 494 | (append |
| 495 | ;; Add ${build_dir} in front of the path |
| 496 | (list build-dir) |
| 497 | |
| 498 | (ada-get-absolute-dir-list (ada-xref-get-project-field 'src_dir) |
| 499 | build-dir) |
| 500 | |
| 501 | ;; Add the standard runtime at the end |
| 502 | ada-xref-runtime-library-specs-path))) |
| 503 | |
| 504 | (defun ada-xref-get-obj-dir-field () |
| 505 | "Return the full value for obj_dir, including the default directories. |
| 506 | All the directories are returned as absolute directories." |
| 507 | |
| 508 | (let ((build-dir (ada-xref-get-project-field 'build_dir))) |
| 509 | (append |
| 510 | ;; Add ${build_dir} in front of the path |
| 511 | (list build-dir) |
| 512 | |
| 513 | (ada-get-absolute-dir-list (ada-xref-get-project-field 'obj_dir) |
| 514 | build-dir) |
| 515 | |
| 516 | ;; Add the standard runtime at the end |
| 517 | ada-xref-runtime-library-ali-path))) |
| 518 | |
| 519 | (defun ada-xref-set-project-field (field value) |
| 520 | "Set FIELD to VALUE in current project. Assumes project exists." |
| 521 | ;; same algorithm to find project-plist as ada-xref-current-project |
| 522 | (let* ((file-name (ada-xref-current-project-file)) |
| 523 | (project-plist (cdr (assoc file-name ada-xref-project-files)))) |
| 524 | |
| 525 | (setq project-plist (plist-put project-plist field value)) |
| 526 | (setcdr (assoc file-name ada-xref-project-files) project-plist))) |
| 527 | |
| 528 | (defun ada-xref-update-project-menu () |
| 529 | "Update the menu Ada->Project, with the list of available project files." |
| 530 | ;; Create the standard items. |
| 531 | (let ((submenu |
| 532 | `("Project" |
| 533 | ["Load..." ada-set-default-project-file t] |
| 534 | ["New..." ada-prj-new t] |
| 535 | ["Edit..." ada-prj-edit t] |
| 536 | "---" |
| 537 | ;; Add the project files |
| 538 | ,@(mapcar |
| 539 | (lambda (x) |
| 540 | (let* ((name (or (car x) "<default>")) |
| 541 | (command `(lambda () |
| 542 | "Select the current project file." |
| 543 | (interactive) |
| 544 | (ada-select-prj-file ,name)))) |
| 545 | (vector |
| 546 | (file-name-nondirectory name) |
| 547 | command |
| 548 | :button (cons |
| 549 | :toggle |
| 550 | (equal ada-prj-default-project-file |
| 551 | (car x)) |
| 552 | )))) |
| 553 | |
| 554 | (or ada-xref-project-files '(nil)))))) |
| 555 | |
| 556 | (easy-menu-add-item ada-mode-menu '() submenu))) |
| 557 | |
| 558 | |
| 559 | ;;------------------------------------------------------------- |
| 560 | ;;-- Searching a file anywhere on the source path. |
| 561 | ;;-- |
| 562 | ;;-- The following functions provide support for finding a file anywhere |
| 563 | ;;-- on the source path, without providing an explicit directory. |
| 564 | ;;-- They also provide file name completion in the minibuffer. |
| 565 | ;;-- |
| 566 | ;;-- Public subprograms: ada-find-file |
| 567 | ;;-- |
| 568 | ;;------------------------------------------------------------- |
| 569 | |
| 570 | (defun ada-do-file-completion (string predicate flag) |
| 571 | "Completion function when reading a file from the minibuffer. |
| 572 | Completion is attempted in all the directories in the source path, |
| 573 | as defined in the project file." |
| 574 | ;; FIXME: doc arguments |
| 575 | |
| 576 | ;; This function is not itself interactive, but it is called as part |
| 577 | ;; of the prompt of interactive functions, so we require a project |
| 578 | ;; file. |
| 579 | (ada-require-project-file) |
| 580 | (let (list |
| 581 | (dirs (ada-xref-get-src-dir-field))) |
| 582 | |
| 583 | (while dirs |
| 584 | (if (file-directory-p (car dirs)) |
| 585 | (set 'list (append list (file-name-all-completions string (car dirs))))) |
| 586 | (set 'dirs (cdr dirs))) |
| 587 | (cond ((equal flag 'lambda) |
| 588 | (assoc string list)) |
| 589 | (flag |
| 590 | list) |
| 591 | (t |
| 592 | (try-completion string |
| 593 | (mapcar (lambda (x) (cons x 1)) list) |
| 594 | predicate))))) |
| 595 | |
| 596 | ;;;###autoload |
| 597 | (defun ada-find-file (filename) |
| 598 | "Open FILENAME, from anywhere in the source path. |
| 599 | Completion is available." |
| 600 | (interactive |
| 601 | (list (completing-read "File: " 'ada-do-file-completion))) |
| 602 | (let ((file (ada-find-src-file-in-dir filename))) |
| 603 | (if file |
| 604 | (find-file file) |
| 605 | (error "%s not found in src_dir" filename)))) |
| 606 | |
| 607 | |
| 608 | ;; ----- Utilities ------------------------------------------------- |
| 609 | |
| 610 | (defun ada-require-project-file () |
| 611 | "If the current project does not exist, load or create a default one. |
| 612 | Should only be called from interactive functions." |
| 613 | (if (string= "" ada-prj-default-project-file) |
| 614 | (ada-reread-prj-file (ada-prj-find-prj-file t)))) |
| 615 | |
| 616 | (defun ada-xref-current-project-file () |
| 617 | "Return the current project file name; never nil. |
| 618 | Call `ada-require-project-file' first if a project must exist." |
| 619 | (if (not (string= "" ada-prj-default-project-file)) |
| 620 | ada-prj-default-project-file |
| 621 | (ada-prj-find-prj-file t))) |
| 622 | |
| 623 | (defun ada-xref-current-project () |
| 624 | "Return the current project. |
| 625 | Call `ada-require-project-file' first to ensure a project exists." |
| 626 | (let ((file-name (ada-xref-current-project-file))) |
| 627 | (assoc file-name ada-xref-project-files))) |
| 628 | |
| 629 | (defun ada-show-current-project () |
| 630 | "Display current project file name in message buffer." |
| 631 | (interactive) |
| 632 | (message (ada-xref-current-project-file))) |
| 633 | |
| 634 | (defun ada-show-current-main () |
| 635 | "Display current main file name in message buffer." |
| 636 | (interactive) |
| 637 | (message "ada-mode main: %s" (ada-xref-get-project-field 'main))) |
| 638 | |
| 639 | (defun ada-xref-push-pos (filename position) |
| 640 | "Push (FILENAME, POSITION) on the position ring for cross-references." |
| 641 | (setq ada-xref-pos-ring (cons (list position filename) ada-xref-pos-ring)) |
| 642 | (if (> (length ada-xref-pos-ring) ada-xref-pos-ring-max) |
| 643 | (setcdr (nthcdr (1- ada-xref-pos-ring-max) ada-xref-pos-ring) nil))) |
| 644 | |
| 645 | (defun ada-xref-goto-previous-reference () |
| 646 | "Go to the previous cross-reference we were on." |
| 647 | (interactive) |
| 648 | (if ada-xref-pos-ring |
| 649 | (let ((pos (car ada-xref-pos-ring))) |
| 650 | (setq ada-xref-pos-ring (cdr ada-xref-pos-ring)) |
| 651 | (find-file (car (cdr pos))) |
| 652 | (goto-char (car pos))))) |
| 653 | |
| 654 | (defun ada-convert-file-name (name) |
| 655 | "Convert from NAME to a name that can be used by the compilation commands. |
| 656 | This is overridden on VMS to convert from VMS filenames to Unix filenames." |
| 657 | name) |
| 658 | ;; FIXME: use convert-standard-filename instead |
| 659 | |
| 660 | (defun ada-set-default-project-file (file) |
| 661 | "Set FILE as the current project file." |
| 662 | (interactive "fProject file:") |
| 663 | (ada-parse-prj-file file) |
| 664 | (ada-select-prj-file file)) |
| 665 | |
| 666 | ;; ------ Handling the project file ----------------------------- |
| 667 | |
| 668 | (defun ada-prj-find-prj-file (&optional no-user-question) |
| 669 | "Find the project file associated with the current buffer. |
| 670 | If the buffer is not in Ada mode, or not associated with a file, |
| 671 | return `ada-prj-default-project-file'. Otherwise, search for a file with |
| 672 | the same base name as the Ada file, but extension given by |
| 673 | `ada-prj-file-extension' (default .adp). If not found, search for *.adp |
| 674 | in the current directory; if several are found, and NO-USER-QUESTION |
| 675 | is non-nil, prompt the user to select one. If none are found, return |
| 676 | 'default.adp'." |
| 677 | |
| 678 | (let (selected) |
| 679 | |
| 680 | (if (not (and (derived-mode-p 'ada-mode) |
| 681 | buffer-file-name)) |
| 682 | |
| 683 | ;; Not in an Ada buffer, or current buffer not associated |
| 684 | ;; with a file (for instance an emerge buffer) |
| 685 | (setq selected nil) |
| 686 | |
| 687 | ;; other cases: use a more complex algorithm |
| 688 | |
| 689 | (let* ((current-file (buffer-file-name)) |
| 690 | (first-choice (concat |
| 691 | (file-name-sans-extension current-file) |
| 692 | ada-prj-file-extension)) |
| 693 | (dir (file-name-directory current-file)) |
| 694 | |
| 695 | (prj-files (directory-files |
| 696 | dir t |
| 697 | (concat ".*" (regexp-quote |
| 698 | ada-prj-file-extension) "$"))) |
| 699 | (choice nil)) |
| 700 | |
| 701 | (cond |
| 702 | |
| 703 | ((file-exists-p first-choice) |
| 704 | ;; filename.adp |
| 705 | (set 'selected first-choice)) |
| 706 | |
| 707 | ((= (length prj-files) 1) |
| 708 | ;; Exactly one project file was found in the current directory |
| 709 | (set 'selected (car prj-files))) |
| 710 | |
| 711 | ((and (> (length prj-files) 1) (not no-user-question)) |
| 712 | ;; multiple project files in current directory, ask the user |
| 713 | (save-window-excursion |
| 714 | (with-output-to-temp-buffer "*choice list*" |
| 715 | (princ "There are more than one possible project file.\n") |
| 716 | (princ "Which one should we use ?\n\n") |
| 717 | (princ " no. file name \n") |
| 718 | (princ " --- ------------------------\n") |
| 719 | (let ((counter 1)) |
| 720 | (while (<= counter (length prj-files)) |
| 721 | (princ (format " %2d) %s\n" |
| 722 | counter |
| 723 | (nth (1- counter) prj-files))) |
| 724 | (setq counter (1+ counter)) |
| 725 | |
| 726 | ))) ; end of with-output-to ... |
| 727 | (setq choice nil) |
| 728 | (while (or |
| 729 | (not choice) |
| 730 | (not (integerp choice)) |
| 731 | (< choice 1) |
| 732 | (> choice (length prj-files))) |
| 733 | (setq choice (string-to-number |
| 734 | (read-from-minibuffer "Enter No. of your choice: ")))) |
| 735 | (set 'selected (nth (1- choice) prj-files)))) |
| 736 | |
| 737 | ((= (length prj-files) 0) |
| 738 | ;; No project file in the current directory; ask user |
| 739 | (unless (or no-user-question (not ada-always-ask-project)) |
| 740 | (setq ada-last-prj-file |
| 741 | (read-file-name |
| 742 | (concat "project file [" ada-last-prj-file "]:") |
| 743 | nil ada-last-prj-file)) |
| 744 | (unless (string= ada-last-prj-file "") |
| 745 | (set 'selected ada-last-prj-file)))) |
| 746 | ))) |
| 747 | |
| 748 | (or selected "default.adp") |
| 749 | )) |
| 750 | |
| 751 | (defun ada-default-prj-properties () |
| 752 | "Return the default project properties list with the current buffer as main." |
| 753 | |
| 754 | (let ((file (buffer-file-name nil))) |
| 755 | (list |
| 756 | ;; variable name alphabetical order |
| 757 | 'ada_project_path (or (getenv "ADA_PROJECT_PATH") "") |
| 758 | 'ada_project_path_sep ada-prj-ada-project-path-sep |
| 759 | 'bind_opt ada-prj-default-bind-opt |
| 760 | 'build_dir default-directory |
| 761 | 'casing (if (listp ada-case-exception-file) |
| 762 | ada-case-exception-file |
| 763 | (list ada-case-exception-file)) |
| 764 | 'check_cmd (list ada-prj-default-check-cmd) ;; FIXME: should not a list |
| 765 | 'comp_cmd (list ada-prj-default-comp-cmd) ;; FIXME: should not a list |
| 766 | 'comp_opt ada-prj-default-comp-opt |
| 767 | 'cross_prefix "" |
| 768 | 'debug_cmd (concat ada-prj-default-debugger |
| 769 | " ${main}" (if ada-on-ms-windows ".exe")) ;; FIXME: don't need .exe? |
| 770 | 'debug_post_cmd (list nil) |
| 771 | 'debug_pre_cmd (list (concat ada-cd-command " ${build_dir}")) |
| 772 | 'gnatmake_opt ada-prj-default-gnatmake-opt |
| 773 | 'gnatfind_opt ada-prj-gnatfind-switches |
| 774 | 'gpr_file ada-prj-default-gpr-file |
| 775 | 'link_opt ada-prj-default-link-opt |
| 776 | 'main (if file |
| 777 | (file-name-nondirectory |
| 778 | (file-name-sans-extension file)) |
| 779 | "") |
| 780 | 'make_cmd (list ada-prj-default-make-cmd) ;; FIXME: should not a list |
| 781 | 'obj_dir (list ".") |
| 782 | 'remote_machine "" |
| 783 | 'run_cmd (list (concat "./${main}" (if ada-on-ms-windows ".exe"))) |
| 784 | ;; FIXME: should not a list |
| 785 | ;; FIXME: don't need .exe? |
| 786 | 'src_dir (list ".") |
| 787 | ))) |
| 788 | |
| 789 | (defun ada-parse-prj-file (prj-file) |
| 790 | "Read PRJ-FILE, set project properties in `ada-xref-project-files'." |
| 791 | (let ((project (ada-default-prj-properties))) |
| 792 | |
| 793 | (setq prj-file (expand-file-name prj-file)) |
| 794 | (if (string= (file-name-extension prj-file) "gpr") |
| 795 | (set 'project (ada-gnat-parse-gpr project prj-file)) |
| 796 | |
| 797 | (set 'project (ada-parse-prj-file-1 prj-file project)) |
| 798 | ) |
| 799 | |
| 800 | ;; Store the project properties |
| 801 | (if (assoc prj-file ada-xref-project-files) |
| 802 | (setcdr (assoc prj-file ada-xref-project-files) project) |
| 803 | (add-to-list 'ada-xref-project-files (cons prj-file project))) |
| 804 | |
| 805 | (ada-xref-update-project-menu) |
| 806 | )) |
| 807 | |
| 808 | (defun ada-parse-prj-file-1 (prj-file project) |
| 809 | "Parse the Ada mode project file PRJ-FILE, set project properties in PROJECT. |
| 810 | Return new value of PROJECT." |
| 811 | (let ((ada-buffer (current-buffer)) |
| 812 | ;; fields that are lists or otherwise require special processing |
| 813 | ada_project_path casing comp_cmd check_cmd |
| 814 | debug_pre_cmd debug_post_cmd gpr_file make_cmd obj_dir src_dir run_cmd) |
| 815 | |
| 816 | ;; Give users a chance to use compiler-specific project file formats |
| 817 | (let ((buffer (run-hook-with-args-until-success |
| 818 | 'ada-load-project-hook prj-file))) |
| 819 | (unless buffer |
| 820 | ;; we load the project file with no warnings; if it does not |
| 821 | ;; exist, we stay in the Ada buffer; no project variable |
| 822 | ;; settings will be found. That works for the default |
| 823 | ;; "default.adp", which does not exist as a file. |
| 824 | (setq buffer (find-file-noselect prj-file nil))) |
| 825 | (set-buffer buffer)) |
| 826 | |
| 827 | (widen) |
| 828 | (goto-char (point-min)) |
| 829 | |
| 830 | ;; process each line |
| 831 | (while (not (eobp)) |
| 832 | |
| 833 | ;; ignore lines that don't have the format "name=value", put |
| 834 | ;; 'name', 'value' in match-string. |
| 835 | (if (looking-at "^\\([^=\n]+\\)=\\(.*\\)") |
| 836 | (cond |
| 837 | ;; FIXME: strip trailing spaces |
| 838 | ;; variable name alphabetical order |
| 839 | ((string= (match-string 1) "ada_project_path") |
| 840 | (add-to-list 'ada_project_path |
| 841 | (expand-file-name |
| 842 | (substitute-in-file-name (match-string 2))))) |
| 843 | |
| 844 | ((string= (match-string 1) "build_dir") |
| 845 | (set 'project |
| 846 | (plist-put project 'build_dir |
| 847 | (file-name-as-directory (match-string 2))))) |
| 848 | |
| 849 | ((string= (match-string 1) "casing") |
| 850 | (add-to-list 'casing |
| 851 | (expand-file-name (substitute-in-file-name (match-string 2))))) |
| 852 | |
| 853 | ((string= (match-string 1) "check_cmd") |
| 854 | (add-to-list 'check_cmd (match-string 2))) |
| 855 | |
| 856 | ((string= (match-string 1) "comp_cmd") |
| 857 | (add-to-list 'comp_cmd (match-string 2))) |
| 858 | |
| 859 | ((string= (match-string 1) "debug_post_cmd") |
| 860 | (add-to-list 'debug_post_cmd (match-string 2))) |
| 861 | |
| 862 | ((string= (match-string 1) "debug_pre_cmd") |
| 863 | (add-to-list 'debug_pre_cmd (match-string 2))) |
| 864 | |
| 865 | ((string= (match-string 1) "gpr_file") |
| 866 | ;; expand now; path is relative to Emacs project file |
| 867 | (setq gpr_file (expand-file-name (match-string 2)))) |
| 868 | |
| 869 | ((string= (match-string 1) "make_cmd") |
| 870 | (add-to-list 'make_cmd (match-string 2))) |
| 871 | |
| 872 | ((string= (match-string 1) "obj_dir") |
| 873 | (add-to-list 'obj_dir |
| 874 | (file-name-as-directory |
| 875 | (expand-file-name (match-string 2))))) |
| 876 | |
| 877 | ((string= (match-string 1) "run_cmd") |
| 878 | (add-to-list 'run_cmd (match-string 2))) |
| 879 | |
| 880 | ((string= (match-string 1) "src_dir") |
| 881 | (add-to-list 'src_dir |
| 882 | (file-name-as-directory |
| 883 | (expand-file-name (match-string 2))))) |
| 884 | |
| 885 | (t |
| 886 | ;; any other field in the file is just copied |
| 887 | (set 'project (plist-put project |
| 888 | (intern (match-string 1)) |
| 889 | (match-string 2)))))) |
| 890 | |
| 891 | (forward-line 1)) |
| 892 | |
| 893 | ;; done reading file |
| 894 | |
| 895 | ;; back to the user buffer |
| 896 | (set-buffer ada-buffer) |
| 897 | |
| 898 | ;; process accumulated lists |
| 899 | (if ada_project_path |
| 900 | (let ((sep (plist-get project 'ada_project_path_sep))) |
| 901 | (setq ada_project_path (reverse ada_project_path)) |
| 902 | (setq ada_project_path (mapconcat 'identity ada_project_path sep)) |
| 903 | (set 'project (plist-put project 'ada_project_path ada_project_path)) |
| 904 | ;; env var needed now for ada-gnat-parse-gpr |
| 905 | (setenv "ADA_PROJECT_PATH" ada_project_path))) |
| 906 | |
| 907 | (if debug_post_cmd (set 'project (plist-put project 'debug_post_cmd (reverse debug_post_cmd)))) |
| 908 | (if debug_pre_cmd (set 'project (plist-put project 'debug_pre_cmd (reverse debug_pre_cmd)))) |
| 909 | (if casing (set 'project (plist-put project 'casing (reverse casing)))) |
| 910 | (if check_cmd (set 'project (plist-put project 'check_cmd (reverse check_cmd)))) |
| 911 | (if comp_cmd (set 'project (plist-put project 'comp_cmd (reverse comp_cmd)))) |
| 912 | (if make_cmd (set 'project (plist-put project 'make_cmd (reverse make_cmd)))) |
| 913 | (if run_cmd (set 'project (plist-put project 'run_cmd (reverse run_cmd)))) |
| 914 | |
| 915 | (if gpr_file |
| 916 | (progn |
| 917 | (set 'project (ada-gnat-parse-gpr project gpr_file)) |
| 918 | ;; append Ada source and object directories to others from Emacs project file |
| 919 | (setq src_dir (append (plist-get project 'src_dir) src_dir)) |
| 920 | (setq obj_dir (append (plist-get project 'obj_dir) obj_dir)) |
| 921 | (setq ada-xref-runtime-library-specs-path '() |
| 922 | ada-xref-runtime-library-ali-path '())) |
| 923 | ) |
| 924 | |
| 925 | ;; FIXME: gnatpath.exe doesn't output the runtime libraries, so always call ada-initialize-runtime-library |
| 926 | ;; if using a gpr_file, the runtime library directories are |
| 927 | ;; included in src_dir and obj_dir; otherwise they are in the |
| 928 | ;; 'runtime-library' variables. |
| 929 | ;; FIXME: always append to src_dir, obj_dir |
| 930 | (ada-initialize-runtime-library (or (ada-xref-get-project-field 'cross_prefix) "")) |
| 931 | ;;) |
| 932 | |
| 933 | (if obj_dir (set 'project (plist-put project 'obj_dir (reverse obj_dir)))) |
| 934 | (if src_dir (set 'project (plist-put project 'src_dir (reverse src_dir)))) |
| 935 | |
| 936 | project |
| 937 | )) |
| 938 | |
| 939 | (defun ada-select-prj-file (file) |
| 940 | "Select FILE as the current project file." |
| 941 | (interactive) |
| 942 | (setq ada-prj-default-project-file (expand-file-name file)) |
| 943 | |
| 944 | (let ((casing (ada-xref-get-project-field 'casing))) |
| 945 | (if casing |
| 946 | (progn |
| 947 | ;; FIXME: use ada-get-absolute-dir here |
| 948 | (setq ada-case-exception-file casing) |
| 949 | (ada-case-read-exceptions)))) |
| 950 | |
| 951 | (let ((ada_project_path (ada-xref-get-project-field 'ada_project_path))) |
| 952 | (if ada_project_path |
| 953 | ;; FIXME: use ada-get-absolute-dir, mapconcat here |
| 954 | (setenv "ADA_PROJECT_PATH" ada_project_path))) |
| 955 | |
| 956 | (setq compilation-search-path (ada-xref-get-src-dir-field)) |
| 957 | |
| 958 | (setq ada-search-directories-internal |
| 959 | ;; FIXME: why do we need directory-file-name here? |
| 960 | (append (mapcar 'directory-file-name compilation-search-path) |
| 961 | ada-search-directories)) |
| 962 | |
| 963 | ;; return 't', for decent display in message buffer when called interactively |
| 964 | t) |
| 965 | |
| 966 | (defun ada-find-references (&optional pos arg local-only) |
| 967 | "Find all references to the entity under POS. |
| 968 | Calls gnatfind to find the references. |
| 969 | If ARG is non-nil, the contents of the old *gnatfind* buffer is preserved. |
| 970 | If LOCAL-ONLY is non-nil, only declarations in the current file are returned." |
| 971 | (interactive "d\nP") |
| 972 | (ada-require-project-file) |
| 973 | |
| 974 | (let* ((identlist (ada-read-identifier pos)) |
| 975 | (alifile (ada-get-ali-file-name (ada-file-of identlist))) |
| 976 | (process-environment (ada-set-environment))) |
| 977 | |
| 978 | (set-buffer (get-file-buffer (ada-file-of identlist))) |
| 979 | |
| 980 | ;; if the file is more recent than the executable |
| 981 | (if (or (buffer-modified-p (current-buffer)) |
| 982 | (file-newer-than-file-p (ada-file-of identlist) alifile)) |
| 983 | (ada-find-any-references (ada-name-of identlist) |
| 984 | (ada-file-of identlist) |
| 985 | nil nil local-only arg) |
| 986 | (ada-find-any-references (ada-name-of identlist) |
| 987 | (ada-file-of identlist) |
| 988 | (ada-line-of identlist) |
| 989 | (ada-column-of identlist) local-only arg))) |
| 990 | ) |
| 991 | |
| 992 | (defun ada-find-local-references (&optional pos arg) |
| 993 | "Find all references to the entity under POS. |
| 994 | Calls `gnatfind' to find the references. |
| 995 | If ARG is non-nil, the contents of the old *gnatfind* buffer is preserved." |
| 996 | (interactive "d\nP") |
| 997 | (ada-find-references pos arg t)) |
| 998 | |
| 999 | (defconst ada-gnatfind-buffer-name "*gnatfind*") |
| 1000 | |
| 1001 | (defun ada-find-any-references |
| 1002 | (entity &optional file line column local-only append) |
| 1003 | "Search for references to any entity whose name is ENTITY. |
| 1004 | ENTITY was first found the location given by FILE, LINE and COLUMN. |
| 1005 | If LOCAL-ONLY is non-nil, then list only the references in FILE, |
| 1006 | which is much faster. |
| 1007 | If APPEND is non-nil, then append the output of the command to the |
| 1008 | existing buffer `*gnatfind*', if there is one." |
| 1009 | (interactive "sEntity name: ") |
| 1010 | (ada-require-project-file) |
| 1011 | |
| 1012 | ;; Prepare the gnatfind command. Note that we must protect the quotes |
| 1013 | ;; around operators, so that they are correctly handled and can be |
| 1014 | ;; processed (gnatfind \"+\":...). |
| 1015 | (let* ((quote-entity |
| 1016 | (if (= (aref entity 0) ?\") |
| 1017 | (if ada-on-ms-windows |
| 1018 | (concat "\\\"" (substring entity 1 -1) "\\\"") |
| 1019 | (concat "'\"" (substring entity 1 -1) "\"'")) |
| 1020 | entity)) |
| 1021 | (switches (ada-xref-get-project-field 'gnatfind_opt)) |
| 1022 | ;; FIXME: use gpr_file |
| 1023 | (cross-prefix (ada-xref-get-project-field 'cross_prefix)) |
| 1024 | (command (concat cross-prefix "gnat find " switches " " |
| 1025 | quote-entity |
| 1026 | (if file (concat ":" (file-name-nondirectory file))) |
| 1027 | (if line (concat ":" line)) |
| 1028 | (if column (concat ":" column)) |
| 1029 | (if local-only (concat " " (file-name-nondirectory file))) |
| 1030 | )) |
| 1031 | old-contents) |
| 1032 | |
| 1033 | ;; If a project file is defined, use it |
| 1034 | (if (and ada-prj-default-project-file |
| 1035 | (not (string= ada-prj-default-project-file ""))) |
| 1036 | (if (string-equal (file-name-extension ada-prj-default-project-file) |
| 1037 | "gpr") |
| 1038 | (setq command (concat command " -P\"" ada-prj-default-project-file "\"")) |
| 1039 | (setq command (concat command " -p\"" ada-prj-default-project-file "\"")))) |
| 1040 | |
| 1041 | (if (and append (get-buffer ada-gnatfind-buffer-name)) |
| 1042 | (with-current-buffer "*gnatfind*" |
| 1043 | (setq old-contents (buffer-string)))) |
| 1044 | |
| 1045 | (let ((compilation-error "reference")) |
| 1046 | (compilation-start command 'compilation-mode (lambda (_mode) ada-gnatfind-buffer-name))) |
| 1047 | |
| 1048 | ;; Hide the "Compilation" menu |
| 1049 | (with-current-buffer ada-gnatfind-buffer-name |
| 1050 | (local-unset-key [menu-bar compilation-menu]) |
| 1051 | |
| 1052 | (if old-contents |
| 1053 | (progn |
| 1054 | (goto-char 1) |
| 1055 | (set 'buffer-read-only nil) |
| 1056 | (insert old-contents) |
| 1057 | (set 'buffer-read-only t) |
| 1058 | (goto-char (point-max))))) |
| 1059 | ) |
| 1060 | ) |
| 1061 | |
| 1062 | (defalias 'ada-change-prj (symbol-function 'ada-set-default-project-file)) |
| 1063 | |
| 1064 | ;; ----- Identifier Completion -------------------------------------------- |
| 1065 | (defun ada-complete-identifier (pos) |
| 1066 | "Try to complete the identifier around POS, using compiler cross-reference information." |
| 1067 | (interactive "d") |
| 1068 | (ada-require-project-file) |
| 1069 | |
| 1070 | ;; Initialize function-local variables and jump to the .ali buffer |
| 1071 | ;; Note that for regexp search is case insensitive too |
| 1072 | (let* ((curbuf (current-buffer)) |
| 1073 | (identlist (ada-read-identifier pos)) |
| 1074 | (sofar (concat "^[0-9]+[a-zA-Z][0-9]+[ *]\\(" |
| 1075 | (regexp-quote (ada-name-of identlist)) |
| 1076 | "[a-zA-Z0-9_]*\\)")) |
| 1077 | (completed nil) |
| 1078 | (symalist nil)) |
| 1079 | |
| 1080 | ;; Open the .ali file |
| 1081 | (set-buffer (ada-get-ali-buffer (buffer-file-name))) |
| 1082 | (goto-char (point-max)) |
| 1083 | |
| 1084 | ;; build an alist of possible completions |
| 1085 | (while (re-search-backward sofar nil t) |
| 1086 | (setq symalist (cons (cons (match-string 1) nil) symalist))) |
| 1087 | |
| 1088 | (setq completed (try-completion "" symalist)) |
| 1089 | |
| 1090 | ;; kills .ali buffer |
| 1091 | (kill-buffer nil) |
| 1092 | |
| 1093 | ;; deletes the incomplete identifier in the buffer |
| 1094 | (set-buffer curbuf) |
| 1095 | (looking-at "[a-zA-Z0-9_]+") |
| 1096 | (replace-match "") |
| 1097 | ;; inserts the completed symbol |
| 1098 | (insert completed) |
| 1099 | )) |
| 1100 | |
| 1101 | ;; ----- Cross-referencing ---------------------------------------- |
| 1102 | |
| 1103 | (defun ada-point-and-xref () |
| 1104 | "Jump to the declaration of the entity below the cursor." |
| 1105 | (interactive) |
| 1106 | (mouse-set-point last-input-event) |
| 1107 | (ada-goto-declaration (point))) |
| 1108 | |
| 1109 | (defun ada-point-and-xref-body () |
| 1110 | "Jump to the body of the entity under the cursor." |
| 1111 | (interactive) |
| 1112 | (mouse-set-point last-input-event) |
| 1113 | (ada-goto-body (point))) |
| 1114 | |
| 1115 | (defun ada-goto-body (pos &optional other-frame) |
| 1116 | "Display the body of the entity around POS. |
| 1117 | OTHER-FRAME non-nil means display in another frame. |
| 1118 | If the entity doesn't have a body, display its declaration. |
| 1119 | As a side effect, the buffer for the declaration is also open." |
| 1120 | (interactive "d") |
| 1121 | (ada-goto-declaration pos other-frame) |
| 1122 | |
| 1123 | ;; Temporarily force the display in the same buffer, since we |
| 1124 | ;; already changed previously |
| 1125 | (let ((ada-xref-other-buffer nil)) |
| 1126 | (ada-goto-declaration (point) nil))) |
| 1127 | |
| 1128 | (defun ada-goto-declaration (pos &optional other-frame) |
| 1129 | "Display the declaration of the identifier around POS. |
| 1130 | The declaration is shown in another buffer if `ada-xref-other-buffer' is |
| 1131 | non-nil. |
| 1132 | If OTHER-FRAME is non-nil, display the cross-reference in another frame." |
| 1133 | (interactive "d") |
| 1134 | (ada-require-project-file) |
| 1135 | (push-mark pos) |
| 1136 | (ada-xref-push-pos (buffer-file-name) pos) |
| 1137 | |
| 1138 | ;; First try the standard algorithm by looking into the .ali file, but if |
| 1139 | ;; that file was too old or even did not exist, try to look in the whole |
| 1140 | ;; object path for a possible location. |
| 1141 | (let ((identlist (ada-read-identifier pos))) |
| 1142 | (condition-case err |
| 1143 | (ada-find-in-ali identlist other-frame) |
| 1144 | ;; File not found: print explicit error message |
| 1145 | (error-file-not-found |
| 1146 | (message (concat (error-message-string err) |
| 1147 | (nthcdr 1 err)))) |
| 1148 | |
| 1149 | (error |
| 1150 | (let ((ali-file (ada-get-ali-file-name (ada-file-of identlist)))) |
| 1151 | |
| 1152 | ;; If the ALI file was up-to-date, then we probably have a predefined |
| 1153 | ;; entity, whose references are not given by GNAT |
| 1154 | (if (and (file-exists-p ali-file) |
| 1155 | (file-newer-than-file-p ali-file (ada-file-of identlist))) |
| 1156 | (message "No cross-reference found -- may be a predefined entity.") |
| 1157 | |
| 1158 | ;; Else, look in every ALI file, except if the user doesn't want that |
| 1159 | (if ada-xref-search-with-egrep |
| 1160 | (ada-find-in-src-path identlist other-frame) |
| 1161 | (message "Cross-referencing information is not up-to-date; please recompile.") |
| 1162 | ))))))) |
| 1163 | |
| 1164 | (defun ada-goto-declaration-other-frame (pos) |
| 1165 | "Display the declaration of the identifier around POS. |
| 1166 | The declaration is shown in another frame if `ada-xref-other-buffer' is |
| 1167 | non-nil." |
| 1168 | (interactive "d") |
| 1169 | (ada-goto-declaration pos t)) |
| 1170 | |
| 1171 | (defun ada-remote (command) |
| 1172 | "Return the remote version of COMMAND, or COMMAND if remote_machine is nil." |
| 1173 | (let ((machine (ada-xref-get-project-field 'remote_machine))) |
| 1174 | (if (or (not machine) (string= machine "")) |
| 1175 | command |
| 1176 | (format "%s %s '(%s)'" |
| 1177 | remote-shell-program |
| 1178 | machine |
| 1179 | command)))) |
| 1180 | |
| 1181 | (defun ada-get-absolute-dir-list (dir-list root-dir) |
| 1182 | "Return the list of absolute directories found in DIR-LIST. |
| 1183 | If a directory is a relative directory, ROOT-DIR is prepended. |
| 1184 | Project and environment variables are substituted." |
| 1185 | (mapcar (lambda (x) (expand-file-name x (ada-treat-cmd-string root-dir))) dir-list)) |
| 1186 | |
| 1187 | (defun ada-set-environment () |
| 1188 | "Prepare an environment for Ada compilation. |
| 1189 | This returns a new value to use for `process-environment', |
| 1190 | but does not actually put it into use. |
| 1191 | It modifies the source path and object path with the values found in the |
| 1192 | project file." |
| 1193 | (let ((include (getenv "ADA_INCLUDE_PATH")) |
| 1194 | (objects (getenv "ADA_OBJECTS_PATH")) |
| 1195 | (build-dir (ada-xref-get-project-field 'build_dir))) |
| 1196 | (if include |
| 1197 | (set 'include (concat path-separator include))) |
| 1198 | (if objects |
| 1199 | (set 'objects (concat path-separator objects))) |
| 1200 | (cons |
| 1201 | (concat "ADA_INCLUDE_PATH=" |
| 1202 | (mapconcat (lambda(x) (expand-file-name x build-dir)) |
| 1203 | (ada-xref-get-project-field 'src_dir) |
| 1204 | path-separator) |
| 1205 | include) |
| 1206 | (cons |
| 1207 | (concat "ADA_OBJECTS_PATH=" |
| 1208 | (mapconcat (lambda(x) (expand-file-name x build-dir)) |
| 1209 | (ada-xref-get-project-field 'obj_dir) |
| 1210 | path-separator) |
| 1211 | objects) |
| 1212 | process-environment)))) |
| 1213 | |
| 1214 | (defun ada-compile-application (&optional arg) |
| 1215 | "Compile the application, using the command found in the project file. |
| 1216 | If ARG is not nil, ask for user confirmation." |
| 1217 | (interactive "P") |
| 1218 | (ada-require-project-file) |
| 1219 | (let ((cmd (ada-xref-get-project-field 'make_cmd)) |
| 1220 | (process-environment (ada-set-environment)) |
| 1221 | (compilation-scroll-output t)) |
| 1222 | |
| 1223 | (setq compilation-search-path (ada-xref-get-src-dir-field)) |
| 1224 | |
| 1225 | ;; If no project file was found, ask the user |
| 1226 | (unless cmd |
| 1227 | (setq cmd '("") arg t)) |
| 1228 | |
| 1229 | ;; Make a single command from the list of commands, including the |
| 1230 | ;; commands to run it on a remote machine. |
| 1231 | (setq cmd (ada-remote (mapconcat 'identity cmd ada-command-separator))) |
| 1232 | |
| 1233 | (if (or ada-xref-confirm-compile arg) |
| 1234 | (setq cmd (read-from-minibuffer "enter command to compile: " cmd))) |
| 1235 | |
| 1236 | ;; Insert newlines so as to separate the name of the commands to run |
| 1237 | ;; and the output of the commands. This doesn't work with cmdproxy.exe, |
| 1238 | ;; which gets confused by newline characters. |
| 1239 | (if (not (string-match ".exe" shell-file-name)) |
| 1240 | (setq cmd (concat cmd "\n\n"))) |
| 1241 | |
| 1242 | (compile (ada-quote-cmd cmd)))) |
| 1243 | |
| 1244 | (defun ada-set-main-compile-application () |
| 1245 | "Set main project variable to current buffer, build main." |
| 1246 | (interactive) |
| 1247 | (ada-require-project-file) |
| 1248 | (let* ((file (buffer-file-name (current-buffer))) |
| 1249 | main) |
| 1250 | (if (not file) |
| 1251 | (error "No file for current buffer") |
| 1252 | |
| 1253 | (setq main |
| 1254 | (if file |
| 1255 | (file-name-nondirectory |
| 1256 | (file-name-sans-extension file)) |
| 1257 | "")) |
| 1258 | (ada-xref-set-project-field 'main main) |
| 1259 | (ada-compile-application)))) |
| 1260 | |
| 1261 | (defun ada-compile-current (&optional arg prj-field) |
| 1262 | "Recompile the current file. |
| 1263 | If ARG is non-nil, ask for user confirmation of the command. |
| 1264 | PRJ-FIELD is the name of the field to use in the project file to get the |
| 1265 | command, and should be either `comp_cmd' (default) or `check_cmd'." |
| 1266 | (interactive "P") |
| 1267 | (ada-require-project-file) |
| 1268 | (let* ((field (if prj-field prj-field 'comp_cmd)) |
| 1269 | (cmd (ada-xref-get-project-field field)) |
| 1270 | (process-environment (ada-set-environment)) |
| 1271 | (compilation-scroll-output t)) |
| 1272 | |
| 1273 | (unless cmd |
| 1274 | (setq cmd '("") arg t)) |
| 1275 | |
| 1276 | ;; Make a single command from the list of commands, including the |
| 1277 | ;; commands to run it on a remote machine. |
| 1278 | (setq cmd (ada-remote (mapconcat 'identity cmd ada-command-separator))) |
| 1279 | |
| 1280 | ;; If no project file was found, ask the user |
| 1281 | (if (or ada-xref-confirm-compile arg) |
| 1282 | (setq cmd (read-from-minibuffer "enter command to compile: " cmd))) |
| 1283 | |
| 1284 | (compile (ada-quote-cmd cmd)))) |
| 1285 | |
| 1286 | (defun ada-check-current (&optional arg) |
| 1287 | "Check the current file for syntax errors. |
| 1288 | If ARG is non-nil, ask for user confirmation of the command." |
| 1289 | (interactive "P") |
| 1290 | (ada-compile-current arg 'check_cmd)) |
| 1291 | |
| 1292 | (defun ada-run-application (&optional arg) |
| 1293 | "Run the application. |
| 1294 | If ARG is non-nil, ask for user confirmation." |
| 1295 | (interactive) |
| 1296 | (ada-require-project-file) |
| 1297 | |
| 1298 | (let ((machine (ada-xref-get-project-field 'cross_prefix))) |
| 1299 | (if (and machine (not (string= machine ""))) |
| 1300 | (error "This feature is not supported yet for cross environments"))) |
| 1301 | |
| 1302 | (let ((command (ada-xref-get-project-field 'run_cmd))) |
| 1303 | |
| 1304 | ;; Guess the command if it wasn't specified |
| 1305 | (if (not command) |
| 1306 | (set 'command (list (file-name-sans-extension (buffer-name))))) |
| 1307 | |
| 1308 | ;; Modify the command to run remotely |
| 1309 | (setq command (ada-remote (mapconcat 'identity command |
| 1310 | ada-command-separator))) |
| 1311 | |
| 1312 | ;; Ask for the arguments to the command if required |
| 1313 | (if (or ada-xref-confirm-compile arg) |
| 1314 | (setq command (read-from-minibuffer "Enter command to execute: " |
| 1315 | command))) |
| 1316 | |
| 1317 | ;; Run the command |
| 1318 | (with-current-buffer (get-buffer-create "*run*") |
| 1319 | (set 'buffer-read-only nil) |
| 1320 | |
| 1321 | (erase-buffer) |
| 1322 | (start-process "run" (current-buffer) shell-file-name |
| 1323 | "-c" command) |
| 1324 | (comint-mode) |
| 1325 | ;; Set these two variables to their default values, since otherwise |
| 1326 | ;; the output buffer is scrolled so that only the last output line |
| 1327 | ;; is visible at the top of the buffer. |
| 1328 | (set (make-local-variable 'scroll-step) 0) |
| 1329 | (set (make-local-variable 'scroll-conservatively) 0) |
| 1330 | ) |
| 1331 | (display-buffer "*run*") |
| 1332 | |
| 1333 | ;; change to buffer *run* for interactive programs |
| 1334 | (other-window 1) |
| 1335 | (switch-to-buffer "*run*") |
| 1336 | )) |
| 1337 | |
| 1338 | (defun ada-gdb-application (&optional arg executable-name) |
| 1339 | "Start the debugger on the application. |
| 1340 | If ARG is non-nil, ask the user to confirm the command. |
| 1341 | EXECUTABLE-NAME, if non-nil, is debugged instead of the file specified in the |
| 1342 | project file." |
| 1343 | (interactive "P") |
| 1344 | (ada-require-project-file) |
| 1345 | (let ((buffer (current-buffer)) |
| 1346 | cmd pre-cmd post-cmd) |
| 1347 | (setq cmd (if executable-name |
| 1348 | (concat ada-prj-default-debugger " " executable-name) |
| 1349 | (ada-xref-get-project-field 'debug_cmd)) |
| 1350 | pre-cmd (ada-xref-get-project-field 'debug_pre_cmd) |
| 1351 | post-cmd (ada-xref-get-project-field 'debug_post_cmd)) |
| 1352 | |
| 1353 | ;; If the command was not given in the project file, start a bare gdb |
| 1354 | (if (not cmd) |
| 1355 | (set 'cmd (concat ada-prj-default-debugger |
| 1356 | " " |
| 1357 | (or executable-name |
| 1358 | (file-name-sans-extension (buffer-file-name)))))) |
| 1359 | |
| 1360 | ;; For gvd, add an extra switch so that the Emacs window is completely |
| 1361 | ;; swallowed inside the Gvd one |
| 1362 | (if (and ada-tight-gvd-integration |
| 1363 | (string-match "^[^ \t]*gvd" cmd)) |
| 1364 | ;; Start a new frame, so that when gvd exists we do not kill Emacs |
| 1365 | ;; We make sure that gvd swallows the new frame, not the one the |
| 1366 | ;; user has been using until now |
| 1367 | ;; The frame is made invisible initially, so that GtkPlug gets a |
| 1368 | ;; chance to fully manage it. Then it works fine with Enlightenment |
| 1369 | ;; as well |
| 1370 | (let ((frame (make-frame '((visibility . nil))))) |
| 1371 | (set 'cmd (concat |
| 1372 | cmd " --editor-window=" |
| 1373 | (cdr (assoc 'outer-window-id (frame-parameters frame))))) |
| 1374 | (select-frame frame))) |
| 1375 | |
| 1376 | ;; Add a -fullname switch |
| 1377 | ;; Use the remote machine |
| 1378 | (set 'cmd (ada-remote (concat cmd " -fullname "))) |
| 1379 | |
| 1380 | ;; Ask for confirmation if required |
| 1381 | (if (or arg ada-xref-confirm-compile) |
| 1382 | (set 'cmd (read-from-minibuffer "enter command to debug: " cmd))) |
| 1383 | |
| 1384 | (let ((old-comint-exec (symbol-function 'comint-exec))) |
| 1385 | |
| 1386 | ;; Do not add -fullname, since we can have a 'rsh' command in front. |
| 1387 | ;; FIXME: This is evil but luckily a nop under Emacs-21.3.50 ! -stef |
| 1388 | (fset 'gud-gdb-massage-args (lambda (_file args) args)) |
| 1389 | |
| 1390 | (set 'pre-cmd (mapconcat 'identity pre-cmd ada-command-separator)) |
| 1391 | (if (not (equal pre-cmd "")) |
| 1392 | (setq pre-cmd (concat pre-cmd ada-command-separator))) |
| 1393 | |
| 1394 | (set 'post-cmd (mapconcat 'identity post-cmd "\n")) |
| 1395 | (if post-cmd |
| 1396 | (set 'post-cmd (concat post-cmd "\n"))) |
| 1397 | |
| 1398 | |
| 1399 | ;; Temporarily replaces the definition of `comint-exec' so that we |
| 1400 | ;; can execute commands before running gdb. |
| 1401 | ;; FIXME: This is evil and not temporary !!! -stef |
| 1402 | (fset 'comint-exec |
| 1403 | `(lambda (buffer name command startfile switches) |
| 1404 | (let (compilation-buffer-name-function) |
| 1405 | (save-excursion |
| 1406 | (set 'compilation-buffer-name-function |
| 1407 | (lambda(x) (buffer-name buffer))) |
| 1408 | (compile (ada-quote-cmd |
| 1409 | (concat ,pre-cmd |
| 1410 | command " " |
| 1411 | (mapconcat 'identity switches " ")))))) |
| 1412 | )) |
| 1413 | |
| 1414 | ;; Tight integration should force the tty mode |
| 1415 | (if (and (string-match "gvd" (comint-arguments cmd 0 0)) |
| 1416 | ada-tight-gvd-integration |
| 1417 | (not (string-match "--tty" cmd))) |
| 1418 | (setq cmd (concat cmd "--tty"))) |
| 1419 | |
| 1420 | (if (and (string-match "jdb" (comint-arguments cmd 0 0)) |
| 1421 | (boundp 'jdb)) |
| 1422 | (funcall (symbol-function 'jdb) cmd) |
| 1423 | (gdb cmd)) |
| 1424 | |
| 1425 | ;; Restore the standard fset command (or for instance C-U M-x shell |
| 1426 | ;; wouldn't work anymore |
| 1427 | |
| 1428 | (fset 'comint-exec old-comint-exec) |
| 1429 | |
| 1430 | ;; Send post-commands to the debugger |
| 1431 | (process-send-string (get-buffer-process (current-buffer)) post-cmd) |
| 1432 | |
| 1433 | ;; Move to the end of the debugger buffer, so that it is automatically |
| 1434 | ;; scrolled from then on. |
| 1435 | (goto-char (point-max)) |
| 1436 | |
| 1437 | ;; Display both the source window and the debugger window (the former |
| 1438 | ;; above the latter). No need to show the debugger window unless it |
| 1439 | ;; is going to have some relevant information. |
| 1440 | (if (or (not (string-match "gvd" (comint-arguments cmd 0 0))) |
| 1441 | (string-match "--tty" cmd)) |
| 1442 | (split-window-below)) |
| 1443 | (switch-to-buffer buffer) |
| 1444 | ))) |
| 1445 | |
| 1446 | (defun ada-reread-prj-file (&optional filename) |
| 1447 | "Reread either the current project, or FILENAME if non-nil. |
| 1448 | If FILENAME is non-nil, set it as current project." |
| 1449 | (interactive "P") |
| 1450 | (if (not filename) |
| 1451 | (setq filename ada-prj-default-project-file)) |
| 1452 | (ada-parse-prj-file filename) |
| 1453 | (ada-select-prj-file filename)) |
| 1454 | |
| 1455 | ;; ------ Private routines |
| 1456 | |
| 1457 | (defun ada-xref-current (file &optional ali-file-name) |
| 1458 | "Update the cross-references for FILE. |
| 1459 | This in fact recompiles FILE to create ALI-FILE-NAME. |
| 1460 | This function returns the name of the file that was recompiled to generate |
| 1461 | the cross-reference information. Note that the ali file can then be deduced |
| 1462 | by replacing the file extension with `.ali'." |
| 1463 | ;; kill old buffer |
| 1464 | (if (and ali-file-name |
| 1465 | (get-file-buffer ali-file-name)) |
| 1466 | (kill-buffer (get-file-buffer ali-file-name))) |
| 1467 | |
| 1468 | (let* ((name (ada-convert-file-name file)) |
| 1469 | (body-name (or (ada-get-body-name name) name))) |
| 1470 | |
| 1471 | ;; Always recompile the body when we can. We thus temporarily switch to a |
| 1472 | ;; buffer than contains the body of the unit |
| 1473 | (save-excursion |
| 1474 | (let ((body-visible (find-buffer-visiting body-name)) |
| 1475 | process) |
| 1476 | (if body-visible |
| 1477 | (set-buffer body-visible) |
| 1478 | (find-file body-name)) |
| 1479 | |
| 1480 | ;; Execute the compilation. Note that we must wait for the end of the |
| 1481 | ;; process, or the ALI file would still not be available. |
| 1482 | ;; Unfortunately, the underlying `compile' command that we use is |
| 1483 | ;; asynchronous. |
| 1484 | (ada-compile-current) |
| 1485 | (setq process (get-buffer-process "*compilation*")) |
| 1486 | |
| 1487 | (while (and process |
| 1488 | (not (equal (process-status process) 'exit))) |
| 1489 | (sit-for 1)) |
| 1490 | |
| 1491 | ;; remove the buffer for the body if it wasn't there before |
| 1492 | (unless body-visible |
| 1493 | (kill-buffer (find-buffer-visiting body-name))) |
| 1494 | )) |
| 1495 | body-name)) |
| 1496 | |
| 1497 | (defun ada-find-file-in-dir (file dir-list) |
| 1498 | "Search for FILE in DIR-LIST." |
| 1499 | (let (found) |
| 1500 | (while (and (not found) dir-list) |
| 1501 | (set 'found (concat (file-name-as-directory (car dir-list)) |
| 1502 | (file-name-nondirectory file))) |
| 1503 | |
| 1504 | (unless (file-exists-p found) |
| 1505 | (set 'found nil)) |
| 1506 | (set 'dir-list (cdr dir-list))) |
| 1507 | found)) |
| 1508 | |
| 1509 | (defun ada-find-ali-file-in-dir (file) |
| 1510 | "Find the ali file FILE, searching obj_dir for the current project. |
| 1511 | Adds build_dir in front of the search path to conform to gnatmake's behavior, |
| 1512 | and the standard runtime location at the end." |
| 1513 | (ada-find-file-in-dir file (ada-xref-get-obj-dir-field))) |
| 1514 | |
| 1515 | (defun ada-find-src-file-in-dir (file) |
| 1516 | "Find the source file FILE, searching src_dir for the current project. |
| 1517 | Adds the standard runtime location at the end of the search path to conform |
| 1518 | to gnatmake's behavior." |
| 1519 | (ada-find-file-in-dir file (ada-xref-get-src-dir-field))) |
| 1520 | |
| 1521 | (defun ada-get-ali-file-name (file) |
| 1522 | "Create the ali file name for the Ada file FILE. |
| 1523 | The file is searched for in every directory shown in the obj_dir lines of |
| 1524 | the project file." |
| 1525 | |
| 1526 | ;; This function has to handle the special case of non-standard |
| 1527 | ;; file names (i.e. not .adb or .ads) |
| 1528 | ;; The trick is the following: |
| 1529 | ;; 1- replace the extension of the current file with .ali, |
| 1530 | ;; and look for this file |
| 1531 | ;; 2- If this file is found: |
| 1532 | ;; grep the "^U" lines, and make sure we are not reading the |
| 1533 | ;; .ali file for a spec file. If we are, go to step 3. |
| 1534 | ;; 3- If the file is not found or step 2 failed: |
| 1535 | ;; find the name of the "other file", ie the body, and look |
| 1536 | ;; for its associated .ali file by subtituting the extension |
| 1537 | ;; |
| 1538 | ;; We must also handle the case of separate packages and subprograms: |
| 1539 | ;; 4- If no ali file was found, we try to modify the file name by removing |
| 1540 | ;; everything after the last '-' or '.' character, so as to get the |
| 1541 | ;; ali file for the parent unit. If we found an ali file, we check that |
| 1542 | ;; it indeed contains the definition for the separate entity by checking |
| 1543 | ;; the 'D' lines. This is done repeatedly, in case the direct parent is |
| 1544 | ;; also a separate. |
| 1545 | |
| 1546 | (with-current-buffer (get-file-buffer file) |
| 1547 | (let ((short-ali-file-name |
| 1548 | (concat (file-name-sans-extension (file-name-nondirectory file)) |
| 1549 | ".ali")) |
| 1550 | ali-file-name |
| 1551 | is-spec) |
| 1552 | |
| 1553 | ;; If we have a non-standard file name, and this is a spec, we first |
| 1554 | ;; look for the .ali file of the body, since this is the one that |
| 1555 | ;; contains the most complete information. If not found, we will do what |
| 1556 | ;; we can with the .ali file for the spec... |
| 1557 | |
| 1558 | (if (not (string= (file-name-extension file) "ads")) |
| 1559 | (let ((specs ada-spec-suffixes)) |
| 1560 | (while specs |
| 1561 | (if (string-match (concat (regexp-quote (car specs)) "$") |
| 1562 | file) |
| 1563 | (set 'is-spec t)) |
| 1564 | (set 'specs (cdr specs))))) |
| 1565 | |
| 1566 | (if is-spec |
| 1567 | (set 'ali-file-name |
| 1568 | (ada-find-ali-file-in-dir |
| 1569 | (concat (file-name-sans-extension |
| 1570 | (file-name-nondirectory |
| 1571 | (ada-other-file-name))) |
| 1572 | ".ali")))) |
| 1573 | |
| 1574 | |
| 1575 | (setq ali-file-name |
| 1576 | (or ali-file-name |
| 1577 | |
| 1578 | ;; Else we take the .ali file associated with the unit |
| 1579 | (ada-find-ali-file-in-dir short-ali-file-name) |
| 1580 | |
| 1581 | |
| 1582 | ;; else we did not find the .ali file Second chance: in case |
| 1583 | ;; the files do not have standard names (such as for instance |
| 1584 | ;; file_s.ada and file_b.ada), try to go to the other file |
| 1585 | ;; and look for its ali file |
| 1586 | (ada-find-ali-file-in-dir |
| 1587 | (concat (file-name-sans-extension |
| 1588 | (file-name-nondirectory (ada-other-file-name))) |
| 1589 | ".ali")) |
| 1590 | |
| 1591 | |
| 1592 | ;; If we still don't have an ali file, try to get the one |
| 1593 | ;; from the parent unit, in case we have a separate entity. |
| 1594 | (let ((parent-name (file-name-sans-extension |
| 1595 | (file-name-nondirectory file)))) |
| 1596 | |
| 1597 | (while (and (not ali-file-name) |
| 1598 | (string-match "^\\(.*\\)[.-][^.-]*" parent-name)) |
| 1599 | |
| 1600 | (set 'parent-name (match-string 1 parent-name)) |
| 1601 | (set 'ali-file-name (ada-find-ali-file-in-dir |
| 1602 | (concat parent-name ".ali"))) |
| 1603 | ) |
| 1604 | ali-file-name))) |
| 1605 | |
| 1606 | ;; If still not found, try to recompile the file |
| 1607 | (if (not ali-file-name) |
| 1608 | ;; Recompile only if the user asked for this, and search the ali |
| 1609 | ;; filename again. We avoid a possible infinite recursion by |
| 1610 | ;; temporarily disabling the automatic compilation. |
| 1611 | |
| 1612 | (if ada-xref-create-ali |
| 1613 | (setq ali-file-name |
| 1614 | (concat (file-name-sans-extension (ada-xref-current file)) |
| 1615 | ".ali")) |
| 1616 | |
| 1617 | (error "`.ali' file not found; recompile your source file")) |
| 1618 | |
| 1619 | |
| 1620 | ;; same if the .ali file is too old and we must recompile it |
| 1621 | (if (and (file-newer-than-file-p file ali-file-name) |
| 1622 | ada-xref-create-ali) |
| 1623 | (ada-xref-current file ali-file-name))) |
| 1624 | |
| 1625 | ;; Always return the correct absolute file name |
| 1626 | (expand-file-name ali-file-name)) |
| 1627 | )) |
| 1628 | |
| 1629 | (defun ada-get-ada-file-name (file original-file) |
| 1630 | "Create the complete file name (+directory) for FILE. |
| 1631 | The original file (where the user was) is ORIGINAL-FILE. |
| 1632 | Search in project file for possible paths." |
| 1633 | |
| 1634 | (save-excursion |
| 1635 | |
| 1636 | ;; If the buffer for original-file, use it to get the values from the |
| 1637 | ;; project file, otherwise load the file and its project file |
| 1638 | (let ((buffer (get-file-buffer original-file))) |
| 1639 | (if buffer |
| 1640 | (set-buffer buffer) |
| 1641 | (find-file original-file))) |
| 1642 | |
| 1643 | ;; we choose the first possible completion and we |
| 1644 | ;; return the absolute file name |
| 1645 | (let ((filename (ada-find-src-file-in-dir file))) |
| 1646 | (if filename |
| 1647 | (expand-file-name filename) |
| 1648 | (signal 'error-file-not-found (file-name-nondirectory file))) |
| 1649 | ))) |
| 1650 | |
| 1651 | (defun ada-find-file-number-in-ali (file) |
| 1652 | "Return the file number for FILE in the associated ali file." |
| 1653 | (set-buffer (ada-get-ali-buffer file)) |
| 1654 | (goto-char (point-min)) |
| 1655 | |
| 1656 | (let ((begin (re-search-forward "^D"))) |
| 1657 | (beginning-of-line) |
| 1658 | (re-search-forward (concat "^D " (file-name-nondirectory file))) |
| 1659 | (count-lines begin (point)))) |
| 1660 | |
| 1661 | (defun ada-read-identifier (pos) |
| 1662 | "Return the identlist around POS and switch to the .ali buffer. |
| 1663 | The returned list represents the entity, and can be manipulated through the |
| 1664 | macros `ada-name-of', `ada-line-of', `ada-column-of', `ada-file-of',..." |
| 1665 | |
| 1666 | ;; If at end of buffer (e.g the buffer is empty), error |
| 1667 | (if (>= (point) (point-max)) |
| 1668 | (error "No identifier on point")) |
| 1669 | |
| 1670 | ;; goto first character of the identifier/operator (skip backward < and > |
| 1671 | ;; since they are part of multiple character operators |
| 1672 | (goto-char pos) |
| 1673 | (skip-chars-backward "a-zA-Z0-9_<>") |
| 1674 | |
| 1675 | ;; check if it really is an identifier |
| 1676 | (if (ada-in-comment-p) |
| 1677 | (error "Inside comment")) |
| 1678 | |
| 1679 | (let (identifier identlist) |
| 1680 | ;; Just in front of a string => we could have an operator declaration, |
| 1681 | ;; as in "+", "-", .. |
| 1682 | (if (= (char-after) ?\") |
| 1683 | (forward-char 1)) |
| 1684 | |
| 1685 | ;; if looking at an operator |
| 1686 | ;; This is only true if: |
| 1687 | ;; - the symbol is +, -, ... |
| 1688 | ;; - the symbol is made of letters, and not followed by _ or a letter |
| 1689 | (if (and (looking-at ada-operator-re) |
| 1690 | (or (not (= (char-syntax (char-after)) ?w)) |
| 1691 | (not (or (= (char-syntax (char-after (match-end 0))) ?w) |
| 1692 | (= (char-after (match-end 0)) ?_))))) |
| 1693 | (progn |
| 1694 | (if (and (= (char-before) ?\") |
| 1695 | (= (char-after (+ (length (match-string 0)) (point))) ?\")) |
| 1696 | (forward-char -1)) |
| 1697 | (set 'identifier (regexp-quote (concat "\"" (match-string 0) "\"")))) |
| 1698 | |
| 1699 | (if (ada-in-string-p) |
| 1700 | (error "Inside string or character constant")) |
| 1701 | (if (looking-at (concat ada-keywords "[^a-zA-Z_]")) |
| 1702 | (error "No cross-reference available for reserved keyword")) |
| 1703 | (if (looking-at "[a-zA-Z0-9_]+") |
| 1704 | (set 'identifier (match-string 0)) |
| 1705 | (error "No identifier around"))) |
| 1706 | |
| 1707 | ;; Build the identlist |
| 1708 | (set 'identlist (ada-make-identlist)) |
| 1709 | (ada-set-name identlist (downcase identifier)) |
| 1710 | (ada-set-line identlist |
| 1711 | (number-to-string (count-lines 1 (point)))) |
| 1712 | (ada-set-column identlist |
| 1713 | (number-to-string (1+ (current-column)))) |
| 1714 | (ada-set-file identlist (buffer-file-name)) |
| 1715 | identlist |
| 1716 | )) |
| 1717 | |
| 1718 | (defun ada-get-all-references (identlist) |
| 1719 | "Complete IDENTLIST with definition file and places where it is referenced. |
| 1720 | Information is extracted from the ali file." |
| 1721 | |
| 1722 | (let ((ali-buffer (ada-get-ali-buffer (ada-file-of identlist))) |
| 1723 | declaration-found) |
| 1724 | (set-buffer ali-buffer) |
| 1725 | (goto-char (point-min)) |
| 1726 | (ada-set-on-declaration identlist nil) |
| 1727 | |
| 1728 | ;; First attempt: we might already be on the declaration of the identifier |
| 1729 | ;; We want to look for the declaration only in a definite interval (after |
| 1730 | ;; the "^X ..." line for the current file, and before the next "^X" line |
| 1731 | |
| 1732 | (if (re-search-forward |
| 1733 | (concat "^X [0-9]+ " (file-name-nondirectory (ada-file-of identlist))) |
| 1734 | nil t) |
| 1735 | (let ((bound (save-excursion (re-search-forward "^X " nil t)))) |
| 1736 | (set 'declaration-found |
| 1737 | (re-search-forward |
| 1738 | (concat "^" (ada-line-of identlist) |
| 1739 | "." (ada-column-of identlist) |
| 1740 | "[ *]" (ada-name-of identlist) |
| 1741 | "[{\[\(<= ]?\\(.*\\)$") bound t)) |
| 1742 | (if declaration-found |
| 1743 | (ada-set-on-declaration identlist t)) |
| 1744 | )) |
| 1745 | |
| 1746 | ;; If declaration is still nil, then we were not on a declaration, and |
| 1747 | ;; have to fall back on other algorithms |
| 1748 | |
| 1749 | (unless declaration-found |
| 1750 | |
| 1751 | ;; Since we already know the number of the file, search for a direct |
| 1752 | ;; reference to it |
| 1753 | (goto-char (point-min)) |
| 1754 | (set 'declaration-found t) |
| 1755 | (ada-set-ali-index |
| 1756 | identlist |
| 1757 | (number-to-string (ada-find-file-number-in-ali |
| 1758 | (ada-file-of identlist)))) |
| 1759 | (unless (re-search-forward (concat (ada-ali-index-of identlist) |
| 1760 | "|\\([0-9]+[^0-9][0-9]+\\(\n\\.\\)? \\)*" |
| 1761 | (ada-line-of identlist) |
| 1762 | "[^etpzkd<>=^]" |
| 1763 | (ada-column-of identlist) "\\>") |
| 1764 | nil t) |
| 1765 | |
| 1766 | ;; if we did not find it, it may be because the first reference |
| 1767 | ;; is not required to have a 'unit_number|' item included. |
| 1768 | ;; Or maybe we are already on the declaration... |
| 1769 | (unless (re-search-forward |
| 1770 | (concat |
| 1771 | "^[0-9]+.[0-9]+[ *]" |
| 1772 | (ada-name-of identlist) |
| 1773 | "[ <{=\(\[]\\(.\\|\n\\.\\)*\\<" |
| 1774 | (ada-line-of identlist) |
| 1775 | "[^0-9]" |
| 1776 | (ada-column-of identlist) "\\>") |
| 1777 | nil t) |
| 1778 | |
| 1779 | ;; If still not found, then either the declaration is unknown |
| 1780 | ;; or the source file has been modified since the ali file was |
| 1781 | ;; created |
| 1782 | (set 'declaration-found nil) |
| 1783 | ) |
| 1784 | ) |
| 1785 | |
| 1786 | ;; Last check to be completely sure we have found the correct line (the |
| 1787 | ;; ali might not be up to date for instance) |
| 1788 | (if declaration-found |
| 1789 | (progn |
| 1790 | (beginning-of-line) |
| 1791 | ;; while we have a continuation line, go up one line |
| 1792 | (while (looking-at "^\\.") |
| 1793 | (forward-line -1) |
| 1794 | (beginning-of-line)) |
| 1795 | (unless (looking-at (concat "[0-9]+.[0-9]+[ *]" |
| 1796 | (ada-name-of identlist) "[ <{=\(\[]")) |
| 1797 | (set 'declaration-found nil)))) |
| 1798 | |
| 1799 | ;; Still no success ! The ali file must be too old, and we need to |
| 1800 | ;; use a basic algorithm based on guesses. Note that this only happens |
| 1801 | ;; if the user does not want us to automatically recompile files |
| 1802 | ;; automatically |
| 1803 | (unless declaration-found |
| 1804 | (if (ada-xref-find-in-modified-ali identlist) |
| 1805 | (set 'declaration-found t) |
| 1806 | ;; No more idea to find the declaration. Give up |
| 1807 | (progn |
| 1808 | (kill-buffer ali-buffer) |
| 1809 | |
| 1810 | (error "No declaration of %s found" (ada-name-of identlist)) |
| 1811 | ))) |
| 1812 | ) |
| 1813 | |
| 1814 | |
| 1815 | ;; Now that we have found a suitable line in the .ali file, get the |
| 1816 | ;; information available |
| 1817 | (beginning-of-line) |
| 1818 | (if declaration-found |
| 1819 | (let ((current-line (buffer-substring |
| 1820 | (point) (point-at-eol)))) |
| 1821 | (save-excursion |
| 1822 | (forward-line 1) |
| 1823 | (beginning-of-line) |
| 1824 | (while (looking-at "^\\.\\(.*\\)") |
| 1825 | (set 'current-line (concat current-line (match-string 1))) |
| 1826 | (forward-line 1)) |
| 1827 | ) |
| 1828 | |
| 1829 | (if (re-search-backward "^X [0-9]+ \\([a-zA-Z0-9_.-]+\\)" nil t) |
| 1830 | |
| 1831 | ;; If we can find the file |
| 1832 | (condition-case err |
| 1833 | (ada-set-declare-file |
| 1834 | identlist |
| 1835 | (ada-get-ada-file-name (match-string 1) |
| 1836 | (ada-file-of identlist))) |
| 1837 | |
| 1838 | ;; Else clean up the ali file |
| 1839 | (error-file-not-found |
| 1840 | (signal (car err) (cdr err))) |
| 1841 | (error |
| 1842 | (kill-buffer ali-buffer) |
| 1843 | (error (error-message-string err))) |
| 1844 | )) |
| 1845 | |
| 1846 | (ada-set-references identlist current-line) |
| 1847 | )) |
| 1848 | )) |
| 1849 | |
| 1850 | (defun ada-xref-find-in-modified-ali (identlist) |
| 1851 | "Find the matching position for IDENTLIST in the current ali buffer. |
| 1852 | This function is only called when the file was not up-to-date, so we need |
| 1853 | to make some guesses. |
| 1854 | This function is disabled for operators, and only works for identifiers." |
| 1855 | |
| 1856 | (unless (= (string-to-char (ada-name-of identlist)) ?\") |
| 1857 | (progn |
| 1858 | (let ((declist '()) ;;; ( (line_in_ali_file line_in_ada) ( ... )) |
| 1859 | (my-regexp (concat "[ *]" |
| 1860 | (regexp-quote (ada-name-of identlist)) " ")) |
| 1861 | (line-ada "--") |
| 1862 | (col-ada "--") |
| 1863 | (line-ali 0) |
| 1864 | (len 0) |
| 1865 | (choice 0) |
| 1866 | (ali-buffer (current-buffer))) |
| 1867 | |
| 1868 | (goto-char (point-max)) |
| 1869 | (while (re-search-backward my-regexp nil t) |
| 1870 | (save-excursion |
| 1871 | (set 'line-ali (count-lines 1 (point))) |
| 1872 | (beginning-of-line) |
| 1873 | ;; have a look at the line and column numbers |
| 1874 | (if (looking-at "^\\([0-9]+\\).\\([0-9]+\\)[ *]") |
| 1875 | (progn |
| 1876 | (setq line-ada (match-string 1)) |
| 1877 | (setq col-ada (match-string 2))) |
| 1878 | (setq line-ada "--") |
| 1879 | (setq col-ada "--") |
| 1880 | ) |
| 1881 | ;; construct a list with the file names and the positions within |
| 1882 | (if (re-search-backward "^X [0-9]+ \\([a-zA-Z0-9._-]+\\)" nil t) |
| 1883 | (add-to-list |
| 1884 | 'declist (list line-ali (match-string 1) line-ada col-ada)) |
| 1885 | ) |
| 1886 | ) |
| 1887 | ) |
| 1888 | |
| 1889 | ;; how many possible declarations have we found ? |
| 1890 | (setq len (length declist)) |
| 1891 | (cond |
| 1892 | ;; none => error |
| 1893 | ((= len 0) |
| 1894 | (kill-buffer (current-buffer)) |
| 1895 | (error "No declaration of %s recorded in .ali file" |
| 1896 | (ada-name-of identlist))) |
| 1897 | ;; one => should be the right one |
| 1898 | ((= len 1) |
| 1899 | (goto-char (point-min)) |
| 1900 | (forward-line (1- (caar declist)))) |
| 1901 | |
| 1902 | ;; more than one => display choice list |
| 1903 | (t |
| 1904 | (save-window-excursion |
| 1905 | (with-output-to-temp-buffer "*choice list*" |
| 1906 | |
| 1907 | (princ "Identifier is overloaded and Xref information is not up to date.\n") |
| 1908 | (princ "Possible declarations are:\n\n") |
| 1909 | (princ " no. in file at line col\n") |
| 1910 | (princ " --- --------------------- ---- ----\n") |
| 1911 | (let ((counter 0)) |
| 1912 | (while (< counter len) |
| 1913 | (princ (format " %2d) %-21s %4s %4s\n" |
| 1914 | (1+ counter) |
| 1915 | (ada-get-ada-file-name |
| 1916 | (nth 1 (nth counter declist)) |
| 1917 | (ada-file-of identlist)) |
| 1918 | (nth 2 (nth counter declist)) |
| 1919 | (nth 3 (nth counter declist)) |
| 1920 | )) |
| 1921 | (setq counter (1+ counter)) |
| 1922 | ) ; end of while |
| 1923 | ) ; end of let |
| 1924 | ) ; end of with-output-to ... |
| 1925 | (setq choice nil) |
| 1926 | (while (or |
| 1927 | (not choice) |
| 1928 | (not (integerp choice)) |
| 1929 | (< choice 1) |
| 1930 | (> choice len)) |
| 1931 | (setq choice |
| 1932 | (string-to-number |
| 1933 | (read-from-minibuffer "Enter No. of your choice: ")))) |
| 1934 | ) |
| 1935 | (set-buffer ali-buffer) |
| 1936 | (goto-char (point-min)) |
| 1937 | (forward-line (1- (car (nth (1- choice) declist)))) |
| 1938 | )))))) |
| 1939 | |
| 1940 | |
| 1941 | (defun ada-find-in-ali (identlist &optional other-frame) |
| 1942 | "Look in the .ali file for the definition of the identifier in IDENTLIST. |
| 1943 | If OTHER-FRAME is non-nil, and `ada-xref-other-buffer' is non-nil, |
| 1944 | opens a new window to show the declaration." |
| 1945 | |
| 1946 | (ada-get-all-references identlist) |
| 1947 | (let ((ali-line (ada-references-of identlist)) |
| 1948 | (locations nil) |
| 1949 | (start 0) |
| 1950 | file line col) |
| 1951 | |
| 1952 | ;; Note: in some cases, an entity can have multiple references to the |
| 1953 | ;; bodies (this is for instance the case for a separate subprogram, that |
| 1954 | ;; has a reference both to the stub and to the real body). |
| 1955 | ;; In that case, we simply go to each one in turn. |
| 1956 | |
| 1957 | ;; Get all the possible locations |
| 1958 | (string-match "^\\([0-9]+\\)[a-zA-Z+*]\\([0-9]+\\)[ *]" ali-line) |
| 1959 | (set 'locations (list (list (match-string 1 ali-line) ;; line |
| 1960 | (match-string 2 ali-line) ;; column |
| 1961 | (ada-declare-file-of identlist)))) |
| 1962 | (while (string-match "\\([0-9]+\\)[bc]\\(<[^>]+>\\)?\\([0-9]+\\)" |
| 1963 | ali-line start) |
| 1964 | (setq line (match-string 1 ali-line) |
| 1965 | col (match-string 3 ali-line) |
| 1966 | start (match-end 3)) |
| 1967 | |
| 1968 | ;; it there was a file number in the same line |
| 1969 | ;; Make sure we correctly handle the case where the first file reference |
| 1970 | ;; on the line is the type reference. |
| 1971 | ;; 1U2 T(2|2r3) 34r23 |
| 1972 | (if (string-match (concat "[^{(<0-9]\\([0-9]+\\)|\\([^|bc]+\\)?" |
| 1973 | (match-string 0 ali-line)) |
| 1974 | ali-line) |
| 1975 | (let ((file-number (match-string 1 ali-line))) |
| 1976 | (goto-char (point-min)) |
| 1977 | (re-search-forward "^D \\([a-zA-Z0-9_.-]+\\)" nil t |
| 1978 | (string-to-number file-number)) |
| 1979 | (set 'file (match-string 1)) |
| 1980 | ) |
| 1981 | ;; Else get the nearest file |
| 1982 | (set 'file (ada-declare-file-of identlist))) |
| 1983 | |
| 1984 | (set 'locations (append locations (list (list line col file))))) |
| 1985 | |
| 1986 | ;; Add the specs at the end again, so that from the last body we go to |
| 1987 | ;; the specs |
| 1988 | (set 'locations (append locations (list (car locations)))) |
| 1989 | |
| 1990 | ;; Find the new location we want to go to. |
| 1991 | ;; If we are on none of the locations listed, we simply go to the specs. |
| 1992 | |
| 1993 | (setq line (caar locations) |
| 1994 | col (nth 1 (car locations)) |
| 1995 | file (nth 2 (car locations))) |
| 1996 | |
| 1997 | (while locations |
| 1998 | (if (and (string= (caar locations) (ada-line-of identlist)) |
| 1999 | (string= (nth 1 (car locations)) (ada-column-of identlist)) |
| 2000 | (string= (file-name-nondirectory (nth 2 (car locations))) |
| 2001 | (file-name-nondirectory (ada-file-of identlist)))) |
| 2002 | (setq locations (cadr locations) |
| 2003 | line (car locations) |
| 2004 | col (nth 1 locations) |
| 2005 | file (nth 2 locations) |
| 2006 | locations nil) |
| 2007 | (set 'locations (cdr locations)))) |
| 2008 | |
| 2009 | ;; Find the file in the source path |
| 2010 | (set 'file (ada-get-ada-file-name file (ada-file-of identlist))) |
| 2011 | |
| 2012 | ;; Kill the .ali buffer |
| 2013 | (kill-buffer (current-buffer)) |
| 2014 | |
| 2015 | ;; Now go to the buffer |
| 2016 | (ada-xref-change-buffer file |
| 2017 | (string-to-number line) |
| 2018 | (1- (string-to-number col)) |
| 2019 | identlist |
| 2020 | other-frame) |
| 2021 | )) |
| 2022 | |
| 2023 | (defun ada-find-in-src-path (identlist &optional other-frame) |
| 2024 | "More general function for cross-references. |
| 2025 | This function should be used when the standard algorithm that parses the |
| 2026 | .ali file has failed, either because that file was too old or even did not |
| 2027 | exist. |
| 2028 | This function attempts to find the possible declarations for the identifier |
| 2029 | anywhere in the object path. |
| 2030 | This command requires the external `egrep' program to be available. |
| 2031 | |
| 2032 | This works well when one is using an external library and wants to find |
| 2033 | the declaration and documentation of the subprograms one is using." |
| 2034 | ;; FIXME: what does this function do? |
| 2035 | (let (list |
| 2036 | (dirs (ada-xref-get-obj-dir-field)) |
| 2037 | (regexp (concat "[ *]" (ada-name-of identlist))) |
| 2038 | line column |
| 2039 | choice |
| 2040 | file) |
| 2041 | |
| 2042 | ;; Do the grep in all the directories. We do multiple shell |
| 2043 | ;; commands instead of one in case there is no .ali file in one |
| 2044 | ;; of the directory and the shell stops because of that. |
| 2045 | |
| 2046 | (with-current-buffer (get-buffer-create "*grep*") |
| 2047 | (while dirs |
| 2048 | (insert (shell-command-to-string |
| 2049 | (concat |
| 2050 | "grep -E -i -h " |
| 2051 | (shell-quote-argument (concat "^X|" regexp "( |$)")) |
| 2052 | " " |
| 2053 | (shell-quote-argument (file-name-as-directory (car dirs))) |
| 2054 | "*.ali"))) |
| 2055 | (set 'dirs (cdr dirs))) |
| 2056 | |
| 2057 | ;; Now parse the output |
| 2058 | (set 'case-fold-search t) |
| 2059 | (goto-char (point-min)) |
| 2060 | (while (re-search-forward regexp nil t) |
| 2061 | (save-excursion |
| 2062 | (beginning-of-line) |
| 2063 | (if (not (= (char-after) ?X)) |
| 2064 | (progn |
| 2065 | (looking-at "\\([0-9]+\\).\\([0-9]+\\)") |
| 2066 | (setq line (match-string 1) |
| 2067 | column (match-string 2)) |
| 2068 | (re-search-backward "^X [0-9]+ \\(.*\\)$") |
| 2069 | (set 'file (list (match-string 1) line column)) |
| 2070 | |
| 2071 | ;; There could be duplicate choices, because of the structure |
| 2072 | ;; of the .ali files |
| 2073 | (unless (member file list) |
| 2074 | (set 'list (append list (list file)))))))) |
| 2075 | |
| 2076 | ;; Current buffer is still "*grep*" |
| 2077 | (kill-buffer "*grep*") |
| 2078 | ) |
| 2079 | |
| 2080 | ;; Now display the list of possible matches |
| 2081 | (cond |
| 2082 | |
| 2083 | ;; No choice found => Error |
| 2084 | ((null list) |
| 2085 | (error "No cross-reference found, please recompile your file")) |
| 2086 | |
| 2087 | ;; Only one choice => Do the cross-reference |
| 2088 | ((= (length list) 1) |
| 2089 | (set 'file (ada-find-src-file-in-dir (caar list))) |
| 2090 | (if file |
| 2091 | (ada-xref-change-buffer file |
| 2092 | (string-to-number (nth 1 (car list))) |
| 2093 | (string-to-number (nth 2 (car list))) |
| 2094 | identlist |
| 2095 | other-frame) |
| 2096 | (error "%s not found in src_dir" (caar list))) |
| 2097 | (message "This is only a (good) guess at the cross-reference.") |
| 2098 | ) |
| 2099 | |
| 2100 | ;; Else, ask the user |
| 2101 | (t |
| 2102 | (save-window-excursion |
| 2103 | (with-output-to-temp-buffer "*choice list*" |
| 2104 | |
| 2105 | (princ "Identifier is overloaded and Xref information is not up to date.\n") |
| 2106 | (princ "Possible declarations are:\n\n") |
| 2107 | (princ " no. in file at line col\n") |
| 2108 | (princ " --- --------------------- ---- ----\n") |
| 2109 | (let ((counter 0)) |
| 2110 | (while (< counter (length list)) |
| 2111 | (princ (format " %2d) %-21s %4s %4s\n" |
| 2112 | (1+ counter) |
| 2113 | (nth 0 (nth counter list)) |
| 2114 | (nth 1 (nth counter list)) |
| 2115 | (nth 2 (nth counter list)) |
| 2116 | )) |
| 2117 | (setq counter (1+ counter)) |
| 2118 | ))) |
| 2119 | (setq choice nil) |
| 2120 | (while (or (not choice) |
| 2121 | (not (integerp choice)) |
| 2122 | (< choice 1) |
| 2123 | (> choice (length list))) |
| 2124 | (setq choice |
| 2125 | (string-to-number |
| 2126 | (read-from-minibuffer "Enter No. of your choice: ")))) |
| 2127 | ) |
| 2128 | (set 'choice (1- choice)) |
| 2129 | (kill-buffer "*choice list*") |
| 2130 | |
| 2131 | (set 'file (ada-find-src-file-in-dir (car (nth choice list)))) |
| 2132 | (if file |
| 2133 | (ada-xref-change-buffer file |
| 2134 | (string-to-number (nth 1 (nth choice list))) |
| 2135 | (string-to-number (nth 2 (nth choice list))) |
| 2136 | identlist |
| 2137 | other-frame) |
| 2138 | (signal 'error-file-not-found (car (nth choice list)))) |
| 2139 | (message "This is only a (good) guess at the cross-reference.") |
| 2140 | )))) |
| 2141 | |
| 2142 | (defun ada-xref-change-buffer |
| 2143 | (file line column identlist &optional other-frame) |
| 2144 | "Select and display FILE, at LINE and COLUMN. |
| 2145 | If we do not end on the same identifier as IDENTLIST, find the |
| 2146 | closest match. Kills the .ali buffer at the end. |
| 2147 | If OTHER-FRAME is non-nil, creates a new frame to show the file." |
| 2148 | |
| 2149 | (let (declaration-buffer) |
| 2150 | |
| 2151 | ;; Select and display the destination buffer |
| 2152 | (if ada-xref-other-buffer |
| 2153 | (if other-frame |
| 2154 | (find-file-other-frame file) |
| 2155 | (set 'declaration-buffer (find-file-noselect file)) |
| 2156 | (set-buffer declaration-buffer) |
| 2157 | (switch-to-buffer-other-window declaration-buffer) |
| 2158 | ) |
| 2159 | (find-file file) |
| 2160 | ) |
| 2161 | |
| 2162 | ;; move the cursor to the correct position |
| 2163 | (push-mark) |
| 2164 | (goto-char (point-min)) |
| 2165 | (forward-line (1- line)) |
| 2166 | (move-to-column column) |
| 2167 | |
| 2168 | ;; If we are not on the identifier, the ali file was not up-to-date. |
| 2169 | ;; Try to find the nearest position where the identifier is found, |
| 2170 | ;; this is probably the right one. |
| 2171 | (unless (looking-at (ada-name-of identlist)) |
| 2172 | (ada-xref-search-nearest (ada-name-of identlist))) |
| 2173 | )) |
| 2174 | |
| 2175 | |
| 2176 | (defun ada-xref-search-nearest (name) |
| 2177 | "Search for NAME nearest to the position recorded in the Xref file. |
| 2178 | Return the position of the declaration in the buffer, or nil if not found." |
| 2179 | (let ((orgpos (point)) |
| 2180 | (newpos nil) |
| 2181 | (diff nil)) |
| 2182 | |
| 2183 | (goto-char (point-max)) |
| 2184 | |
| 2185 | ;; loop - look for all declarations of name in this file |
| 2186 | (while (search-backward name nil t) |
| 2187 | |
| 2188 | ;; check if it really is a complete Ada identifier |
| 2189 | (if (and |
| 2190 | (not (save-excursion |
| 2191 | (goto-char (match-end 0)) |
| 2192 | (looking-at "_"))) |
| 2193 | (not (ada-in-string-or-comment-p)) |
| 2194 | (or |
| 2195 | ;; variable declaration ? |
| 2196 | (save-excursion |
| 2197 | (skip-chars-forward "a-zA-Z_0-9" ) |
| 2198 | (ada-goto-next-non-ws) |
| 2199 | (looking-at ":[^=]")) |
| 2200 | ;; procedure, function, task or package declaration ? |
| 2201 | (save-excursion |
| 2202 | (ada-goto-previous-word) |
| 2203 | (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]\\>")))) |
| 2204 | |
| 2205 | ;; check if it is nearer than the ones before if any |
| 2206 | (if (or (not diff) |
| 2207 | (< (abs (- (point) orgpos)) diff)) |
| 2208 | (progn |
| 2209 | (setq newpos (point) |
| 2210 | diff (abs (- newpos orgpos)))))) |
| 2211 | ) |
| 2212 | |
| 2213 | (if newpos |
| 2214 | (progn |
| 2215 | (message "ATTENTION: this declaration is only a (good) guess ...") |
| 2216 | (goto-char newpos)) |
| 2217 | nil))) |
| 2218 | |
| 2219 | |
| 2220 | ;; Find the parent library file of the current file |
| 2221 | (defun ada-goto-parent () |
| 2222 | "Go to the parent library file." |
| 2223 | (interactive) |
| 2224 | (ada-require-project-file) |
| 2225 | |
| 2226 | (let ((buffer (ada-get-ali-buffer (buffer-file-name))) |
| 2227 | (unit-name nil) |
| 2228 | (body-name nil) |
| 2229 | (ali-name nil)) |
| 2230 | (with-current-buffer buffer |
| 2231 | (goto-char (point-min)) |
| 2232 | (re-search-forward "^U \\([^ \t%]+\\)%[bs][ \t]+\\([^ \t]+\\)") |
| 2233 | (setq unit-name (match-string 1)) |
| 2234 | (if (not (string-match "\\(.*\\)\\.[^.]+" unit-name)) |
| 2235 | (progn |
| 2236 | (kill-buffer buffer) |
| 2237 | (error "No parent unit !")) |
| 2238 | (setq unit-name (match-string 1 unit-name)) |
| 2239 | ) |
| 2240 | |
| 2241 | ;; look for the file name for the parent unit specification |
| 2242 | (goto-char (point-min)) |
| 2243 | (re-search-forward (concat "^W " unit-name |
| 2244 | "%s[ \t]+\\([^ \t]+\\)[ \t]+" |
| 2245 | "\\([^ \t\n]+\\)")) |
| 2246 | (setq body-name (match-string 1)) |
| 2247 | (setq ali-name (match-string 2)) |
| 2248 | (kill-buffer buffer) |
| 2249 | ) |
| 2250 | |
| 2251 | (setq ali-name (ada-find-ali-file-in-dir ali-name)) |
| 2252 | |
| 2253 | (save-excursion |
| 2254 | ;; Tries to open the new ali file to find the spec file |
| 2255 | (if ali-name |
| 2256 | (progn |
| 2257 | (find-file ali-name) |
| 2258 | (goto-char (point-min)) |
| 2259 | (re-search-forward (concat "^U " unit-name "%s[ \t]+" |
| 2260 | "\\([^ \t]+\\)")) |
| 2261 | (setq body-name (match-string 1)) |
| 2262 | (kill-buffer (current-buffer)) |
| 2263 | ) |
| 2264 | ) |
| 2265 | ) |
| 2266 | |
| 2267 | (find-file body-name) |
| 2268 | )) |
| 2269 | |
| 2270 | (defun ada-make-filename-from-adaname (adaname) |
| 2271 | "Determine the filename in which ADANAME is found. |
| 2272 | This is a GNAT specific function that uses gnatkrunch." |
| 2273 | (let ((krunch-buf (generate-new-buffer "*gkrunch*")) |
| 2274 | (cross-prefix (plist-get (cdr (ada-xref-current-project)) 'cross_prefix))) |
| 2275 | (with-current-buffer krunch-buf |
| 2276 | ;; send adaname to external process `gnatkr'. |
| 2277 | ;; Add a dummy extension, since gnatkr versions have two different |
| 2278 | ;; behaviors depending on the version: |
| 2279 | ;; Up to 3.15: "AA.BB.CC" => aa-bb-cc |
| 2280 | ;; After: "AA.BB.CC" => aa-bb.cc |
| 2281 | (call-process (concat cross-prefix "gnatkr") nil krunch-buf nil |
| 2282 | (concat adaname ".adb") ada-krunch-args) |
| 2283 | ;; fetch output of that process |
| 2284 | (setq adaname (buffer-substring |
| 2285 | (point-min) |
| 2286 | (progn |
| 2287 | (goto-char (point-min)) |
| 2288 | (end-of-line) |
| 2289 | (point)))) |
| 2290 | ;; Remove the extra extension we added above |
| 2291 | (setq adaname (substring adaname 0 -4)) |
| 2292 | |
| 2293 | (kill-buffer krunch-buf))) |
| 2294 | adaname |
| 2295 | ) |
| 2296 | |
| 2297 | (defun ada-make-body-gnatstub (&optional interactive) |
| 2298 | "Create an Ada package body in the current buffer. |
| 2299 | This function uses the `gnat stub' program to create the body. |
| 2300 | This function typically is to be hooked into `ff-file-created-hook'. |
| 2301 | If INTERACTIVE is nil, assume this is called from `ff-file-created-hook'." |
| 2302 | (interactive "p") |
| 2303 | (ada-require-project-file) |
| 2304 | |
| 2305 | ;; If not interactive, assume we are being called from |
| 2306 | ;; ff-file-created-hook. Then the current buffer is for the body |
| 2307 | ;; file, but we will create a new one after gnat stub runs |
| 2308 | (unless interactive |
| 2309 | (set-buffer-modified-p nil) |
| 2310 | (kill-buffer (current-buffer))) |
| 2311 | |
| 2312 | (save-some-buffers nil nil) |
| 2313 | |
| 2314 | ;; Make sure the current buffer is the spec, so gnat stub gets the |
| 2315 | ;; right package parameter (this might not be the case if for |
| 2316 | ;; instance the user was asked for a project file) |
| 2317 | |
| 2318 | (unless (buffer-file-name (car (buffer-list))) |
| 2319 | (set-buffer (cadr (buffer-list)))) |
| 2320 | |
| 2321 | ;; Call the external process |
| 2322 | (let* ((project-plist (cdr (ada-xref-current-project))) |
| 2323 | (gnatstub-opts (ada-treat-cmd-string ada-gnatstub-opts)) |
| 2324 | (gpr-file (plist-get project-plist 'gpr_file)) |
| 2325 | (filename (buffer-file-name (car (buffer-list)))) |
| 2326 | (output (concat (file-name-sans-extension filename) ".adb")) |
| 2327 | (cross-prefix (plist-get project-plist 'cross_prefix)) |
| 2328 | (gnatstub-cmd (concat cross-prefix "gnat stub" |
| 2329 | (if (not (string= gpr-file "")) |
| 2330 | (concat " -P\"" gpr-file "\"")) |
| 2331 | " " gnatstub-opts " " filename)) |
| 2332 | (buffer (get-buffer-create "*gnat stub*"))) |
| 2333 | |
| 2334 | (with-current-buffer buffer |
| 2335 | (compilation-minor-mode 1) |
| 2336 | (erase-buffer) |
| 2337 | (insert gnatstub-cmd) |
| 2338 | (newline) |
| 2339 | ) |
| 2340 | |
| 2341 | (call-process shell-file-name nil buffer nil "-c" gnatstub-cmd) |
| 2342 | |
| 2343 | ;; clean up the output |
| 2344 | |
| 2345 | (if (file-exists-p output) |
| 2346 | (progn |
| 2347 | (find-file output) |
| 2348 | (kill-buffer buffer)) |
| 2349 | |
| 2350 | ;; file not created; display the error message |
| 2351 | (display-buffer buffer)))) |
| 2352 | |
| 2353 | (defun ada-xref-initialize () |
| 2354 | "Function called by `ada-mode-hook' to initialize the ada-xref.el package. |
| 2355 | For instance, it creates the gnat-specific menus, sets some hooks for |
| 2356 | `find-file'." |
| 2357 | (remove-hook 'ff-file-created-hook 'ada-make-body) ; from global hook |
| 2358 | (remove-hook 'ff-file-created-hook 'ada-make-body t) ; from local hook |
| 2359 | (add-hook 'ff-file-created-hook 'ada-make-body-gnatstub nil t) |
| 2360 | |
| 2361 | ;; Completion for file names in the mini buffer should ignore .ali files |
| 2362 | (add-to-list 'completion-ignored-extensions ".ali") |
| 2363 | |
| 2364 | (ada-xref-update-project-menu) |
| 2365 | ) |
| 2366 | |
| 2367 | ;; ----- Add to ada-mode-hook --------------------------------------------- |
| 2368 | |
| 2369 | ;; This must be done before initializing the Ada menu. |
| 2370 | (add-hook 'ada-mode-hook 'ada-xref-initialize) |
| 2371 | |
| 2372 | ;; Define a new error type |
| 2373 | (put 'error-file-not-found |
| 2374 | 'error-conditions |
| 2375 | '(error ada-mode-errors error-file-not-found)) |
| 2376 | (put 'error-file-not-found |
| 2377 | 'error-message |
| 2378 | "File not found in src-dir (check project file): ") |
| 2379 | |
| 2380 | (provide 'ada-xref) |
| 2381 | |
| 2382 | ;;; ada-xref.el ends here |