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