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

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