code.delx.au - gnu-emacs-elpa/blob - packages/ada-mode/gpr-query.el

   1 ;; gpr-query.el --- Minor mode for navigating sources using gpr_query  -*- lexical-binding:t -*-
   2 ;;
   3 ;; gpr-query supports Ada and any gcc language that supports the
   4 ;; AdaCore -fdump-xref switch (which includes C, C++).
   5 ;;
   6 ;; Copyright (C) 2013 - 2015  Free Software Foundation, Inc.
   7
   8 ;; Author: Stephen Leake <stephen_leake@member.fsf.org>
   9 ;; Maintainer: Stephen Leake <stephen_leake@member.fsf.org>
  10 ;; Version: 1.0
  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 ;;; Usage:
  28 ;;
  29 ;; M-x gpr-query
  30
  31 (require 'ada-mode-compat-24.2)
  32
  33 (require 'ada-mode) ;; for ada-prj-*, some other things
  34 (require 'gnat-core)
  35 (require 'cl-lib)
  36 (require 'compile)
  37
  38 ;;;;; sessions
  39
  40 ;; gpr_query reads the project files and the database at startup,
  41 ;; which is noticeably slow for a reasonably sized project. But
  42 ;; running queries after startup is fast. So we leave gpr_query
  43 ;; running, and send it new queries via stdin, getting responses via
  44 ;; stdout.
  45 ;;
  46 ;; We maintain a cache of active sessions, one per gnat project.
  47
  48 (cl-defstruct (gpr-query--session)
  49   (process nil) ;; running gpr_query
  50   (buffer nil)) ;; receives output of gpr_query
  51
  52 (defconst gpr-query-buffer-name-prefix " *gpr_query-")
  53
  54 (defun gpr-query--start-process (session)
  55   "Start the session process running gpr_query."
  56   (unless (buffer-live-p (gpr-query--session-buffer session))
  57     ;; user may have killed buffer
  58     (setf (gpr-query--session-buffer session) (gnat-run-buffer gpr-query-buffer-name-prefix)))
  59
  60   (with-current-buffer (gpr-query--session-buffer session)
  61     (let ((process-environment (ada-prj-get 'proc_env)) ;; for GPR_PROJECT_PATH
  62
  63           (project-file (file-name-nondirectory (ada-prj-get 'gpr_file))))
  64       (erase-buffer); delete any previous messages, prompt
  65       (setf (gpr-query--session-process session)
  66             ;; gnatcoll-1.6 can't handle aggregate projects; M910-032
  67             ;; gpr_query can handle some aggregate projects, but not all
  68             (start-process (concat "gpr_query " (buffer-name))
  69                            (gpr-query--session-buffer session)
  70                            "gpr_query"
  71                            (concat "--project=" project-file)))
  72       (set-process-query-on-exit-flag (gpr-query--session-process session) nil)
  73       (gpr-query-session-wait session)
  74
  75       ;; Check for warnings about invalid directories etc. But some
  76       ;; warnings are tolerable, so only abort if process actually
  77       ;; died.
  78       (if (process-live-p (gpr-query--session-process session))
  79           (progn
  80             (goto-char (point-min))
  81             (when (search-forward "warning:" nil t)
  82               (beep)
  83               (message "gpr_query warnings")))
  84
  85         (error "gpr-query process failed to start"))
  86       )))
  87
  88 (defun gpr-query--make-session ()
  89   "Create and return a session for the current project file."
  90   (let ((session
  91          (make-gpr-query--session
  92           :buffer (gnat-run-buffer gpr-query-buffer-name-prefix))))
  93     (gpr-query--start-process session)
  94     session))
  95
  96 (defvar gpr-query--sessions '()
  97   "Assoc list of sessions, indexed by absolute GNAT project file name.")
  98
  99 (defun gpr-query-cached-session ()
 100   "Return a session for the current project file, creating it if necessary."
 101   (let* ((session (cdr (assoc ada-prj-current-file gpr-query--sessions))))
 102     (if session
 103         (progn
 104           (unless (process-live-p (gpr-query--session-process session))
 105             (gpr-query--start-process session))
 106           session)
 107       ;; else
 108       (prog1
 109           (setq session (gpr-query--make-session))
 110         (setq gpr-query--sessions
 111               (cl-acons ada-prj-current-file session gpr-query--sessions))))
 112     ))
 113
 114 (defconst gpr-query-prompt "^>>> $"
 115   ;; gpr_query output ends with this
 116   "Regexp matching gpr_query prompt; indicates previous command is complete.")
 117
 118 (defun gpr-query-session-wait (session)
 119   "Wait for the current command to complete."
 120   (unless (process-live-p (gpr-query--session-process session))
 121     (gpr-query-show-buffer session)
 122     (error "gpr-query process died"))
 123
 124   (with-current-buffer (gpr-query--session-buffer session)
 125     (let ((process (gpr-query--session-process session))
 126           (search-start (point-min))
 127           (wait-count 0))
 128       (while (and (process-live-p process)
 129                   (progn
 130                     ;; process output is inserted before point, so move back over it to search it
 131                     (goto-char search-start)
 132                     (not (re-search-forward gpr-query-prompt (point-max) 1))))
 133         (setq search-start (point));; don't search same text again
 134         (message (concat "running gpr_query ..." (make-string wait-count ?.)))
 135         ;; IMPROVEME: use --display-progress
 136         (accept-process-output process 1.0)
 137         (setq wait-count (1+ wait-count)))
 138       (if (process-live-p process)
 139           (message (concat "running gpr_query ... done"))
 140         (gpr-query-show-buffer session)
 141         (error "gpr_query process died"))
 142       )))
 143
 144 (defun gpr-require-prj ()
 145   "Throw error if no project file defined."
 146   (unless (or (ada-prj-get 'gpr_file)
 147               (ada-prj-get 'gpr_query_file))
 148     (error "no gpr project file defined.")))
 149
 150 (defun gpr-query-session-send (cmd wait)
 151   "Send CMD to gpr_query session for current project.
 152 If WAIT is non-nil, wait for command to complete.
 153 Return buffer that holds output."
 154   (gpr-require-prj)
 155   (let ((session (gpr-query-cached-session)))
 156     ;; always wait for previous command to complete; also checks for
 157     ;; dead process.
 158     (gpr-query-session-wait session)
 159     (with-current-buffer (gpr-query--session-buffer session)
 160       (erase-buffer)
 161       (process-send-string (gpr-query--session-process session)
 162                            (concat cmd "\n"))
 163       (when wait
 164         (gpr-query-session-wait session))
 165       (current-buffer)
 166       )))
 167
 168 (defun gpr-query-kill-session (session)
 169   (let ((process (gpr-query--session-process session)))
 170     (when (process-live-p process)
 171       (process-send-string (gpr-query--session-process session) "exit\n")
 172       (while (process-live-p process)
 173         (accept-process-output process 1.0)))
 174     ))
 175
 176 (defun gpr-query-kill-all-sessions ()
 177   (interactive)
 178   (let ((count 0))
 179     (mapc (lambda (assoc)
 180             (let ((session (cdr assoc)))
 181               (when (process-live-p (gpr-query--session-process session))
 182                 (setq count (1+ count))
 183                 (process-send-string (gpr-query--session-process session) "exit\n")
 184                 )))
 185             gpr-query--sessions)
 186     (message "Killed %d sessions" count)
 187     ))
 188
 189 (defun gpr-query-show-buffer (&optional session)
 190   "For `ada-show-xref-tool-buffer'; show gpr-query buffer for current project."
 191   (interactive)
 192   (pop-to-buffer (gpr-query--session-buffer (or session (gpr-query-cached-session)))))
 193
 194 ;;;;; utils
 195
 196 (defun gpr-query-get-src-dirs (src-dirs)
 197   "Append list of source dirs in current gpr project to SRC-DIRS.
 198 Uses `gpr_query'. Returns new list."
 199
 200   (with-current-buffer (gpr-query--session-buffer (gpr-query-cached-session))
 201     (gpr-query-session-send "source_dirs" t)
 202     (goto-char (point-min))
 203     (while (not (looking-at gpr-query-prompt))
 204       (cl-pushnew (directory-file-name
 205                     (buffer-substring-no-properties (point) (point-at-eol)))
 206                   src-dirs :test #'equal)
 207       (forward-line 1))
 208     )
 209   src-dirs)
 210
 211 (defun gpr-query-get-prj-dirs (prj-dirs)
 212   "Append list of project dirs in current gpr project to PRJ-DIRS.
 213 Uses `gpr_query'. Returns new list."
 214
 215   (with-current-buffer (gpr-query--session-buffer (gpr-query-cached-session))
 216     (gpr-query-session-send "project_path" t)
 217     (goto-char (point-min))
 218     (while (not (looking-at gpr-query-prompt))
 219       (cl-pushnew
 220        (let ((dir (buffer-substring-no-properties (point) (point-at-eol))))
 221          (if (string= dir ".")
 222              (directory-file-name default-directory)
 223              dir))
 224        prj-dirs
 225        :test #'equal)
 226       (forward-line 1))
 227     )
 228   prj-dirs)
 229
 230 (defconst gpr-query-ident-file-regexp
 231   ;; C:\Projects\GDS\work_dscovr_release\common\1553\gds-mil_std_1553-utf.ads:252:25
 232   ;; /Projects/GDS/work_dscovr_release/common/1553/gds-mil_std_1553-utf.ads:252:25
 233   "\\(\\(?:.:\\\\\\|/\\)[^:]*\\):\\([0123456789]+\\):\\([0123456789]+\\)"
 234   ;; 1                          2                   3
 235   "Regexp matching <file>:<line>:<column>")
 236
 237 (defconst gpr-query-ident-file-regexp-alist
 238   (list (concat "^" gpr-query-ident-file-regexp) 1 2 3)
 239   "For compilation-error-regexp-alist, matching gpr_query output")
 240
 241 (defconst gpr-query-ident-file-type-regexp
 242   (concat gpr-query-ident-file-regexp " (\\(.*\\))")
 243   "Regexp matching <file>:<line>:<column> (<type>)")
 244
 245 (defun gpr-query-compilation (identifier file line col cmd comp-err)
 246   "Run gpr_query IDENTIFIER:FILE:LINE:COL CMD,
 247 set compilation-mode with compilation-error-regexp-alist set to COMP-ERR."
 248   ;; Useful when gpr_query will return a list of references; we use
 249   ;; `compilation-start' to run gpr_query, so the user can navigate
 250   ;; to each result in turn via `next-error'.
 251   (let ((cmd-1 (format "%s %s:%s:%d:%d" cmd identifier file line col))
 252         (result-count 0)
 253         target-file target-line target-col)
 254     (with-current-buffer (gpr-query--session-buffer (gpr-query-cached-session))
 255       (compilation-mode)
 256       (setq buffer-read-only nil)
 257       (set (make-local-variable 'compilation-error-regexp-alist) (list comp-err))
 258       (gpr-query-session-send cmd-1 t)
 259
 260       ;; point is at EOB. gpr_query returns one line per result plus prompt, warnings
 261       (setq result-count (- (line-number-at-pos) 1))
 262
 263       (font-lock-ensure)
 264       ;; pre Emacs 25, font-lock-ensure applies compilation-message
 265       ;; text properties
 266       ;;
 267       ;; post Emacs 25, compilation-next-error applies
 268       ;; compilation-message text properties on the fly via
 269       ;; compilation--ensure-parse. But that doesn't apply face text
 270       ;; properties.
 271       ;;
 272       ;; IMPROVEME: next-error works, but the font colors are not
 273       ;; right (bad regexp?)
 274
 275       (goto-char (point-min))
 276       (cond
 277        ((looking-at "^warning: ")
 278         (setq result-count (1- result-count))
 279         (forward-line 1))
 280        ((looking-at "^Error: entity not found")
 281         (error (buffer-substring-no-properties (line-beginning-position) (line-end-position))))
 282        )
 283
 284       (cl-case result-count
 285         (0
 286          (error "gpr_query returned no results"))
 287         (1
 288          ;; just go there, don't display session-buffer. We have to
 289          ;; fetch the compilation-message while in the
 290          ;; session-buffer. and call ada-goot-source outside the
 291          ;; with-current-buffer above.
 292          (compilation--ensure-parse (point-max))
 293          (let* ((msg (compilation-next-error 0))
 294                 ;; IMPROVEME: '--' indicates internal-only. But we can't
 295                 ;; use compile-goto-error, because that displays the
 296                 ;; session-buffer.
 297                 (loc (compilation--message->loc msg)))
 298            (setq target-file (caar (compilation--loc->file-struct loc))
 299                  target-line (caar (cddr (compilation--loc->file-struct loc)))
 300                  target-col  (1- (compilation--loc->col loc))
 301                  )
 302            ))
 303
 304         (t
 305          ;; for next-error, below
 306          (setq next-error-last-buffer (current-buffer)))
 307
 308         ));; case, with-currrent-buffer
 309
 310     (if (= result-count 1)
 311         (ada-goto-source target-file target-line target-col nil)
 312
 313       ;; more than one result; display session buffer, goto first ref
 314       ;;
 315       ;; compilation-next-error-function assumes there is not an error
 316       ;; at point-min; work around that by moving forward 0 errors for
 317       ;; the first one. Unless the first line contains "warning: ".
 318       (set-buffer next-error-last-buffer)
 319       (goto-char (point-min))
 320       (if (looking-at "^warning: ")
 321           (next-error)
 322         (next-error 0 t))
 323       )
 324     ))
 325
 326 (defun gpr-query-dist (found-line line found-col col)
 327   "Return distance between FOUND-LINE FOUND-COL and LINE COL."
 328   (+ (abs (- found-col col))
 329      (* (abs (- found-line line)) 250)))
 330
 331 ;;;;; user interface functions
 332
 333 (defun gpr-query-show-references ()
 334   "Show all references of identifier at point."
 335   (interactive)
 336   (gpr-query-all
 337    (thing-at-point 'symbol)
 338    (file-name-nondirectory (buffer-file-name))
 339    (line-number-at-pos)
 340    (1+ (current-column)))
 341   )
 342
 343 (defun gpr-query-overridden (other-window)
 344   "Move to the overridden declaration of the identifier around point.
 345 If OTHER-WINDOW (set by interactive prefix) is non-nil, show the
 346 buffer in another window."
 347   (interactive "P")
 348
 349   (let ((target
 350          (gpr-query-overridden-1
 351           (thing-at-point 'symbol)
 352           (buffer-file-name)
 353           (line-number-at-pos)
 354           (save-excursion
 355             (goto-char (car (bounds-of-thing-at-point 'symbol)))
 356             (1+ (current-column)))
 357           )))
 358
 359     (ada-goto-source (nth 0 target)
 360                      (nth 1 target)
 361                      (nth 2 target)
 362                      other-window)
 363     ))
 364
 365 (defun gpr-query-goto-declaration (other-window)
 366   "Move to the declaration or body of the identifier around point.
 367 If at the declaration, go to the body, and vice versa. If at a
 368 reference, goto the declaration.
 369
 370 If OTHER-WINDOW (set by interactive prefix) is non-nil, show the
 371 buffer in another window."
 372   (interactive "P")
 373
 374   (let ((target
 375          (gpr-query-other
 376           (thing-at-point 'symbol)
 377           (buffer-file-name)
 378           (line-number-at-pos)
 379           (save-excursion
 380             (goto-char (car (bounds-of-thing-at-point 'symbol)))
 381             (1+ (current-column)))
 382           )))
 383
 384     (ada-goto-source (nth 0 target)
 385                      (nth 1 target)
 386                      (nth 2 target)
 387                      other-window)
 388     ))
 389
 390 (defvar gpr-query-map
 391   (let ((map (make-sparse-keymap)))
 392     ;; C-c C-i prefix for gpr-query minor mode
 393
 394     (define-key map "\C-c\C-i\C-d" 'gpr-query-goto-declaration)
 395     (define-key map "\C-c\C-i\C-p" 'ada-build-prompt-select-prj-file)
 396     (define-key map "\C-c\C-i\C-q" 'gpr-query-refresh)
 397     (define-key map "\C-c\C-i\C-r" 'gpr-query-show-references)
 398     ;; IMPROVEME: (define-key map "\C-c\M-d" 'gpr-query-parents)
 399     ;; IMPROVEME: overriding
 400     map
 401   )  "Local keymap used for gpr query minor mode.")
 402
 403 (defvar gpr-query-menu (make-sparse-keymap "gpr-query"))
 404 (easy-menu-define gpr-query-menu gpr-query-map "Menu keymap for gpr-query minor mode"
 405   '("gpr-query"
 406     ["Find and select project ..."   ada-build-prompt-select-prj-file t]
 407     ["Select project ..."            ada-prj-select                   t]
 408     ["Show current project"          ada-prj-show                     t]
 409     ["Show gpr-query buffer"         gpr-query-show-buffer            t]
 410     ["Next compilation error"        next-error                       t]
 411     ["Show secondary error"          ada-show-secondary-error         t]
 412     ["Goto declaration/body"         gpr-query-goto-declaration       t]
 413     ["Show parent declarations"      ada-show-declaration-parents     t]
 414     ["Show references"               gpr-query-show-references        t]
 415     ;; ["Show overriding"               gpr-query-show-overriding        t]
 416     ;; ["Show overridden"               gpr-query-show-overridden        t]
 417     ["Refresh cross reference cache" gpr-query-refresh        t]
 418     ))
 419
 420 (define-minor-mode gpr-query
 421   "Minor mode for navigating sources using GNAT cross reference tool.
 422 Enable mode if ARG is positive."
 423   :initial-value t
 424   :lighter       " gpr-query"   ;; mode line
 425
 426   ;; just enable the menu and keymap
 427   )
 428
 429 ;;;;; support for Ada mode
 430
 431 (defun gpr-query-refresh ()
 432   "For `ada-xref-refresh-function', using gpr_query."
 433   (interactive)
 434   ;; need to kill session to get changed env vars etc
 435   (let ((session (gpr-query-cached-session)))
 436     (gpr-query-kill-session session)
 437     (gpr-query--start-process session)))
 438
 439 (defun gpr-query-other (identifier file line col)
 440   "For `ada-xref-other-function', using gpr_query."
 441   (when (eq ?\" (aref identifier 0))
 442     ;; gpr_query wants the quotes stripped
 443     (setq col (+ 1 col))
 444     (setq identifier (substring identifier 1 (1- (length identifier))))
 445     )
 446
 447   (when (eq system-type 'windows-nt)
 448     ;; Since Windows file system is case insensitive, GNAT and Emacs
 449     ;; can disagree on the case, so convert all to lowercase.
 450     (setq file (downcase file)))
 451
 452   (let ((cmd (format "refs %s:%s:%d:%d" identifier (file-name-nondirectory file) line col))
 453         (decl-loc nil)
 454         (body-loc nil)
 455         (search-type nil)
 456         (min-distance (1- (expt 2 29)))
 457         (result nil))
 458
 459     (with-current-buffer (gpr-query-session-send cmd t)
 460       ;; 'gpr_query refs' returns a list containing the declaration,
 461       ;; the body, and all the references, in no particular order.
 462       ;;
 463       ;; We search the list, looking for the input location,
 464       ;; declaration and body, then return the declaration or body as
 465       ;; appropriate.
 466       ;;
 467       ;; the format of each line is file:line:column (type)
 468       ;;                            1    2    3       4
 469       ;;
 470       ;; 'type' can be:
 471       ;;   body
 472       ;;   declaration
 473       ;;   full declaration  (for a private type)
 474       ;;   implicit reference
 475       ;;   reference
 476       ;;   static call
 477       ;;
 478       ;; Module_Type:/home/Projects/GDS/work_stephe_2/common/1553/gds-hardware-bus_1553-wrapper.ads:171:9 (full declaration)
 479       ;;
 480       ;; itc_assert:/home/Projects/GDS/work_stephe_2/common/itc/opsim/itc_dscovr_gdsi/Gds1553/src/Gds1553.cpp:830:9 (reference)
 481
 482       (message "parsing result ...")
 483
 484       (goto-char (point-min))
 485
 486       (while (not (eobp))
 487         (cond
 488          ((looking-at gpr-query-ident-file-type-regexp)
 489           ;; process line
 490           (let* ((found-file (match-string 1))
 491                  (found-line (string-to-number (match-string 2)))
 492                  (found-col  (string-to-number (match-string 3)))
 493                  (found-type (match-string 4))
 494                  (dist       (gpr-query-dist found-line line found-col col))
 495                  )
 496
 497             (when (eq system-type 'windows-nt)
 498               ;; 'expand-file-name' converts Windows directory
 499               ;; separators to normal Emacs.  Since Windows file
 500               ;; system is case insensitive, GNAT and Emacs can
 501               ;; disagree on the case, so convert all to lowercase.
 502               (setq found-file (downcase (expand-file-name found-file))))
 503
 504             (when (string-equal found-type "declaration")
 505               (setq decl-loc (list found-file found-line (1- found-col))))
 506
 507             (when (or
 508                    (string-equal found-type "body")
 509                    (string-equal found-type "full declaration"))
 510               (setq body-loc (list found-file found-line (1- found-col))))
 511
 512             (when
 513                 ;; The source may have changed since the xref database
 514                 ;; was computed, so allow for fuzzy matches.
 515                 (and (equal found-file file)
 516                      (< dist min-distance))
 517               (setq min-distance dist)
 518               (setq search-type found-type))
 519             ))
 520
 521          (t ;; ignore line
 522           ;;
 523           ;; This skips GPR_PROJECT_PATH and echoed command at start of buffer.
 524           ;;
 525           ;; It also skips warning lines. For example,
 526           ;; gnatcoll-1.6w-20130902 can't handle the Auto_Text_IO
 527           ;; language, because it doesn't use the gprconfig
 528           ;; configuration project. That gives lines like:
 529           ;;
 530           ;; common_text_io.gpr:15:07: language unknown for "gds-hardware-bus_1553-time_tone.ads"
 531           ;;
 532           ;; There are probably other warnings that might be reported as well.
 533           )
 534          )
 535         (forward-line 1)
 536         )
 537
 538       (cond
 539        ((null search-type)
 540         nil)
 541
 542        ((and
 543          (string-equal search-type "declaration")
 544          body-loc)
 545         (setq result body-loc))
 546
 547        (decl-loc
 548         (setq result decl-loc))
 549        )
 550
 551       (when (null result)
 552         (error "gpr_query did not return other item; refresh?"))
 553
 554       (message "parsing result ... done")
 555       result)))
 556
 557 (defun gpr-query-all (identifier file line col)
 558   "For `ada-xref-all-function', using gpr_query."
 559   (gpr-query-compilation identifier file line col "refs" 'gpr-query-ident-file))
 560
 561 (defun gpr-query-parents (identifier file line col)
 562   "For `ada-xref-parent-function', using gpr_query."
 563   (gpr-query-compilation identifier file line col "parent_types" 'gpr-query-ident-file))
 564
 565 (defun gpr-query-overriding (identifier file line col)
 566   "For `ada-xref-overriding-function', using gpr_query."
 567   (gpr-query-compilation identifier file line col "overriding" 'gpr-query-ident-file))
 568
 569 (defun gpr-query-overridden-1 (identifier file line col)
 570   "For `ada-xref-overridden-function', using gpr_query."
 571   (when (eq ?\" (aref identifier 0))
 572     ;; gpr_query wants the quotes stripped
 573     (setq col (+ 1 col))
 574     (setq identifier (substring identifier 1 (1- (length identifier))))
 575     )
 576
 577   (let ((cmd (format "overridden %s:%s:%d:%d" identifier (file-name-nondirectory file) line col))
 578         result)
 579     (with-current-buffer (gpr-query-session-send cmd t)
 580
 581       (goto-char (point-min))
 582       (when (looking-at gpr-query-ident-file-regexp)
 583         (setq result
 584               (list
 585                (match-string 1)
 586                (string-to-number (match-string 2))
 587                (string-to-number (match-string 3)))))
 588
 589       (when (null result)
 590         (error "gpr_query did not return a result; refresh?"))
 591
 592       (message "parsing result ... done")
 593       result)))
 594
 595 (defun ada-gpr-query-select-prj ()
 596   (setq ada-file-name-from-ada-name 'ada-gnat-file-name-from-ada-name)
 597   (setq ada-ada-name-from-file-name 'ada-gnat-ada-name-from-file-name)
 598   (setq ada-make-package-body       'ada-gnat-make-package-body)
 599
 600   (setq ada-xref-refresh-function    'gpr-query-refresh)
 601   (setq ada-xref-all-function        'gpr-query-all)
 602   (setq ada-xref-other-function      'gpr-query-other)
 603   (setq ada-xref-parent-function     'gpr-query-parents)
 604   (setq ada-xref-all-function        'gpr-query-all)
 605   (setq ada-xref-overriding-function 'gpr-query-overriding)
 606   (setq ada-xref-overridden-function 'gpr-query-overridden-1)
 607   (setq ada-show-xref-tool-buffer    'gpr-query-show-buffer)
 608
 609   (add-to-list 'completion-ignored-extensions ".ali") ;; gnat library files, used for cross reference
 610   )
 611
 612 (defun ada-gpr-query-deselect-prj ()
 613   (setq ada-file-name-from-ada-name nil)
 614   (setq ada-ada-name-from-file-name nil)
 615   (setq ada-make-package-body       nil)
 616
 617   (setq ada-xref-other-function      nil)
 618   (setq ada-xref-parent-function     nil)
 619   (setq ada-xref-all-function        nil)
 620   (setq ada-xref-overriding-function nil)
 621   (setq ada-xref-overridden-function nil)
 622   (setq ada-show-xref-tool-buffer    nil)
 623
 624   (setq completion-ignored-extensions (delete ".ali" completion-ignored-extensions))
 625   )
 626
 627 (defun ada-gpr-query ()
 628   "Set Ada mode global vars to use gpr_query."
 629   (add-to-list 'ada-prj-parser-alist       '("gpr" . gnat-parse-gpr))
 630   (add-to-list 'ada-select-prj-xref-tool   '(gpr_query . ada-gpr-query-select-prj))
 631   (add-to-list 'ada-deselect-prj-xref-tool '(gpr_query . ada-gpr-query-deselect-prj))
 632
 633   ;; no parse-*-xref
 634   )
 635
 636 (provide 'gpr-query)
 637 (provide 'ada-xref-tool)
 638
 639 (add-to-list 'compilation-error-regexp-alist-alist
 640              (cons 'gpr-query-ident-file       gpr-query-ident-file-regexp-alist))
 641
 642 (unless (and (boundp 'ada-xref-tool)
 643              (default-value 'ada-xref-tool))
 644   (setq ada-xref-tool 'gpr_query))
 645
 646 (ada-gpr-query)
 647
 648 ;;; end of file