/[emacs]/emacs/lisp/progmodes/ada-xref.el
ViewVC logotype

Diff of /emacs/lisp/progmodes/ada-xref.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.10 by rms, Sun Apr 28 03:17:51 2002 UTC revision 1.10.2.1 by miles, Fri Apr 4 06:20:31 2003 UTC
# Line 1  Line 1 
1  ;;; ada-xref.el --- for lookup and completion in Ada mode  ;;; ada-xref.el --- for lookup and completion in Ada mode
2    
3  ;; Copyright (C) 1994, 95, 96, 97, 98, 99, 2000, 2001  ;; Copyright (C) 1994, 95, 96, 97, 98, 99, 2000, 2001, 2002
4  ;;    Free Software Foundation, Inc.  ;;    Free Software Foundation, Inc.
5    
6  ;; Author: Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de>  ;; Author: Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de>
7  ;;      Rolf Ebert <ebert@inf.enst.fr>  ;;      Rolf Ebert <ebert@inf.enst.fr>
8  ;;      Emmanuel Briot <briot@gnat.com>  ;;      Emmanuel Briot <briot@gnat.com>
9  ;; Maintainer: Emmanuel Briot <briot@gnat.com>  ;; Maintainer: Emmanuel Briot <briot@gnat.com>
10  ;; Ada Core Technologies's version:   $Revision$  ;; Ada Core Technologies's version:   Revision: 1.155.2.8 (GNAT 3.15)
11  ;; Keywords: languages ada xref  ;; Keywords: languages ada xref
12    
13  ;; This file is part of GNU Emacs.  ;; This file is part of GNU Emacs.
# Line 51  Line 51 
51  Otherwise create either a new buffer or a new frame."  Otherwise create either a new buffer or a new frame."
52    :type 'boolean :group 'ada)    :type 'boolean :group 'ada)
53    
54  (defcustom ada-xref-create-ali t  (defcustom ada-xref-create-ali nil
55    "*If non-nil, run gcc whenever the cross-references are not up-to-date.    "*If non-nil, run gcc whenever the cross-references are not up-to-date.
56  If nil, the cross-reference mode will never run gcc."  If nil, the cross-reference mode will never run gcc."
57    :type 'boolean :group 'ada)    :type 'boolean :group 'ada)
# Line 91  The command gnatfind is used every time Line 91  The command gnatfind is used every time
91    :type 'string :group 'ada)    :type 'string :group 'ada)
92    
93  (defcustom ada-prj-default-comp-cmd  (defcustom ada-prj-default-comp-cmd
94    "${cross_prefix}gcc -x ada -c ${comp_opt} ${full_current}"    (concat "${cross_prefix}gnatmake -u -c ${gnatmake_opt} ${full_current} -cargs"
95              " ${comp_opt}")
96    "*Default command to be used to compile a single file.    "*Default command to be used to compile a single file.
97  Emacs will add the filename at the end of this command. This is the same  Emacs will add the filename at the end of this command. This is the same
98  syntax as in the project file."  syntax as in the project file."
# Line 132  Otherwise, ask the user for the name of Line 133  Otherwise, ask the user for the name of
133    "*If non-nil, a new Emacs frame will be swallowed in GVD when debugging.    "*If non-nil, a new Emacs frame will be swallowed in GVD when debugging.
134  If GVD is not the debugger used, nothing happens.")  If GVD is not the debugger used, nothing happens.")
135    
136    (defcustom ada-xref-search-with-egrep t
137      "*If non-nil, use egrep to find the possible declarations for an entity.
138    This alternate method is used when the exact location was not found in the
139    information provided by GNAT. However, it might be expensive if you have a lot
140    of sources, since it will search in all the files in your project."
141      :type 'boolean :group 'ada)
142    
143    (defvar ada-load-project-hook nil
144      "Hook that is run when loading a project file.
145    Each function in this hook takes one argument FILENAME, that is the name of
146    the project file to load.
147    This hook should be used to support new formats for the project files.
148    
149    If the function can load the file with the given filename, it should create a
150    buffer that contains a conversion of the file to the standard format of the
151    project files, and return that buffer. (the usual \"src_dir=\" or \"obj_dir=\"
152    lines).  It should return nil if it doesn't know how to convert that project
153    file.")
154    
155    
156  ;; ------- Nothing to be modified by the user below this  ;; ------- Nothing to be modified by the user below this
157  (defvar ada-last-prj-file ""  (defvar ada-last-prj-file ""
158    "Name of the last project file entered by the user.")    "Name of the last project file entered by the user.")
# Line 204  CROSS-PREFIX is the prefix to use for th Line 225  CROSS-PREFIX is the prefix to use for th
225                (goto-char (point-min))                (goto-char (point-min))
226    
227                ;;  Source path                ;;  Source path
228                  
229                (search-forward "Source Search Path:")                (search-forward "Source Search Path:")
230                (forward-line 1)                (forward-line 1)
231                (while (not (looking-at "^$"))                (while (not (looking-at "^$"))
# Line 217  CROSS-PREFIX is the prefix to use for th Line 238  CROSS-PREFIX is the prefix to use for th
238                  (forward-line 1))                  (forward-line 1))
239    
240                ;;  Object path                ;;  Object path
241                  
242                (search-forward "Object Search Path:")                (search-forward "Object Search Path:")
243                (forward-line 1)                (forward-line 1)
244                (while (not (looking-at "^$"))                (while (not (looking-at "^$"))
# Line 261  replaced by the name including the exten Line 282  replaced by the name including the exten
282        (if (null value)        (if (null value)
283            (if (not (setq value (getenv name)))            (if (not (setq value (getenv name)))
284                (message (concat "No environment variable " name " found"))))                (message (concat "No environment variable " name " found"))))
285                    
286        (cond        (cond
287         ((null value)         ((null value)
288          (setq cmd-string (replace-match "" t t cmd-string)))          (setq cmd-string (replace-match "" t t cmd-string)))
# Line 282  replaced by the name including the exten Line 303  replaced by the name including the exten
303          plist)          plist)
304      (save-excursion      (save-excursion
305        (set-buffer ada-buffer)        (set-buffer ada-buffer)
306          
307        (set 'plist        (set 'plist
308             ;;  Try hard to find a default value for filename, so that the user             ;;  Try hard to find a default value for filename, so that the user
309             ;;  can edit his project file even if the current buffer is not an             ;;  can edit his project file even if the current buffer is not an
310             ;;  Ada file or not even associated with a file             ;;  Ada file or not even associated with a file
311             (list 'filename (expand-file-name             (list 'filename (expand-file-name
312                              (cond                              (cond
                              (file  
                               (ada-prj-get-prj-dir file))  
313                               (ada-prj-default-project-file                               (ada-prj-default-project-file
314                                ada-prj-default-project-file)                                ada-prj-default-project-file)
315                                 (file
316                                  (ada-prj-get-prj-dir file))
317                               (t                               (t
318                                (message (concat "Not editing an Ada file,"                                (message (concat "Not editing an Ada file,"
319                                                 "and no default project "                                                 "and no default project "
# Line 336  replaced by the name including the exten Line 357  replaced by the name including the exten
357                   'debug_post_cmd  (list nil)))                   'debug_post_cmd  (list nil)))
358        )        )
359      (set symbol plist)))      (set symbol plist)))
360      
361  (defun ada-xref-get-project-field (field)  (defun ada-xref-get-project-field (field)
362    "Extract the value of FIELD from the current project file.    "Extract the value of FIELD from the current project file.
363  The project file must have been loaded first.  The project file must have been loaded first.
# Line 352  addition return the default paths." Line 373  addition return the default paths."
373      ;;  Get the project file (either the current one, or a default one)      ;;  Get the project file (either the current one, or a default one)
374      (setq file (or (assoc file-name ada-xref-project-files)      (setq file (or (assoc file-name ada-xref-project-files)
375                     (assoc nil ada-xref-project-files)))                     (assoc nil ada-xref-project-files)))
376            
377      ;;  If the file was not found, use the default values      ;;  If the file was not found, use the default values
378      (if file      (if file
379          ;;  Get the value from the file          ;;  Get the value from the file
# Line 388  All the directories are returned as abso Line 409  All the directories are returned as abso
409      (append      (append
410       ;; Add ${build_dir} in front of the path       ;; Add ${build_dir} in front of the path
411       (list build-dir)       (list build-dir)
412        
413       (ada-get-absolute-dir-list (ada-xref-get-project-field 'src_dir)       (ada-get-absolute-dir-list (ada-xref-get-project-field 'src_dir)
414                                  build-dir)                                  build-dir)
415        
416       ;; Add the standard runtime at the end       ;; Add the standard runtime at the end
417       ada-xref-runtime-library-specs-path)))       ada-xref-runtime-library-specs-path)))
418    
# Line 403  All the directories are returned as abso Line 424  All the directories are returned as abso
424      (append      (append
425       ;; Add ${build_dir} in front of the path       ;; Add ${build_dir} in front of the path
426       (list build-dir)       (list build-dir)
427        
428       (ada-get-absolute-dir-list (ada-xref-get-project-field 'obj_dir)       (ada-get-absolute-dir-list (ada-xref-get-project-field 'obj_dir)
429                                  build-dir)                                  build-dir)
430        
431       ;; Add the standard runtime at the end       ;; Add the standard runtime at the end
432       ada-xref-runtime-library-ali-path)))       ada-xref-runtime-library-ali-path)))
433    
# Line 421  All the directories are returned as abso Line 442  All the directories are returned as abso
442                          (cons 'New  (cons "New..."  'ada-prj-new))                          (cons 'New  (cons "New..."  'ada-prj-new))
443                          (cons 'Edit (cons "Edit..." 'ada-prj-edit))                          (cons 'Edit (cons "Edit..." 'ada-prj-edit))
444                          (cons 'sep  (cons "---" nil))))                          (cons 'sep  (cons "---" nil))))
445        
446      ;;  Add the new items      ;;  Add the new items
447      (mapcar      (mapcar
448       (lambda (x)       (lambda (x)
# Line 436  All the directories are returned as abso Line 457  All the directories are returned as abso
457                (append submenu                (append submenu
458                        (list (cons (intern name)                        (list (cons (intern name)
459                                    (list                                    (list
460                                     'menu-item (file-name-sans-extension                                     'menu-item
461                                                 (file-name-nondirectory name))                                     (if (string= (file-name-extension name)
462                                                    ada-project-file-extension)
463                                           (file-name-sans-extension
464                                            (file-name-nondirectory name))
465                                         (file-name-nondirectory name))
466                                     command                                     command
467                                     :button (cons                                     :button (cons
468                                              :toggle                                              :toggle
469                                              (equal ada-prj-default-project-file                                              (equal ada-prj-default-project-file
470                                                     (car x))                                                     (car x))
471                                              ))))))))                                              ))))))))
472        
473       ;; Parses all the known project files, and insert at least the default       ;; Parses all the known project files, and insert at least the default
474       ;; one (in case ada-xref-project-files is nil)       ;; one (in case ada-xref-project-files is nil)
475       (or ada-xref-project-files '(nil)))       (or ada-xref-project-files '(nil)))
476    
477       (if (not ada-xemacs)       (if (not ada-xemacs)
478           (if (lookup-key ada-mode-map [menu-bar Ada Project])           (if (and (lookup-key ada-mode-map [menu-bar Ada])
479               (setcdr (lookup-key ada-mode-map [menu-bar Ada Project])                    (lookup-key ada-mode-map [menu-bar Ada Project]))
480                       submenu)))               (setcdr (lookup-key ada-mode-map [menu-bar Ada Project])
481      ))                       submenu)
482               (if (lookup-key ada-mode-map [menu-bar ada Project])
483                   (setcdr (lookup-key ada-mode-map [menu-bar ada Project])
484                           submenu))))
485         ))
486    
487    
488  ;;-------------------------------------------------------------  ;;-------------------------------------------------------------
# Line 515  Completion is available." Line 544  Completion is available."
544    (define-key ada-mode-map "\C-c5\C-d" 'ada-goto-declaration-other-frame)    (define-key ada-mode-map "\C-c5\C-d" 'ada-goto-declaration-other-frame)
545    (define-key ada-mode-map "\C-c\C-d" 'ada-goto-declaration)    (define-key ada-mode-map "\C-c\C-d" 'ada-goto-declaration)
546    (define-key ada-mode-map "\C-c\C-s" 'ada-xref-goto-previous-reference)    (define-key ada-mode-map "\C-c\C-s" 'ada-xref-goto-previous-reference)
   (define-key ada-mode-map "\C-c\C-x" 'ada-reread-prj-file)  
547    (define-key ada-mode-map "\C-c\C-c" 'ada-compile-application)    (define-key ada-mode-map "\C-c\C-c" 'ada-compile-application)
548    (define-key ada-mode-map "\C-cc"  'ada-change-prj)    (define-key ada-mode-map "\C-cc"  'ada-change-prj)
549    (define-key ada-mode-map "\C-cd"  'ada-set-default-project-file)    (define-key ada-mode-map "\C-cd"  'ada-set-default-project-file)
# Line 523  Completion is available." Line 551  Completion is available."
551    (define-key ada-mode-map "\C-cr"  'ada-run-application)    (define-key ada-mode-map "\C-cr"  'ada-run-application)
552    (define-key ada-mode-map "\C-c\C-o" 'ada-goto-parent)    (define-key ada-mode-map "\C-c\C-o" 'ada-goto-parent)
553    (define-key ada-mode-map "\C-c\C-r" 'ada-find-references)    (define-key ada-mode-map "\C-c\C-r" 'ada-find-references)
554      (define-key ada-mode-map "\C-cl" 'ada-find-local-references)
555    (define-key ada-mode-map "\C-c\C-v" 'ada-check-current)    (define-key ada-mode-map "\C-c\C-v" 'ada-check-current)
556    (define-key ada-mode-map "\C-c\C-f" 'ada-find-file)    (define-key ada-mode-map "\C-cf" 'ada-find-file)
557    )    )
558    
559  ;; ----- Menus --------------------------------------------------------------  ;; ----- Menus --------------------------------------------------------------
# Line 564  name as was passed to `ada-create-menu'. Line 593  name as was passed to `ada-create-menu'.
593                   goto-menu ["List References" ada-find-references t]                   goto-menu ["List References" ada-find-references t]
594                   "Next compilation error")                   "Next compilation error")
595          (funcall (symbol-function 'add-menu-button)          (funcall (symbol-function 'add-menu-button)
596                     goto-menu ["List Local References" ada-find-local-references t]
597                     "Next compilation error")
598            (funcall (symbol-function 'add-menu-button)
599                   goto-menu ["Goto Declaration Other Frame"                   goto-menu ["Goto Declaration Other Frame"
600                              ada-goto-declaration-other-frame t]                              ada-goto-declaration-other-frame t]
601                   "Next compilation error")                   "Next compilation error")
# Line 618  name as was passed to `ada-create-menu'. Line 650  name as was passed to `ada-create-menu'.
650                              (not ada-tight-gvd-integration))                              (not ada-tight-gvd-integration))
651                        :style toggle :selected ada-tight-gvd-integration]))                        :style toggle :selected ada-tight-gvd-integration]))
652          )          )
653        
654      ;; for Emacs      ;; for Emacs
655      (let* ((menu         (lookup-key ada-mode-map [menu-bar ada]))      (let* ((menu      (or (lookup-key ada-mode-map [menu-bar Ada])
656             (edit-menu    (lookup-key ada-mode-map [menu-bar ada edit]))                            ;; Emacs-21.4's easymenu.el downcases the events.
657             (help-menu    (lookup-key ada-mode-map [menu-bar ada help]))                            (lookup-key ada-mode-map [menu-bar ada])))
658             (goto-menu    (lookup-key ada-mode-map [menu-bar ada goto]))             (edit-menu (or (lookup-key menu [Edit]) (lookup-key menu [edit])))
659             (options-menu (lookup-key ada-mode-map [menu-bar ada options])))             (help-menu (or (lookup-key menu [Help]) (lookup-key menu [help])))
660               (goto-menu (or (lookup-key menu [Goto]) (lookup-key menu [goto])))
661               (options-menu (or (lookup-key menu [Options])
662                                 (lookup-key menu [options]))))
663    
664        (define-key-after menu [Check] '("Check file" . ada-check-current)        (define-key-after menu [Check] '("Check file" . ada-check-current)
665          'Customize)          'Customize)
# Line 656  name as was passed to `ada-create-menu'. Line 691  name as was passed to `ada-create-menu'.
691          '("Goto References to any entity" . ada-find-any-references))          '("Goto References to any entity" . ada-find-any-references))
692        (define-key goto-menu [References]        (define-key goto-menu [References]
693          '("List References" . ada-find-references))          '("List References" . ada-find-references))
694          (define-key goto-menu [Local-References]
695            '("List Local References" . ada-find-local-references))
696        (define-key goto-menu [Prev]        (define-key goto-menu [Prev]
697          '("Goto Previous Reference" . ada-xref-goto-previous-reference))          '("Goto Previous Reference" . ada-xref-goto-previous-reference))
698        (define-key goto-menu [Decl-other]        (define-key goto-menu [Decl-other]
699          '("Goto Declaration Other Frame" . ada-goto-declaration-other-frame))          '("Goto Declaration Other Frame" . ada-goto-declaration-other-frame))
700        (define-key goto-menu [Decl]        (define-key goto-menu [Decl]
701          '("Goto Declaration/Body" . ada-goto-declaration))          '("Goto Declaration/Body" . ada-goto-declaration))
702          
703        (define-key edit-menu [rem] '("----" . nil))        (define-key edit-menu [rem] '("----" . nil))
704        (define-key edit-menu [Complete] '("Complete Identifier"        (define-key edit-menu [Complete] '("Complete Identifier"
705                                           . ada-complete-identifier))                                           . ada-complete-identifier))
# Line 692  name as was passed to `ada-create-menu'. Line 729  name as was passed to `ada-create-menu'.
729                                  (not ada-tight-gvd-integration)))                                  (not ada-tight-gvd-integration)))
730                          :button (:toggle . ada-tight-gvd-integration)) t))                          :button (:toggle . ada-tight-gvd-integration)) t))
731    
732        (define-key ada-mode-map [menu-bar Ada Edit rem3] '("------------" . nil))        (define-key edit-menu [rem3] '("------------" . nil))
733        (define-key ada-mode-map [menu-bar Ada Edit open-file-from-src-path]        (define-key edit-menu [open-file-from-src-path]
734          '("Search File on source path..." . ada-find-file))          '("Search File on source path..." . ada-find-file))
735        )        )
736      )      )
# Line 708  name as was passed to `ada-create-menu'. Line 745  name as was passed to `ada-create-menu'.
745            (not ada-xref-project-files)            (not ada-xref-project-files)
746            (string= ada-prj-default-project-file ""))            (string= ada-prj-default-project-file ""))
747        (ada-reread-prj-file)))        (ada-reread-prj-file)))
748          
749  (defun ada-xref-push-pos (filename position)  (defun ada-xref-push-pos (filename position)
750    "Push (FILENAME, POSITION) on the position ring for cross-references."    "Push (FILENAME, POSITION) on the position ring for cross-references."
751    (setq ada-xref-pos-ring (cons (list position filename) ada-xref-pos-ring))    (setq ada-xref-pos-ring (cons (list position filename) ada-xref-pos-ring))
# Line 732  This is overriden on VMS to convert from Line 769  This is overriden on VMS to convert from
769  (defun ada-set-default-project-file (name)  (defun ada-set-default-project-file (name)
770    "Set the file whose name is NAME as the default project file."    "Set the file whose name is NAME as the default project file."
771    (interactive "fProject file:")    (interactive "fProject file:")
772    (set 'ada-prj-default-project-file name)    (setq ada-prj-default-project-file name)
773    (ada-reread-prj-file name)    (ada-reread-prj-file name)
774    )    )
775    
# Line 750  file. If none is set, return nil." Line 787  file. If none is set, return nil."
787      ;;  Use the active project file if there is one.      ;;  Use the active project file if there is one.
788      ;;  This is also valid if we don't currently have an Ada buffer, or if      ;;  This is also valid if we don't currently have an Ada buffer, or if
789      ;;  the current buffer is not a real file (for instance an emerge buffer)      ;;  the current buffer is not a real file (for instance an emerge buffer)
790        
791      (if (or (not (string= mode-name "Ada"))      (if (or (not (string= mode-name "Ada"))
792              (not (buffer-file-name))              (not (buffer-file-name))
793              (and ada-prj-default-project-file              (and ada-prj-default-project-file
794                   (not (string= ada-prj-default-project-file ""))))                   (not (string= ada-prj-default-project-file ""))))
795          (set 'selected ada-prj-default-project-file)          (set 'selected ada-prj-default-project-file)
796          
797        ;;  other cases: use a more complex algorithm        ;;  other cases: use a more complex algorithm
798          
799        (let* ((current-file (buffer-file-name))        (let* ((current-file (buffer-file-name))
800               (first-choice (concat               (first-choice (concat
801                              (file-name-sans-extension current-file)                              (file-name-sans-extension current-file)
802                              ada-project-file-extension))                              ada-project-file-extension))
803               (dir          (file-name-directory current-file))               (dir          (file-name-directory current-file))
804                
805               ;; on Emacs 20.2, directory-files does not work if               ;; on Emacs 20.2, directory-files does not work if
806               ;; parse-sexp-lookup-properties is set               ;; parse-sexp-lookup-properties is set
807               (parse-sexp-lookup-properties nil)               (parse-sexp-lookup-properties nil)
# Line 773  file. If none is set, return nil." Line 810  file. If none is set, return nil."
810                              (concat ".*" (regexp-quote                              (concat ".*" (regexp-quote
811                                            ada-project-file-extension) "$")))                                            ada-project-file-extension) "$")))
812               (choice       nil))               (choice       nil))
813            
814          (cond          (cond
815            
816           ;;  Else if there is a project file with the same name as the Ada           ;;  Else if there is a project file with the same name as the Ada
817           ;;  file, but not the same extension.           ;;  file, but not the same extension.
818           ((file-exists-p first-choice)           ((file-exists-p first-choice)
819            (set 'selected first-choice))            (set 'selected first-choice))
820            
821           ;;  Else if only one project file was found in the current directory           ;;  Else if only one project file was found in the current directory
822           ((= (length prj-files) 1)           ((= (length prj-files) 1)
823            (set 'selected (car prj-files)))            (set 'selected (car prj-files)))
824            
825           ;;  Else if there are multiple files, ask the user           ;;  Else if there are multiple files, ask the user
826           ((and (> (length prj-files) 1) (not no-user-question))           ((and (> (length prj-files) 1) (not no-user-question))
827            (save-window-excursion            (save-window-excursion
# Line 809  file. If none is set, return nil." Line 846  file. If none is set, return nil."
846                (setq choice (string-to-int                (setq choice (string-to-int
847                              (read-from-minibuffer "Enter No. of your choice: "))))                              (read-from-minibuffer "Enter No. of your choice: "))))
848              (set 'selected (nth (1- choice) prj-files))))              (set 'selected (nth (1- choice) prj-files))))
849            
850           ;; Else if no project file was found in the directory, ask a name           ;; Else if no project file was found in the directory, ask a name
851           ;; to the user, using as a default value the last one entered by           ;; to the user, using as a default value the last one entered by
852           ;; the user           ;; the user
# Line 843  The current buffer should be the ada-fil Line 880  The current buffer should be the ada-fil
880          ;;  find-file anyway, since the speedbar frame is special and does not          ;;  find-file anyway, since the speedbar frame is special and does not
881          ;;  allow the selection of a file in it.          ;;  allow the selection of a file in it.
882    
883          (set-buffer (find-file-noselect prj-file))          (let* ((buffer (run-hook-with-args-until-success
884                                   'ada-load-project-hook prj-file)))
885              (unless buffer
886                (setq buffer (find-file-noselect prj-file nil)))
887              (set-buffer buffer))
888    
889          (widen)          (widen)
890          (goto-char (point-min))          (goto-char (point-min))
891    
# Line 880  The current buffer should be the ada-fil Line 921  The current buffer should be the ada-fil
921                  (set 'project (plist-put project (intern (match-string 1))                  (set 'project (plist-put project (intern (match-string 1))
922                                           (match-string 2))))))                                           (match-string 2))))))
923            (forward-line 1))            (forward-line 1))
924            
925          (if src_dir (set 'project (plist-put project 'src_dir          (if src_dir (set 'project (plist-put project 'src_dir
926                                               (reverse src_dir))))                                               (reverse src_dir))))
927          (if obj_dir (set 'project (plist-put project 'obj_dir          (if obj_dir (set 'project (plist-put project 'obj_dir
# Line 905  The current buffer should be the ada-fil Line 946  The current buffer should be the ada-fil
946          ;;  the list          ;;  the list
947          (if (assoc nil ada-xref-project-files)          (if (assoc nil ada-xref-project-files)
948              (setq ada-xref-project-files nil))              (setq ada-xref-project-files nil))
949            
950          ;;  Memorize the newly read project file          ;;  Memorize the newly read project file
951          (if (assoc prj-file ada-xref-project-files)          (if (assoc prj-file ada-xref-project-files)
952              (setcdr (assoc prj-file ada-xref-project-files) project)              (setcdr (assoc prj-file ada-xref-project-files) project)
# Line 913  The current buffer should be the ada-fil Line 954  The current buffer should be the ada-fil
954    
955          ;;  Set the project file as the active one.          ;;  Set the project file as the active one.
956          (setq ada-prj-default-project-file prj-file)          (setq ada-prj-default-project-file prj-file)
957            
958          ;; Sets up the compilation-search-path so that Emacs is able to          ;; Sets up the compilation-search-path so that Emacs is able to
959          ;; go to the source of the errors in a compilation buffer          ;; go to the source of the errors in a compilation buffer
960          (setq compilation-search-path (ada-xref-get-src-dir-field))          (setq compilation-search-path (ada-xref-get-src-dir-field))
# Line 923  The current buffer should be the ada-fil Line 964  The current buffer should be the ada-fil
964              (progn              (progn
965                (setq ada-case-exception-file (reverse casing))                (setq ada-case-exception-file (reverse casing))
966                (ada-case-read-exceptions)))                (ada-case-read-exceptions)))
967            
968          ;; Add the directories to the search path for ff-find-other-file          ;; Add the directories to the search path for ff-find-other-file
969          ;; Do not add the '/' or '\' at the end          ;; Do not add the '/' or '\' at the end
970          (setq ada-search-directories          (setq ada-search-directories
971               (append (mapcar 'directory-file-name compilation-search-path)               (append (mapcar 'directory-file-name compilation-search-path)
972                       ada-search-directories))                       ada-search-directories))
973            
974          ;; Kill the .ali buffer          ;; Kill the project buffer
975          (kill-buffer nil)          (kill-buffer nil)
976          (set-buffer ada-buffer)          (set-buffer ada-buffer)
977    
# Line 944  The current buffer should be the ada-fil Line 985  The current buffer should be the ada-fil
985      ;;  directory.      ;;  directory.
986      (setq compilation-search-path (list nil default-directory))      (setq compilation-search-path (list nil default-directory))
987      ))      ))
988          
989        
990  (defun ada-find-references (&optional pos)  (defun ada-find-references (&optional pos arg local-only)
991    "Find all references to the entity under POS.    "Find all references to the entity under POS.
992  Calls gnatfind to find the references."  Calls gnatfind to find the references.
993    (interactive "")  if ARG is t, the contents of the old *gnatfind* buffer is preserved.
994    (unless pos  if LOCAL-ONLY is t, only the declarations in the current file are returned."
995      (set 'pos (point)))    (interactive "d
996    P")
997    (ada-require-project-file)    (ada-require-project-file)
998    
999    (let* ((identlist (ada-read-identifier pos))    (let* ((identlist (ada-read-identifier pos))
# Line 965  Calls gnatfind to find the references." Line 1007  Calls gnatfind to find the references."
1007              (file-newer-than-file-p (ada-file-of identlist) alifile))              (file-newer-than-file-p (ada-file-of identlist) alifile))
1008          (ada-find-any-references (ada-name-of identlist)          (ada-find-any-references (ada-name-of identlist)
1009                                   (ada-file-of identlist)                                   (ada-file-of identlist)
1010                                   nil nil)                                   nil nil local-only arg)
1011        (ada-find-any-references (ada-name-of identlist)        (ada-find-any-references (ada-name-of identlist)
1012                                 (ada-file-of identlist)                                 (ada-file-of identlist)
1013                                 (ada-line-of identlist)                                 (ada-line-of identlist)
1014                                 (ada-column-of identlist))))                                 (ada-column-of identlist) local-only arg)))
1015    )    )
1016    
1017  (defun ada-find-any-references (entity &optional file line column)  (defun ada-find-local-references (&optional pos arg)
1018      "Find all references to the entity under POS.
1019    Calls gnatfind to find the references.
1020    if ARG is t, the contents of the old *gnatfind* buffer is preserved."
1021      (interactive "d
1022    P")
1023      (ada-find-references pos arg t))
1024    
1025    (defun ada-find-any-references
1026      (entity &optional file line column local-only append)
1027    "Search for references to any entity whose name is ENTITY.    "Search for references to any entity whose name is ENTITY.
1028  ENTITY was first found the location given by FILE, LINE and COLUMN."  ENTITY was first found the location given by FILE, LINE and COLUMN.
1029    If LOCAL-ONLY is t, then only the references in file will be listed, which
1030    is much faster.
1031    If APPEND is t, then the output of the command will be append to the existing
1032    buffer *gnatfind* if it exists."
1033    (interactive "sEntity name: ")    (interactive "sEntity name: ")
1034    (ada-require-project-file)    (ada-require-project-file)
1035    
# Line 992  ENTITY was first found the location give Line 1047  ENTITY was first found the location give
1047                            quote-entity                            quote-entity
1048                            (if file (concat ":" (file-name-nondirectory file)))                            (if file (concat ":" (file-name-nondirectory file)))
1049                            (if line (concat ":" line))                            (if line (concat ":" line))
1050                            (if column (concat ":" column)))))                            (if column (concat ":" column))
1051                              (if local-only (concat " " (file-name-nondirectory file)))
1052                              ))
1053             old-contents)
1054    
1055      ;;  If a project file is defined, use it      ;;  If a project file is defined, use it
1056      (if (and ada-prj-default-project-file      (if (and ada-prj-default-project-file
1057               (not (string= ada-prj-default-project-file "")))               (not (string= ada-prj-default-project-file "")))
1058          (setq command (concat command " -p" ada-prj-default-project-file)))          (setq command (concat command " -p" ada-prj-default-project-file)))
1059    
1060        (if (and append (get-buffer "*gnatfind*"))
1061            (save-excursion
1062              (set-buffer "*gnatfind*")
1063              (setq old-contents (buffer-string))))
1064    
1065      (compile-internal command "No more references" "gnatfind")      (compile-internal command "No more references" "gnatfind")
1066    
1067      ;;  Hide the "Compilation" menu      ;;  Hide the "Compilation" menu
1068      (save-excursion      (save-excursion
1069        (set-buffer "*gnatfind*")        (set-buffer "*gnatfind*")
1070        (local-unset-key [menu-bar compilation-menu]))        (local-unset-key [menu-bar compilation-menu])
1071    
1072          (if old-contents
1073              (progn
1074                (goto-char 1)
1075                (insert old-contents)
1076                (goto-char (point-max)))))
1077      )      )
1078    )    )
1079    
# Line 1102  If OTHER-FRAME is non-nil, display the c Line 1171  If OTHER-FRAME is non-nil, display the c
1171    (let ((identlist (ada-read-identifier pos)))    (let ((identlist (ada-read-identifier pos)))
1172      (condition-case nil      (condition-case nil
1173          (ada-find-in-ali identlist other-frame)          (ada-find-in-ali identlist other-frame)
1174        (error (ada-find-in-src-path identlist other-frame)))))        (error
1175           (let ((ali-file (ada-get-ali-file-name (ada-file-of identlist))))
1176    
1177             ;; If the ALI file was up-to-date, then we probably have a predefined
1178             ;; entity, whose references are not given by GNAT
1179             (if (and (file-exists-p ali-file)
1180                      (file-newer-than-file-p ali-file (ada-file-of identlist)))
1181                 (message "No cross-reference found. It might be a predefined entity.")
1182    
1183               ;; Else, look in every ALI file, except if the user doesn't want that
1184               (if ada-xref-search-with-egrep
1185                   (ada-find-in-src-path identlist other-frame)
1186                 (message "Cross-referencing information is not up-to-date. Please recompile.")
1187                 )))))))
1188    
1189  (defun ada-goto-declaration-other-frame (pos &optional other-frame)  (defun ada-goto-declaration-other-frame (pos &optional other-frame)
1190    "Display the declaration of the identifier around POS.    "Display the declaration of the identifier around POS.
# Line 1169  If ARG is not nil, ask for user confirma Line 1251  If ARG is not nil, ask for user confirma
1251      ;;  Make a single command from the list of commands, including the      ;;  Make a single command from the list of commands, including the
1252      ;;  commands to run it on a remote machine.      ;;  commands to run it on a remote machine.
1253      (setq cmd (ada-remote (mapconcat 'identity cmd ada-command-separator)))      (setq cmd (ada-remote (mapconcat 'identity cmd ada-command-separator)))
1254        
1255      (if (or ada-xref-confirm-compile arg)      (if (or ada-xref-confirm-compile arg)
1256          (setq cmd (read-from-minibuffer "enter command to compile: " cmd)))          (setq cmd (read-from-minibuffer "enter command to compile: " cmd)))
1257    
# Line 1178  If ARG is not nil, ask for user confirma Line 1260  If ARG is not nil, ask for user confirma
1260      ;;  which gets confused by newline characters.      ;;  which gets confused by newline characters.
1261      (if (not (string-match "cmdproxy.exe" shell-file-name))      (if (not (string-match "cmdproxy.exe" shell-file-name))
1262          (setq cmd (concat cmd "\n\n")))          (setq cmd (concat cmd "\n\n")))
1263        
1264      (compile (ada-quote-cmd cmd))))      (compile (ada-quote-cmd cmd))))
1265    
1266  (defun ada-compile-current (&optional arg prj-field)  (defun ada-compile-current (&optional arg prj-field)
# Line 1192  command, and should be either comp_cmd ( Line 1274  command, and should be either comp_cmd (
1274           (cmd (ada-xref-get-project-field field))           (cmd (ada-xref-get-project-field field))
1275           (process-environment (ada-set-environment))           (process-environment (ada-set-environment))
1276           (compilation-scroll-output t))           (compilation-scroll-output t))
1277        
1278      (setq compilation-search-path (ada-xref-get-src-dir-field))      (setq compilation-search-path (ada-xref-get-src-dir-field))
1279    
1280      (unless cmd      (unless cmd
1281        (setq cmd '("") arg t))        (setq cmd '("") arg t))
1282        
1283      ;;  Make a single command from the list of commands, including the      ;;  Make a single command from the list of commands, including the
1284      ;;  commands to run it on a remote machine.      ;;  commands to run it on a remote machine.
1285      (setq cmd (ada-remote (mapconcat 'identity cmd ada-command-separator)))      (setq cmd (ada-remote (mapconcat 'identity cmd ada-command-separator)))
1286        
1287      ;;  If no project file was found, ask the user      ;;  If no project file was found, ask the user
1288      (if (or ada-xref-confirm-compile arg)      (if (or ada-xref-confirm-compile arg)
1289          (setq cmd (read-from-minibuffer "enter command to compile: " cmd)))          (setq cmd (read-from-minibuffer "enter command to compile: " cmd)))
# Line 1211  command, and should be either comp_cmd ( Line 1293  command, and should be either comp_cmd (
1293      ;;  which gets confused by newline characters.      ;;  which gets confused by newline characters.
1294      (if (not (string-match "cmdproxy.exe" shell-file-name))      (if (not (string-match "cmdproxy.exe" shell-file-name))
1295          (setq cmd (concat cmd "\n\n")))          (setq cmd (concat cmd "\n\n")))
1296        
1297      (compile (ada-quote-cmd cmd))))      (compile (ada-quote-cmd cmd))))
1298    
1299  (defun ada-check-current (&optional arg)  (defun ada-check-current (&optional arg)
# Line 1239  if ARG is not-nil, asks for user confirm Line 1321  if ARG is not-nil, asks for user confirm
1321      ;; Modify the command to run remotely      ;; Modify the command to run remotely
1322      (setq command (ada-remote (mapconcat 'identity command      (setq command (ada-remote (mapconcat 'identity command
1323                                           ada-command-separator)))                                           ada-command-separator)))
1324        
1325      ;; Ask for the arguments to the command if required      ;; Ask for the arguments to the command if required
1326      (if (or ada-xref-confirm-compile arg)      (if (or ada-xref-confirm-compile arg)
1327          (setq command (read-from-minibuffer "Enter command to execute: "          (setq command (read-from-minibuffer "Enter command to execute: "
# Line 1330  If ARG is non-nil, ask the user to confi Line 1412  If ARG is non-nil, ask the user to confi
1412    
1413        ;;  Temporarily replaces the definition of `comint-exec' so that we        ;;  Temporarily replaces the definition of `comint-exec' so that we
1414        ;;  can execute commands before running gdb.        ;;  can execute commands before running gdb.
1415        (fset 'comint-exec        (fset 'comint-exec
1416              `(lambda (buffer name command startfile switches)              `(lambda (buffer name command startfile switches)
1417                 (let (compilation-buffer-name-function)                 (let (compilation-buffer-name-function)
1418                   (save-excursion                   (save-excursion
# Line 1347  If ARG is non-nil, ask the user to confi Line 1429  If ARG is non-nil, ask the user to confi
1429                 ada-tight-gvd-integration                 ada-tight-gvd-integration
1430                 (not (string-match "--tty" cmd)))                 (not (string-match "--tty" cmd)))
1431            (setq cmd (concat cmd "--tty")))            (setq cmd (concat cmd "--tty")))
1432          
1433        (if (and (string-match "jdb" (comint-arguments cmd 0 0))        (if (and (string-match "jdb" (comint-arguments cmd 0 0))
1434                 (boundp 'jdb))                 (boundp 'jdb))
1435            (funcall (symbol-function 'jdb) cmd)            (funcall (symbol-function 'jdb) cmd)
# Line 1398  replacing the file extension with .ali" Line 1480  replacing the file extension with .ali"
1480    (if (and ali-file-name    (if (and ali-file-name
1481             (get-file-buffer ali-file-name))             (get-file-buffer ali-file-name))
1482        (kill-buffer (get-file-buffer ali-file-name)))        (kill-buffer (get-file-buffer ali-file-name)))
1483      
1484    (let* ((name      (ada-convert-file-name file))    (let* ((name      (ada-convert-file-name file))
1485           (body-name (or (ada-get-body-name name) name)))           (body-name (or (ada-get-body-name name) name)))
1486    
# Line 1434  replacing the file extension with .ali" Line 1516  replacing the file extension with .ali"
1516      (while (and (not found) dir-list)      (while (and (not found) dir-list)
1517        (set 'found (concat (file-name-as-directory (car dir-list))        (set 'found (concat (file-name-as-directory (car dir-list))
1518                            (file-name-nondirectory file)))                            (file-name-nondirectory file)))
1519          
1520        (unless (file-exists-p found)        (unless (file-exists-p found)
1521            (set 'found nil))            (set 'found nil))
1522        (set 'dir-list (cdr dir-list)))        (set 'dir-list (cdr dir-list)))
# Line 1505  the project file." Line 1587  the project file."
1587                           (file-name-nondirectory                           (file-name-nondirectory
1588                            (ada-other-file-name)))                            (ada-other-file-name)))
1589                          ".ali"))))                          ".ali"))))
1590          
1591    
1592        (setq ali-file-name        (setq ali-file-name
1593              (or ali-file-name              (or ali-file-name
1594                    
1595                  ;;  Else we take the .ali file associated with the unit                  ;;  Else we take the .ali file associated with the unit
1596                  (ada-find-ali-file-in-dir short-ali-file-name)                  (ada-find-ali-file-in-dir short-ali-file-name)
1597                    
1598    
1599                  ;;  else we did not find the .ali file Second chance: in case                  ;;  else we did not find the .ali file Second chance: in case
1600                  ;;  the files do not have standard names (such as for instance                  ;;  the files do not have standard names (such as for instance
# Line 1523  the project file." Line 1605  the project file."
1605                            (file-name-nondirectory (ada-other-file-name)))                            (file-name-nondirectory (ada-other-file-name)))
1606                           ".ali"))                           ".ali"))
1607    
1608                    
1609                  ;;  If we still don't have an ali file, try to get the one                  ;;  If we still don't have an ali file, try to get the one
1610                  ;;  from the parent unit, in case we have a separate entity.                  ;;  from the parent unit, in case we have a separate entity.
1611                  (let ((parent-name (file-name-sans-extension                  (let ((parent-name (file-name-sans-extension
1612                                      (file-name-nondirectory file))))                                      (file-name-nondirectory file))))
1613                      
1614                    (while (and (not ali-file-name)                    (while (and (not ali-file-name)
1615                                (string-match "^\\(.*\\)[.-][^.-]*" parent-name))                                (string-match "^\\(.*\\)[.-][^.-]*" parent-name))
1616                        
1617                      (set 'parent-name (match-string 1 parent-name))                      (set 'parent-name (match-string 1 parent-name))
1618                      (set 'ali-file-name (ada-find-ali-file-in-dir                      (set 'ali-file-name (ada-find-ali-file-in-dir
1619                                           (concat parent-name ".ali")))                                           (concat parent-name ".ali")))
1620                      )                      )
1621                    ali-file-name)))                    ali-file-name)))
1622          
1623        ;; If still not found, try to recompile the file        ;; If still not found, try to recompile the file
1624        (if (not ali-file-name)        (if (not ali-file-name)
1625            ;; recompile only if the user asked for this. and search the ali            ;; recompile only if the user asked for this. and search the ali
1626            ;; filename again. We avoid a possible infinite recursion by            ;; filename again. We avoid a possible infinite recursion by
1627            ;; temporarily disabling the automatic compilation.            ;; temporarily disabling the automatic compilation.
1628              
1629            (if ada-xref-create-ali            (if ada-xref-create-ali
1630                (setq ali-file-name                (setq ali-file-name
1631                      (concat (file-name-sans-extension (ada-xref-current file))                      (concat (file-name-sans-extension (ada-xref-current file))
1632                              ".ali"))                              ".ali"))
1633    
1634              (error "Ali file not found. Recompile your file"))              (error "Ali file not found. Recompile your file"))
1635          
1636            
1637          ;; same if the .ali file is too old and we must recompile it          ;; same if the .ali file is too old and we must recompile it
1638          (if (and (file-newer-than-file-p file ali-file-name)          (if (and (file-newer-than-file-p file ali-file-name)
1639                   ada-xref-create-ali)                   ada-xref-create-ali)
# Line 1575  file for possible paths." Line 1657  file for possible paths."
1657            (set-buffer buffer)            (set-buffer buffer)
1658          (find-file original-file)          (find-file original-file)
1659          (ada-require-project-file)))          (ada-require-project-file)))
1660        
1661      ;; we choose the first possible completion and we      ;; we choose the first possible completion and we
1662      ;; return the absolute file name      ;; return the absolute file name
1663      (let ((filename (ada-find-src-file-in-dir file)))      (let ((filename (ada-find-src-file-in-dir file)))
# Line 1605  macros `ada-name-of', `ada-line-of', `ad Line 1687  macros `ada-name-of', `ada-line-of', `ad
1687    ;; If at end of buffer (e.g the buffer is empty), error    ;; If at end of buffer (e.g the buffer is empty), error
1688    (if (>= (point) (point-max))    (if (>= (point) (point-max))
1689        (error "No identifier on point"))        (error "No identifier on point"))
1690      
1691    ;; goto first character of the identifier/operator (skip backward < and >    ;; goto first character of the identifier/operator (skip backward < and >
1692    ;; since they are part of multiple character operators    ;; since they are part of multiple character operators
1693    (goto-char pos)    (goto-char pos)
# Line 1642  macros `ada-name-of', `ada-line-of', `ad Line 1724  macros `ada-name-of', `ada-line-of', `ad
1724        (if (looking-at "[a-zA-Z0-9_]+")        (if (looking-at "[a-zA-Z0-9_]+")
1725            (set 'identifier (match-string 0))            (set 'identifier (match-string 0))
1726          (error "No identifier around")))          (error "No identifier around")))
1727        
1728      ;; Build the identlist      ;; Build the identlist
1729      (set 'identlist    (ada-make-identlist))      (set 'identlist    (ada-make-identlist))
1730      (ada-set-name      identlist (downcase identifier))      (ada-set-name      identlist (downcase identifier))
1731      (ada-set-line      identlist      (ada-set-line      identlist
1732                         (number-to-string (count-lines (point-min) (point))))                         (number-to-string (count-lines 1 (point))))
1733      (ada-set-column    identlist      (ada-set-column    identlist
1734                         (number-to-string (1+ (current-column))))                         (number-to-string (1+ (current-column))))
1735      (ada-set-file      identlist (buffer-file-name))      (ada-set-file      identlist (buffer-file-name))
# Line 1657  macros `ada-name-of', `ada-line-of', `ad Line 1739  macros `ada-name-of', `ada-line-of', `ad
1739  (defun ada-get-all-references (identlist)  (defun ada-get-all-references (identlist)
1740    "Completes and returns IDENTLIST with the information extracted    "Completes and returns IDENTLIST with the information extracted
1741  from the ali file (definition file and places where it is referenced)."  from the ali file (definition file and places where it is referenced)."
1742      
1743    (let ((ali-buffer (ada-get-ali-buffer (ada-file-of identlist)))    (let ((ali-buffer (ada-get-ali-buffer (ada-file-of identlist)))
1744          declaration-found)          declaration-found)
1745      (set-buffer ali-buffer)      (set-buffer ali-buffer)
# Line 1667  from the ali file (definition file and p Line 1749  from the ali file (definition file and p
1749      ;; First attempt: we might already be on the declaration of the identifier      ;; First attempt: we might already be on the declaration of the identifier
1750      ;; We want to look for the declaration only in a definite interval (after      ;; We want to look for the declaration only in a definite interval (after
1751      ;; the "^X ..." line for the current file, and before the next "^X" line      ;; the "^X ..." line for the current file, and before the next "^X" line
1752        
1753      (if (re-search-forward      (if (re-search-forward
1754           (concat "^X [0-9]+ " (file-name-nondirectory (ada-file-of identlist)))           (concat "^X [0-9]+ " (file-name-nondirectory (ada-file-of identlist)))
1755           nil t)           nil t)
# Line 1677  from the ali file (definition file and p Line 1759  from the ali file (definition file and p
1759                  (concat "^"    (ada-line-of identlist)                  (concat "^"    (ada-line-of identlist)
1760                          "."    (ada-column-of identlist)                          "."    (ada-column-of identlist)
1761                          "[ *]" (ada-name-of identlist)                          "[ *]" (ada-name-of identlist)
1762                          " \\(.*\\)$") bound t))                          "[{\(<= ]?\\(.*\\)$") bound t))
1763            (if declaration-found            (if declaration-found
1764                (ada-set-on-declaration identlist t))                (ada-set-on-declaration identlist t))
1765            ))            ))
# Line 1686  from the ali file (definition file and p Line 1768  from the ali file (definition file and p
1768      ;; have to fall back on other algorithms      ;; have to fall back on other algorithms
1769    
1770      (unless declaration-found      (unless declaration-found
1771          
1772        ;; Since we alread know the number of the file, search for a direct        ;; Since we alread know the number of the file, search for a direct
1773        ;; reference to it        ;; reference to it
1774        (goto-char (point-min))        (goto-char (point-min))
# Line 1696  from the ali file (definition file and p Line 1778  from the ali file (definition file and p
1778         (number-to-string (ada-find-file-number-in-ali         (number-to-string (ada-find-file-number-in-ali
1779                            (ada-file-of identlist))))                            (ada-file-of identlist))))
1780        (unless (re-search-forward (concat (ada-ali-index-of identlist)        (unless (re-search-forward (concat (ada-ali-index-of identlist)
1781                                           "|\\([0-9]+.[0-9]+ \\)*"                                           "|\\([0-9]+[^0-9][0-9]+\\(\n\\.\\)? \\)*"
1782                                           (ada-line-of identlist)                                           (ada-line-of identlist)
1783                                           "[^0-9]"                                           "[^etp]"
1784                                           (ada-column-of identlist))                                           (ada-column-of identlist) "\\>")
1785                                   nil t)                                   nil t)
1786    
1787            ;; if we did not find it, it may be because the first reference            ;; if we did not find it, it may be because the first reference
# Line 1707  from the ali file (definition file and p Line 1789  from the ali file (definition file and p
1789            ;; Or maybe we are already on the declaration...            ;; Or maybe we are already on the declaration...
1790            (unless (re-search-forward            (unless (re-search-forward
1791                     (concat                     (concat
1792                      "^\\(\\([a-zA-Z0-9_.]+\\|\"[<>=+*-/a-z]\"\\)[ *]\\)*"                      "^[0-9]+.[0-9]+[ *]"
1793                        (ada-name-of identlist)
1794                        "[ <{=\(]\\(.\\|\n\\.\\)*\\<"
1795                      (ada-line-of identlist)                      (ada-line-of identlist)
1796                      "[^0-9]"                      "[^0-9]"
1797                      (ada-column-of identlist))                      (ada-column-of identlist) "\\>")
1798                     nil t)                     nil t)
1799                
1800              ;; If still not found, then either the declaration is unknown              ;; If still not found, then either the declaration is unknown
1801              ;; or the source file has been modified since the ali file was              ;; or the source file has been modified since the ali file was
1802              ;; created              ;; created
# Line 1729  from the ali file (definition file and p Line 1813  from the ali file (definition file and p
1813              (while (looking-at "^\\.")              (while (looking-at "^\\.")
1814                (previous-line 1))                (previous-line 1))
1815              (unless (looking-at (concat "[0-9]+.[0-9]+[ *]"              (unless (looking-at (concat "[0-9]+.[0-9]+[ *]"
1816                                          (ada-name-of identlist) "[ <]"))                                          (ada-name-of identlist) "[ <{=\(]"))
1817                (set 'declaration-found nil))))                (set 'declaration-found nil))))
1818    
1819        ;; Still no success ! The ali file must be too old, and we need to        ;; Still no success ! The ali file must be too old, and we need to
# Line 1747  from the ali file (definition file and p Line 1831  from the ali file (definition file and p
1831              )))              )))
1832        )        )
1833    
1834        
1835      ;; Now that we have found a suitable line in the .ali file, get the      ;; Now that we have found a suitable line in the .ali file, get the
1836      ;; information available      ;; information available
1837      (beginning-of-line)      (beginning-of-line)
# Line 1770  from the ali file (definition file and p Line 1854  from the ali file (definition file and p
1854                     identlist                     identlist
1855                     (ada-get-ada-file-name (match-string 1)                     (ada-get-ada-file-name (match-string 1)
1856                                            (ada-file-of identlist)))                                            (ada-file-of identlist)))
1857                    
1858                  ;;  Else clean up the ali file                  ;;  Else clean up the ali file
1859                  (error                  (error
1860                   (kill-buffer ali-buffer)                   (kill-buffer ali-buffer)
1861                   (error (error-message-string err)))                   (error (error-message-string err)))
1862                  ))                  ))
1863              
1864            (ada-set-references   identlist current-line)            (ada-set-references   identlist current-line)
1865            ))            ))
1866    ))    ))
# Line 1802  This function is disabled for operators, Line 1886  This function is disabled for operators,
1886            (goto-char (point-max))            (goto-char (point-max))
1887            (while (re-search-backward my-regexp nil t)            (while (re-search-backward my-regexp nil t)
1888              (save-excursion              (save-excursion
1889                (set 'line-ali (count-lines (point-min) (point)))                (setq line-ali (count-lines 1 (point)))
1890                (beginning-of-line)                (beginning-of-line)
1891                ;; have a look at the line and column numbers                ;; have a look at the line and column numbers
1892                (if (looking-at "^\\([0-9]+\\).\\([0-9]+\\)[ *]")                (if (looking-at "^\\([0-9]+\\).\\([0-9]+\\)[ *]")
# Line 1829  This function is disabled for operators, Line 1913  This function is disabled for operators,
1913              (error (concat "No declaration of "              (error (concat "No declaration of "
1914                             (ada-name-of identlist)                             (ada-name-of identlist)
1915                             " recorded in .ali file")))                             " recorded in .ali file")))
1916              
1917             ;; one => should be the right one             ;; one => should be the right one
1918             ((= len 1)             ((= len 1)
1919              (goto-line (caar declist)))              (goto-line (caar declist)))
1920              
1921             ;; more than one => display choice list             ;; more than one => display choice list
1922             (t             (t
1923              (save-window-excursion              (save-window-excursion
1924                (with-output-to-temp-buffer "*choice list*"                (with-output-to-temp-buffer "*choice list*"
1925                    
1926                  (princ "Identifier is overloaded and Xref information is not up to date.\n")                  (princ "Identifier is overloaded and Xref information is not up to date.\n")
1927                  (princ "Possible declarations are:\n\n")                  (princ "Possible declarations are:\n\n")
1928                  (princ "  no.   in file                at line  col\n")                  (princ "  no.   in file                at line  col\n")
# Line 1910  opens a new window to show the declarati Line 1994  opens a new window to show the declarati
1994              )              )
1995          ;; Else get the nearest file          ;; Else get the nearest file
1996          (set 'file (ada-declare-file-of identlist)))          (set 'file (ada-declare-file-of identlist)))
1997          
1998        (set 'locations (append locations (list (list line col file)))))        (set 'locations (append locations (list (list line col file)))))
1999    
2000      ;; Add the specs at the end again, so that from the last body we go to      ;; Add the specs at the end again, so that from the last body we go to
# Line 1923  opens a new window to show the declarati Line 2007  opens a new window to show the declarati
2007      (setq line (caar locations)      (setq line (caar locations)
2008            col  (nth 1 (car locations))            col  (nth 1 (car locations))
2009            file (nth 2 (car locations)))            file (nth 2 (car locations)))
2010        
2011      (while locations      (while locations
2012        (if (and (string= (caar locations) (ada-line-of identlist))        (if (and (string= (caar locations) (ada-line-of identlist))
2013                 (string= (nth 1 (car locations)) (ada-column-of identlist))                 (string= (nth 1 (car locations)) (ada-column-of identlist))
# Line 1962  This command requires the external `egre Line 2046  This command requires the external `egre
2046  This works well when one is using an external librarie and wants  This works well when one is using an external librarie and wants
2047  to find the declaration and documentation of the subprograms one is  to find the declaration and documentation of the subprograms one is
2048  is using."  is using."
2049      
2050    (let (list    (let (list
2051          (dirs (ada-xref-get-obj-dir-field))          (dirs (ada-xref-get-obj-dir-field))
2052          (regexp (concat "[ *]" (ada-name-of identlist)))          (regexp (concat "[ *]" (ada-name-of identlist)))
2053          line column          line column
2054          choice          choice
2055          file)          file)
2056        
2057      (save-excursion      (save-excursion
2058          
2059        ;;  Do the grep in all the directories. We do multiple shell        ;;  Do the grep in all the directories. We do multiple shell
2060        ;;  commands instead of one in case there is no .ali file in one        ;;  commands instead of one in case there is no .ali file in one
2061        ;;  of the directory and the shell stops because of that.        ;;  of the directory and the shell stops because of that.
2062          
2063        (set-buffer (get-buffer-create "*grep*"))        (set-buffer (get-buffer-create "*grep*"))
2064        (while dirs        (while dirs
2065          (insert (shell-command-to-string          (insert (shell-command-to-string
2066                   (concat "egrep -i -h '^X|" regexp "( |$)' "                   (concat "egrep -i -h '^X|" regexp "( |$)' "
2067                           (file-name-as-directory (car dirs)) "*.ali")))                           (file-name-as-directory (car dirs)) "*.ali")))
2068          (set 'dirs (cdr dirs)))          (set 'dirs (cdr dirs)))
2069          
2070        ;;  Now parse the output        ;;  Now parse the output
2071        (set 'case-fold-search t)        (set 'case-fold-search t)
2072        (goto-char (point-min))        (goto-char (point-min))
# Line 1996  is using." Line 2080  is using."
2080                        column (match-string 2))                        column (match-string 2))
2081                  (re-search-backward "^X [0-9]+ \\(.*\\)$")                  (re-search-backward "^X [0-9]+ \\(.*\\)$")
2082                  (set 'file (list (match-string 1) line column))                  (set 'file (list (match-string 1) line column))
2083              
2084                  ;;  There could be duplicate choices, because of the structure                  ;;  There could be duplicate choices, because of the structure
2085                  ;;  of the .ali files                  ;;  of the .ali files
2086                  (unless (member file list)                  (unless (member file list)
2087                    (set 'list (append list (list file))))))))                    (set 'list (append list (list file))))))))
2088          
2089        ;;  Current buffer is still "*grep*"        ;;  Current buffer is still "*grep*"
2090        (kill-buffer "*grep*")        (kill-buffer "*grep*")
2091        )        )
2092        
2093      ;;  Now display the list of possible matches      ;;  Now display the list of possible matches
2094      (cond      (cond
2095        
2096       ;;  No choice found => Error       ;;  No choice found => Error
2097       ((null list)       ((null list)
2098        (error "No cross-reference found, please recompile your file"))        (error "No cross-reference found, please recompile your file"))
2099        
2100       ;;  Only one choice => Do the cross-reference       ;;  Only one choice => Do the cross-reference
2101       ((= (length list) 1)       ((= (length list) 1)
2102        (set 'file (ada-find-src-file-in-dir (caar list)))        (set 'file (ada-find-src-file-in-dir (caar list)))
# Line 2025  is using." Line 2109  is using."
2109          (error (concat (caar list) " not found in src_dir")))          (error (concat (caar list) " not found in src_dir")))
2110        (message "This is only a (good) guess at the cross-reference.")        (message "This is only a (good) guess at the cross-reference.")
2111        )        )
2112        
2113       ;;  Else, ask the user       ;;  Else, ask the user
2114       (t       (t
2115        (save-window-excursion        (save-window-excursion
2116          (with-output-to-temp-buffer "*choice list*"          (with-output-to-temp-buffer "*choice list*"
2117              
2118            (princ "Identifier is overloaded and Xref information is not up to date.\n")            (princ "Identifier is overloaded and Xref information is not up to date.\n")
2119            (princ "Possible declarations are:\n\n")            (princ "Possible declarations are:\n\n")
2120            (princ "  no.   in file                at line  col\n")            (princ "  no.   in file                at line  col\n")
# Line 2231  This function typically is to be hooked Line 2315  This function typically is to be hooked
2315      (progn      (progn
2316        (set-buffer-modified-p nil)        (set-buffer-modified-p nil)
2317        (kill-buffer (current-buffer))))        (kill-buffer (current-buffer))))
2318            
2319    
2320    ;;  Make sure the current buffer is the spec (this might not be the case    ;;  Make sure the current buffer is the spec (this might not be the case
2321    ;;  if for instance the user was asked for a project file)    ;;  if for instance the user was asked for a project file)
# Line 2291  find-file...." Line 2375  find-file...."
2375    ;; This should really be an `add-hook'.  -stef    ;; This should really be an `add-hook'.  -stef
2376    (setq ff-file-created-hooks 'ada-make-body-gnatstub)    (setq ff-file-created-hooks 'ada-make-body-gnatstub)
2377    
   ;; Read the project file and update the search path  
   ;; before looking for the other file  
   (make-local-hook 'ff-pre-find-hooks)  
   (add-hook 'ff-pre-find-hooks 'ada-require-project-file nil t)  
   
2378    ;; Completion for file names in the mini buffer should ignore .ali files    ;; Completion for file names in the mini buffer should ignore .ali files
2379    (add-to-list 'completion-ignored-extensions ".ali")    (add-to-list 'completion-ignored-extensions ".ali")
2380    )    )
# Line 2334  find-file...." Line 2413  find-file...."
2413  ;;  Make sure that the files are always associated with a project file. Since  ;;  Make sure that the files are always associated with a project file. Since
2414  ;;  the project file has some fields that are used for the editor (like the  ;;  the project file has some fields that are used for the editor (like the
2415  ;;  casing exceptions), it has to be read before the user edits a file).  ;;  casing exceptions), it has to be read before the user edits a file).
2416  (add-hook 'ada-mode-hook  ;; (add-hook 'ada-mode-hook
2417            (lambda()  ;;        (lambda()
2418              (let ((file (ada-prj-find-prj-file t)))  ;;          (let ((file (ada-prj-find-prj-file t)))
2419                (if file (ada-reread-prj-file file)))))  ;;            (if file (ada-reread-prj-file file)))))
2420    
2421  (provide 'ada-xref)  (provide 'ada-xref)
2422    

Legend:
Removed from v.1.10  
changed lines
  Added in v.1.10.2.1

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26