X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/4884c50b604797005e04c3317e79286314c3fa2e..199143f1fbc4f791ba20405ed1767e1cac099066:/lisp/progmodes/ada-xref.el diff --git a/lisp/progmodes/ada-xref.el b/lisp/progmodes/ada-xref.el index 5cf2c2e75b..fc1d2d46ab 100644 --- a/lisp/progmodes/ada-xref.el +++ b/lisp/progmodes/ada-xref.el @@ -1,13 +1,13 @@ ;;; ada-xref.el --- for lookup and completion in Ada mode -;; Copyright (C) 1994, 95, 96, 97, 98, 99, 2000, 2001 +;; Copyright (C) 1994, 95, 96, 97, 98, 99, 2000, 2001, 2002, 2003 ;; Free Software Foundation, Inc. ;; Author: Markus Heritsch ;; Rolf Ebert ;; Emmanuel Briot ;; Maintainer: Emmanuel Briot -;; Ada Core Technologies's version: $Revision: 1.150 $ +;; Ada Core Technologies's version: Revision: 1.181 ;; Keywords: languages ada xref ;; This file is part of GNU Emacs. @@ -33,7 +33,7 @@ ;;; for lookup and completion in Ada mode. ;;; ;;; If a file *.`adp' exists in the ada-file directory, then it is -;;; read for configuration informations. It is read only the first +;;; read for configuration informations. It is read only the first ;;; time a cross-reference is asked for, and is not read later. ;;; You need Emacs >= 20.2 to run this package @@ -44,6 +44,8 @@ (require 'compile) (require 'comint) +(require 'find-file) +(require 'ada-mode) ;; ------ Use variables (defcustom ada-xref-other-buffer t @@ -51,21 +53,30 @@ Otherwise create either a new buffer or a new frame." :type 'boolean :group 'ada) -(defcustom ada-xref-create-ali t +(defcustom ada-xref-create-ali nil "*If non-nil, run gcc whenever the cross-references are not up-to-date. -If nil, the cross-reference mode will never run gcc." +If nil, the cross-reference mode never runs gcc." :type 'boolean :group 'ada) (defcustom ada-xref-confirm-compile nil - "*If non-nil, always ask for user confirmation before compiling or running -the application." + "*If non-nil, ask for confirmation before compiling or running the application." :type 'boolean :group 'ada) (defcustom ada-krunch-args "0" - "*Maximum number of characters for filenames created by gnatkr. -Set to 0, if you don't use crunched filenames. This should be a string." + "*Maximum number of characters for filenames created by `gnatkr'. +Set to 0, if you don't use crunched filenames. This should be a string." :type 'string :group 'ada) +(defcustom ada-gnatls-args '("-v") + "*Arguments to pass to `gnatfind' to find location of the runtime. +Typical use is to pass `--RTS=soft-floats' on some systems that support it. + +You can also add `-I-' if you do not want the current directory to be included. +Otherwise, going from specs to bodies and back will first look for files in the +current directory. This only has an impact if you are not using project files, +but only ADA_INCLUDE_PATH." + :type '(repeat string) :group 'ada) + (defcustom ada-prj-default-comp-opt "-gnatq -gnatQ" "Default compilation options." :type 'string :group 'ada) @@ -79,26 +90,27 @@ Set to 0, if you don't use crunched filenames. This should be a string." :type 'string :group 'ada) (defcustom ada-prj-default-gnatmake-opt "-g" - "Default options for gnatmake." + "Default options for `gnatmake'." :type 'string :group 'ada) (defcustom ada-prj-gnatfind-switches "-rf" - "Default switches to use for gnatfind. -You should modify this variable, for instance to add -a, if you are working + "Default switches to use for `gnatfind'. +You should modify this variable, for instance to add `-a', if you are working in an environment where most ALI files are write-protected. -The command gnatfind is used every time you choose the menu +The command `gnatfind' is used every time you choose the menu \"Show all references\"." :type 'string :group 'ada) (defcustom ada-prj-default-comp-cmd - "${cross_prefix}gcc -x ada -c ${comp_opt} ${full_current}" + (concat "${cross_prefix}gnatmake -u -c ${gnatmake_opt} ${full_current} -cargs" + " ${comp_opt}") "*Default command to be used to compile a single file. -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 syntax as in the project file." :type 'string :group 'ada) (defcustom ada-prj-default-debugger "${cross_prefix}gdb" - "*Default name of the debugger. We recommend either `gdb', + "*Default name of the debugger. We recommend either `gdb', `gdb --emacs_gdbtk' or `ddd --tty -fullname'." :type 'string :group 'ada) @@ -116,7 +128,7 @@ this string is not empty." :type '(file :must-match t) :group 'ada) (defcustom ada-gnatstub-opts "-q -I${src_dir}" - "*List of the options to pass to gnatsub to generate the body of a package. + "*List of the options to pass to `gnatsub' to generate the body of a package. This has the same syntax as in the project file (with variable substitution)." :type 'string :group 'ada) @@ -126,11 +138,32 @@ Otherwise, ask the user for the name of the project file to use." :type 'boolean :group 'ada) (defconst is-windows (memq system-type (quote (windows-nt))) - "True if we are running on windows NT or windows 95.") + "True if we are running on Windows NT or Windows 95.") (defcustom ada-tight-gvd-integration nil "*If non-nil, a new Emacs frame will be swallowed in GVD when debugging. -If GVD is not the debugger used, nothing happens.") +If GVD is not the debugger used, nothing happens." + :type 'boolean :group 'ada) + +(defcustom ada-xref-search-with-egrep t + "*If non-nil, use egrep to find the possible declarations for an entity. +This alternate method is used when the exact location was not found in the +information provided by GNAT. However, it might be expensive if you have a lot +of sources, since it will search in all the files in your project." + :type 'boolean :group 'ada) + +(defvar ada-load-project-hook nil + "Hook that is run when loading a project file. +Each function in this hook takes one argument FILENAME, that is the name of +the project file to load. +This hook should be used to support new formats for the project files. + +If the function can load the file with the given filename, it should create a +buffer that contains a conversion of the file to the standard format of the +project files, and return that buffer. (The usual \"src_dir=\" or \"obj_dir=\" +lines.) It should return nil if it doesn't know how to convert that project +file.") + ;; ------- Nothing to be modified by the user below this (defvar ada-last-prj-file "" @@ -158,14 +191,13 @@ Used to go back to these positions.") (if (string-match "cmdproxy.exe" shell-file-name) "cd /d" "cd") - "Command to use to change to a specific directory. On windows systems -using cmdproxy.exe as the shell, we need to use /d or the drive is never -changed.") + "Command to use to change to a specific directory. +On Windows systems using `cmdproxy.exe' as the shell, +we need to use `/d' or the drive is never changed.") (defvar ada-command-separator (if is-windows " && " "\n") - "Separator to use when sending multiple commands to `compile' or -`start-process'. -cmdproxy.exe doesn't recognize multiple-line commands, so we have to use + "Separator to use between multiple commands to `compile' or `start-process'. +`cmdproxy.exe' doesn't recognize multiple-line commands, so we have to use \"&&\" for now.") (defconst ada-xref-pos-ring-max 16 @@ -181,13 +213,44 @@ It has the following format: \((project_name . value) (project_name . value) ...) As always, the values of the project file are defined through properties.") + +;; ----- Identlist manipulation ------------------------------------------- +;; An identlist is a vector that is used internally to reference an identifier +;; To facilitate its use, we provide the following macros + +(defmacro ada-make-identlist () (make-vector 8 nil)) +(defmacro ada-name-of (identlist) (list 'aref identlist 0)) +(defmacro ada-line-of (identlist) (list 'aref identlist 1)) +(defmacro ada-column-of (identlist) (list 'aref identlist 2)) +(defmacro ada-file-of (identlist) (list 'aref identlist 3)) +(defmacro ada-ali-index-of (identlist) (list 'aref identlist 4)) +(defmacro ada-declare-file-of (identlist) (list 'aref identlist 5)) +(defmacro ada-references-of (identlist) (list 'aref identlist 6)) +(defmacro ada-on-declaration (identlist) (list 'aref identlist 7)) + +(defmacro ada-set-name (identlist name) (list 'aset identlist 0 name)) +(defmacro ada-set-line (identlist line) (list 'aset identlist 1 line)) +(defmacro ada-set-column (identlist col) (list 'aset identlist 2 col)) +(defmacro ada-set-file (identlist file) (list 'aset identlist 3 file)) +(defmacro ada-set-ali-index (identlist index) (list 'aset identlist 4 index)) +(defmacro ada-set-declare-file (identlist file) (list 'aset identlist 5 file)) +(defmacro ada-set-references (identlist ref) (list 'aset identlist 6 ref)) +(defmacro ada-set-on-declaration (ident value) (list 'aset ident 7 value)) + +(defsubst ada-get-ali-buffer (file) + "Reads the ali file into a new buffer, and returns this buffer's name" + (find-file-noselect (ada-get-ali-file-name file))) + + +;; ----------------------------------------------------------------------- + (defun ada-quote-cmd (cmd) - "Duplicates all \\ characters in CMD so that it can be passed to `compile'" + "Duplicate all \\ characters in CMD so that it can be passed to `compile'." (mapconcat 'identity (split-string cmd "\\\\") "\\\\")) (defun ada-initialize-runtime-library (cross-prefix) - "Initializes the variables for the runtime library location. -CROSS-PREFIX is the prefix to use for the gnatls command" + "Initialize the variables for the runtime library location. +CROSS-PREFIX is the prefix to use for the gnatls command." (save-excursion (setq ada-xref-runtime-library-specs-path '() ada-xref-runtime-library-ali-path '()) @@ -199,17 +262,18 @@ CROSS-PREFIX is the prefix to use for the gnatls command" ;; Even if we get an error, delete the *gnatls* buffer (unwind-protect (progn - (call-process (concat cross-prefix "gnatls") - nil t nil "-v") + (apply 'call-process (concat cross-prefix "gnatls") + (append '(nil t nil) ada-gnatls-args)) (goto-char (point-min)) ;; Source path - + (search-forward "Source Search Path:") (forward-line 1) (while (not (looking-at "^$")) (back-to-indentation) - (unless (looking-at "") + (if (looking-at "") + (add-to-list 'ada-xref-runtime-library-specs-path ".") (add-to-list 'ada-xref-runtime-library-specs-path (buffer-substring-no-properties (point) @@ -217,12 +281,13 @@ CROSS-PREFIX is the prefix to use for the gnatls command" (forward-line 1)) ;; Object path - + (search-forward "Object Search Path:") (forward-line 1) (while (not (looking-at "^$")) (back-to-indentation) - (unless (looking-at "") + (if (looking-at "") + (add-to-list 'ada-xref-runtime-library-ali-path ".") (add-to-list 'ada-xref-runtime-library-ali-path (buffer-substring-no-properties (point) @@ -261,7 +326,7 @@ replaced by the name including the extension." (if (null value) (if (not (setq value (getenv name))) (message (concat "No environment variable " name " found")))) - + (cond ((null value) (setq cmd-string (replace-match "" t t cmd-string))) @@ -282,17 +347,16 @@ replaced by the name including the extension." plist) (save-excursion (set-buffer ada-buffer) - + (set 'plist ;; Try hard to find a default value for filename, so that the user ;; can edit his project file even if the current buffer is not an ;; Ada file or not even associated with a file (list 'filename (expand-file-name (cond - (file - (ada-prj-get-prj-dir file)) (ada-prj-default-project-file ada-prj-default-project-file) + (file (ada-prj-find-prj-file file t)) (t (message (concat "Not editing an Ada file," "and no default project " @@ -336,7 +400,7 @@ replaced by the name including the extension." 'debug_post_cmd (list nil))) ) (set symbol plist))) - + (defun ada-xref-get-project-field (field) "Extract the value of FIELD from the current project file. The project file must have been loaded first. @@ -352,7 +416,7 @@ addition return the default paths." ;; Get the project file (either the current one, or a default one) (setq file (or (assoc file-name ada-xref-project-files) (assoc nil ada-xref-project-files))) - + ;; If the file was not found, use the default values (if file ;; Get the value from the file @@ -388,10 +452,10 @@ All the directories are returned as absolute directories." (append ;; Add ${build_dir} in front of the path (list build-dir) - + (ada-get-absolute-dir-list (ada-xref-get-project-field 'src_dir) build-dir) - + ;; Add the standard runtime at the end ada-xref-runtime-library-specs-path))) @@ -403,57 +467,51 @@ All the directories are returned as absolute directories." (append ;; Add ${build_dir} in front of the path (list build-dir) - + (ada-get-absolute-dir-list (ada-xref-get-project-field 'obj_dir) build-dir) - + ;; Add the standard runtime at the end ada-xref-runtime-library-ali-path))) (defun ada-xref-update-project-menu () "Update the menu Ada->Project, with the list of available project files." - (interactive) - (let (submenu) - - ;; Create the standard items - (set 'submenu (list (cons 'Load (cons "Load..." - 'ada-set-default-project-file)) - (cons 'New (cons "New..." 'ada-prj-new)) - (cons 'Edit (cons "Edit..." 'ada-prj-edit)) - (cons 'sep (cons "---" nil)))) - - ;; Add the new items - (mapcar - (lambda (x) - (let ((name (or (car x) "")) - (command `(lambda () - "Change the active project file." - (interactive) - (ada-parse-prj-file ,(car x)) - (set 'ada-prj-default-project-file ,(car x)) - (ada-xref-update-project-menu)))) - (set 'submenu - (append submenu - (list (cons (intern name) - (list - 'menu-item (file-name-sans-extension - (file-name-nondirectory name)) - command - :button (cons - :toggle - (equal ada-prj-default-project-file - (car x)) - )))))))) - - ;; Parses all the known project files, and insert at least the default - ;; one (in case ada-xref-project-files is nil) - (or ada-xref-project-files '(nil))) - - (if (not ada-xemacs) - (if (lookup-key ada-mode-map [menu-bar Ada Project]) - (setcdr (lookup-key ada-mode-map [menu-bar Ada Project]) - submenu))) - )) + ;; Create the standard items. + (let ((submenu + `("Project" + ["Load..." ada-set-default-project-file t] + ["New..." ada-prj-new t] + ["Edit..." ada-prj-edit t] + "---" + ;; Add the new items + ,@(mapcar + (lambda (x) + (let ((name (or (car x) "")) + (command `(lambda () + "Change the active project file." + (interactive) + (ada-parse-prj-file ,(car x)) + (set 'ada-prj-default-project-file ,(car x)) + (ada-xref-update-project-menu)))) + (vector + (if (string= (file-name-extension name) + ada-project-file-extension) + (file-name-sans-extension + (file-name-nondirectory name)) + (file-name-nondirectory name)) + command + :button (cons + :toggle + (equal ada-prj-default-project-file + (car x)) + )))) + + ;; Parses all the known project files, and insert at + ;; least the default one (in case + ;; ada-xref-project-files is nil) + (or ada-xref-project-files '(nil)))))) + + (easy-menu-add-item ada-mode-menu '() submenu))) ;;------------------------------------------------------------- @@ -499,207 +557,6 @@ Completion is available." (error (concat filename " not found in src_dir"))))) -;; ----- Keybindings ------------------------------------------------------ - -(defun ada-add-keymap () - "Add new key bindings when using `ada-xrel.el'." - (interactive) - (if ada-xemacs - (progn - (define-key ada-mode-map '(shift button3) 'ada-point-and-xref) - (define-key ada-mode-map '(control tab) 'ada-complete-identifier)) - (define-key ada-mode-map [C-tab] 'ada-complete-identifier) - (define-key ada-mode-map [S-mouse-3] 'ada-point-and-xref)) - - (define-key ada-mode-map "\C-co" 'ff-find-other-file) - (define-key ada-mode-map "\C-c5\C-d" 'ada-goto-declaration-other-frame) - (define-key ada-mode-map "\C-c\C-d" 'ada-goto-declaration) - (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) - (define-key ada-mode-map "\C-c\C-c" 'ada-compile-application) - (define-key ada-mode-map "\C-cc" 'ada-change-prj) - (define-key ada-mode-map "\C-cd" 'ada-set-default-project-file) - (define-key ada-mode-map "\C-cg" 'ada-gdb-application) - (define-key ada-mode-map "\C-cr" 'ada-run-application) - (define-key ada-mode-map "\C-c\C-o" 'ada-goto-parent) - (define-key ada-mode-map "\C-c\C-r" 'ada-find-references) - (define-key ada-mode-map "\C-c\C-v" 'ada-check-current) - (define-key ada-mode-map "\C-c\C-f" 'ada-find-file) - ) - -;; ----- Menus -------------------------------------------------------------- -(defun ada-add-ada-menu () - "Add some items to the standard Ada mode menu. -The items are added to the menu called NAME, which should be the same -name as was passed to `ada-create-menu'." - (interactive) - (if ada-xemacs - (let* ((menu-list '("Ada")) - (goto-menu '("Ada" "Goto")) - (edit-menu '("Ada" "Edit")) - (help-menu '("Ada" "Help")) - (options-menu (list "Ada" "Options"))) - (funcall (symbol-function 'add-menu-button) - menu-list ["Check file" ada-check-current - (string= mode-name "Ada")] "Goto") - (funcall (symbol-function 'add-menu-button) - menu-list ["Compile file" ada-compile-current - (string= mode-name "Ada")] "Goto") - (funcall (symbol-function 'add-menu-button) - menu-list ["Build" ada-compile-application t] "Goto") - (funcall (symbol-function 'add-menu-button) - menu-list ["Run" ada-run-application t] "Goto") - (funcall (symbol-function 'add-menu-button) - menu-list ["Debug" ada-gdb-application t] "Goto") - (funcall (symbol-function 'add-menu-button) - menu-list ["--" nil t] "Goto") - (funcall (symbol-function 'add-menu-button) - goto-menu ["Goto Parent Unit" ada-goto-parent t] - "Next compilation error") - (funcall (symbol-function 'add-menu-button) - goto-menu ["Goto References to any entity" - ada-find-any-references t] - "Next compilation error") - (funcall (symbol-function 'add-menu-button) - goto-menu ["List References" ada-find-references t] - "Next compilation error") - (funcall (symbol-function 'add-menu-button) - goto-menu ["Goto Declaration Other Frame" - ada-goto-declaration-other-frame t] - "Next compilation error") - (funcall (symbol-function 'add-menu-button) - goto-menu ["Goto Declaration/Body" - ada-goto-declaration t] - "Next compilation error") - (funcall (symbol-function 'add-menu-button) - goto-menu ["Goto Previous Reference" - ada-xref-goto-previous-reference t] - "Next compilation error") - (funcall (symbol-function 'add-menu-button) - goto-menu ["--" nil t] "Next compilation error") - (funcall (symbol-function 'add-menu-button) - edit-menu ["Complete Identifier" - ada-complete-identifier t] - "Indent Line") - (funcall (symbol-function 'add-menu-button) - edit-menu ["--------" nil t] "Indent Line") - (funcall (symbol-function 'add-menu-button) - help-menu ["Gnat User Guide" (info "gnat_ug")]) - (funcall (symbol-function 'add-menu-button) - help-menu ["Gnat Reference Manual" (info "gnat_rm")]) - (funcall (symbol-function 'add-menu-button) - help-menu ["Gcc Documentation" (info "gcc")]) - (funcall (symbol-function 'add-menu-button) - help-menu ["Gdb Documentation" (info "gdb")]) - (funcall (symbol-function 'add-menu-button) - help-menu ["Ada95 Reference Manual" (info "arm95")]) - (funcall (symbol-function 'add-menu-button) - options-menu - ["Show Cross-References in Other Buffer" - (setq ada-xref-other-buffer - (not ada-xref-other-buffer)) - :style toggle :selected ada-xref-other-buffer]) - (funcall (symbol-function 'add-menu-button) - options-menu - ["Automatically Recompile for Cross-References" - (setq ada-xref-create-ali (not ada-xref-create-ali)) - :style toggle :selected ada-xref-create-ali]) - (funcall (symbol-function 'add-menu-button) - options-menu - ["Confirm Commands" - (setq ada-xref-confirm-compile - (not ada-xref-confirm-compile)) - :style toggle :selected ada-xref-confirm-compile]) - (if (string-match "gvd" ada-prj-default-debugger) - (funcall (symbol-function 'add-menu-button) - options-menu - ["Tight Integration With Gnu Visual Debugger" - (setq ada-tight-gvd-integration - (not ada-tight-gvd-integration)) - :style toggle :selected ada-tight-gvd-integration])) - ) - - ;; for Emacs - (let* ((menu (lookup-key ada-mode-map [menu-bar Ada])) - (edit-menu (lookup-key ada-mode-map [menu-bar Ada Edit])) - (help-menu (lookup-key ada-mode-map [menu-bar Ada Help])) - (goto-menu (lookup-key ada-mode-map [menu-bar Ada Goto])) - (options-menu (lookup-key ada-mode-map [menu-bar Ada Options]))) - - (define-key-after menu [Check] '("Check file" . ada-check-current) - 'Customize) - (define-key-after menu [Compile] '("Compile file" . ada-compile-current) - 'Check) - (define-key-after menu [Build] '("Build" . ada-compile-application) - 'Compile) - (define-key-after menu [Run] '("Run" . ada-run-application) 'Build) - (define-key-after menu [Debug] '("Debug" . ada-gdb-application) 'Run) - (define-key-after menu [rem] '("--" . nil) 'Debug) - (define-key-after menu [Project] - (cons "Project" (make-sparse-keymap)) 'rem) - - (define-key help-menu [Gnat_ug] - '("Gnat User Guide" . (lambda() (interactive) (info "gnat_ug")))) - (define-key help-menu [Gnat_rm] - '("Gnat Reference Manual" . (lambda() (interactive) (info "gnat_rm")))) - (define-key help-menu [Gcc] - '("Gcc Documentation" . (lambda() (interactive) (info "gcc")))) - (define-key help-menu [gdb] - '("Gdb Documentation" . (lambda() (interactive) (info "gdb")))) - (define-key help-menu [arm95] - '("Ada95 Reference Manual" . (lambda() (interactive) (info "arm95")))) - - (define-key goto-menu [rem] '("----" . nil)) - (define-key goto-menu [Parent] '("Goto Parent Unit" - . ada-goto-parent)) - (define-key goto-menu [References-any] - '("Goto References to any entity" . ada-find-any-references)) - (define-key goto-menu [References] - '("List References" . ada-find-references)) - (define-key goto-menu [Prev] - '("Goto Previous Reference" . ada-xref-goto-previous-reference)) - (define-key goto-menu [Decl-other] - '("Goto Declaration Other Frame" . ada-goto-declaration-other-frame)) - (define-key goto-menu [Decl] - '("Goto Declaration/Body" . ada-goto-declaration)) - - (define-key edit-menu [rem] '("----" . nil)) - (define-key edit-menu [Complete] '("Complete Identifier" - . ada-complete-identifier)) - - (define-key-after options-menu [xrefrecompile] - '(menu-item "Automatically Recompile for Cross-References" - (lambda()(interactive) - (setq ada-xref-create-ali (not ada-xref-create-ali))) - :button (:toggle . ada-xref-create-ali)) t) - (define-key-after options-menu [xrefconfirm] - '(menu-item "Confirm Commands" - (lambda()(interactive) - (setq ada-xref-confirm-compile - (not ada-xref-confirm-compile))) - :button (:toggle . ada-xref-confirm-compile)) t) - (define-key-after options-menu [xrefother] - '(menu-item "Show Cross-References in Other Buffer" - (lambda()(interactive) - (setq ada-xref-other-buffer (not ada-xref-other-buffer))) - :button (:toggle . ada-xref-other-buffer)) t) - - (if (string-match "gvd" ada-prj-default-debugger) - (define-key-after options-menu [tightgvd] - '(menu-item "Tight Integration With Gnu Visual Debugger" - (lambda()(interactive) - (setq ada-tight-gvd-integration - (not ada-tight-gvd-integration))) - :button (:toggle . ada-tight-gvd-integration)) t)) - - (define-key ada-mode-map [menu-bar Ada Edit rem3] '("------------" . nil)) - (define-key ada-mode-map [menu-bar Ada Edit open-file-from-src-path] - '("Search File on source path..." . ada-find-file)) - ) - ) - (ada-xref-update-project-menu) - ) - ;; ----- Utilities ------------------------------------------------- (defun ada-require-project-file () @@ -708,7 +565,7 @@ name as was passed to `ada-create-menu'." (not ada-xref-project-files) (string= ada-prj-default-project-file "")) (ada-reread-prj-file))) - + (defun ada-xref-push-pos (filename position) "Push (FILENAME, POSITION) on the position ring for cross-references." (setq ada-xref-pos-ring (cons (list position filename) ada-xref-pos-ring)) @@ -729,42 +586,50 @@ name as was passed to `ada-create-menu'." This is overriden on VMS to convert from VMS filenames to Unix filenames." name) -(defun ada-set-default-project-file (name) - "Set the file whose name is NAME as the default project file." +(defun ada-set-default-project-file (name &optional keep-existing) + "Set the file whose name is NAME as the default project file. +If KEEP-EXISTING is true and a project file has already been loaded, nothing +is done. This is meant to be used from `ada-mode-hook', for instance, to force +a project file unless the user has already loaded one." (interactive "fProject file:") - (set 'ada-prj-default-project-file name) - (ada-reread-prj-file name) - ) + (if (or (not keep-existing) + (not ada-prj-default-project-file) + (equal ada-prj-default-project-file "")) + (progn + (setq ada-prj-default-project-file name) + (ada-reread-prj-file name)))) ;; ------ Handling the project file ----------------------------- -(defun ada-prj-find-prj-file (&optional no-user-question) - "Find the prj file associated with the current buffer. +(defun ada-prj-find-prj-file (&optional file no-user-question) + "Find the prj file associated with FILE (or the current buffer if nil). If NO-USER-QUESTION is non-nil, use a default file if not project file was found, and do not ask the user. If the buffer is not an Ada buffer, associate it with the default project -file. If none is set, return nil." +file. If none is set, return nil." (let (selected) ;; Use the active project file if there is one. ;; This is also valid if we don't currently have an Ada buffer, or if ;; the current buffer is not a real file (for instance an emerge buffer) - + (if (or (not (string= mode-name "Ada")) - (not (buffer-file-name)) - (and ada-prj-default-project-file - (not (string= ada-prj-default-project-file "")))) - (set 'selected ada-prj-default-project-file) - + (not (buffer-file-name))) + + (if (and ada-prj-default-project-file + (not (string= ada-prj-default-project-file ""))) + (setq selected ada-prj-default-project-file) + (setq selected nil)) + ;; other cases: use a more complex algorithm - - (let* ((current-file (buffer-file-name)) + + (let* ((current-file (or file (buffer-file-name))) (first-choice (concat (file-name-sans-extension current-file) ada-project-file-extension)) (dir (file-name-directory current-file)) - + ;; on Emacs 20.2, directory-files does not work if ;; parse-sexp-lookup-properties is set (parse-sexp-lookup-properties nil) @@ -773,18 +638,18 @@ file. If none is set, return nil." (concat ".*" (regexp-quote ada-project-file-extension) "$"))) (choice nil)) - + (cond - + ;; Else if there is a project file with the same name as the Ada ;; file, but not the same extension. ((file-exists-p first-choice) (set 'selected first-choice)) - + ;; Else if only one project file was found in the current directory ((= (length prj-files) 1) (set 'selected (car prj-files))) - + ;; Else if there are multiple files, ask the user ((and (> (length prj-files) 1) (not no-user-question)) (save-window-excursion @@ -799,6 +664,7 @@ file. If none is set, return nil." counter (nth (1- counter) prj-files))) (setq counter (1+ counter)) + ))) ; end of with-output-to ... (setq choice nil) (while (or @@ -809,7 +675,7 @@ file. If none is set, return nil." (setq choice (string-to-int (read-from-minibuffer "Enter No. of your choice: ")))) (set 'selected (nth (1- choice) prj-files)))) - + ;; Else if no project file was found in the directory, ask a name ;; to the user, using as a default value the last one entered by ;; the user @@ -822,7 +688,8 @@ file. If none is set, return nil." (unless (string= ada-last-prj-file "") (set 'selected ada-last-prj-file)))) ))) - selected + + (or selected "default.adp") )) @@ -835,85 +702,117 @@ The current buffer should be the ada-file buffer." (ada-buffer (current-buffer))) (setq prj-file (expand-file-name prj-file)) + ;; Set the project file as the active one. + (setq ada-prj-default-project-file prj-file) + ;; Initialize the project with the default values (ada-xref-set-default-prj-values 'project (current-buffer)) ;; Do not use find-file below, since we don't want to show this - ;; buffer. If the file is open through speedbar, we can't use + ;; buffer. If the file is open through speedbar, we can't use ;; find-file anyway, since the speedbar frame is special and does not ;; allow the selection of a file in it. - (set-buffer (find-file-noselect prj-file)) - - (widen) - (goto-char (point-min)) - - ;; Now overrides these values with the project file - (while (not (eobp)) - (if (looking-at "^\\([^=]+\\)=\\(.*\\)") - (cond - ((string= (match-string 1) "src_dir") - (add-to-list 'src_dir - (file-name-as-directory (match-string 2)))) - ((string= (match-string 1) "obj_dir") - (add-to-list 'obj_dir - (file-name-as-directory (match-string 2)))) - ((string= (match-string 1) "casing") - (set 'casing (cons (match-string 2) casing))) - ((string= (match-string 1) "build_dir") - (set 'project - (plist-put project 'build_dir - (file-name-as-directory (match-string 2))))) - ((string= (match-string 1) "make_cmd") - (add-to-list 'make_cmd (match-string 2))) - ((string= (match-string 1) "comp_cmd") - (add-to-list 'comp_cmd (match-string 2))) - ((string= (match-string 1) "check_cmd") - (add-to-list 'check_cmd (match-string 2))) - ((string= (match-string 1) "run_cmd") - (add-to-list 'run_cmd (match-string 2))) - ((string= (match-string 1) "debug_pre_cmd") - (add-to-list 'debug_pre_cmd (match-string 2))) - ((string= (match-string 1) "debug_post_cmd") - (add-to-list 'debug_post_cmd (match-string 2))) - (t - (set 'project (plist-put project (intern (match-string 1)) - (match-string 2)))))) - (forward-line 1)) - - (if src_dir (set 'project (plist-put project 'src_dir - (reverse src_dir)))) - (if obj_dir (set 'project (plist-put project 'obj_dir - (reverse obj_dir)))) - (if casing (set 'project (plist-put project 'casing - (reverse casing)))) - (if make_cmd (set 'project (plist-put project 'make_cmd - (reverse make_cmd)))) - (if comp_cmd (set 'project (plist-put project 'comp_cmd - (reverse comp_cmd)))) - (if check_cmd (set 'project (plist-put project 'check_cmd - (reverse check_cmd)))) - (if run_cmd (set 'project (plist-put project 'run_cmd - (reverse run_cmd)))) - (set 'project (plist-put project 'debug_post_cmd - (reverse debug_post_cmd))) - (set 'project (plist-put project 'debug_pre_cmd - (reverse debug_pre_cmd))) + (if (file-exists-p prj-file) + (progn + (let* ((buffer (run-hook-with-args-until-success + 'ada-load-project-hook prj-file))) + (unless buffer + (setq buffer (find-file-noselect prj-file nil))) + (set-buffer buffer)) + + (widen) + (goto-char (point-min)) + + ;; Now overrides these values with the project file + (while (not (eobp)) + (if (looking-at "^\\([^=]+\\)=\\(.*\\)") + (cond + ((string= (match-string 1) "src_dir") + (add-to-list 'src_dir + (file-name-as-directory (match-string 2)))) + ((string= (match-string 1) "obj_dir") + (add-to-list 'obj_dir + (file-name-as-directory (match-string 2)))) + ((string= (match-string 1) "casing") + (set 'casing (cons (match-string 2) casing))) + ((string= (match-string 1) "build_dir") + (set 'project + (plist-put project 'build_dir + (file-name-as-directory (match-string 2))))) + ((string= (match-string 1) "make_cmd") + (add-to-list 'make_cmd (match-string 2))) + ((string= (match-string 1) "comp_cmd") + (add-to-list 'comp_cmd (match-string 2))) + ((string= (match-string 1) "check_cmd") + (add-to-list 'check_cmd (match-string 2))) + ((string= (match-string 1) "run_cmd") + (add-to-list 'run_cmd (match-string 2))) + ((string= (match-string 1) "debug_pre_cmd") + (add-to-list 'debug_pre_cmd (match-string 2))) + ((string= (match-string 1) "debug_post_cmd") + (add-to-list 'debug_post_cmd (match-string 2))) + (t + (set 'project (plist-put project (intern (match-string 1)) + (match-string 2)))))) + (forward-line 1)) + + (if src_dir (set 'project (plist-put project 'src_dir + (reverse src_dir)))) + (if obj_dir (set 'project (plist-put project 'obj_dir + (reverse obj_dir)))) + (if casing (set 'project (plist-put project 'casing + (reverse casing)))) + (if make_cmd (set 'project (plist-put project 'make_cmd + (reverse make_cmd)))) + (if comp_cmd (set 'project (plist-put project 'comp_cmd + (reverse comp_cmd)))) + (if check_cmd (set 'project (plist-put project 'check_cmd + (reverse check_cmd)))) + (if run_cmd (set 'project (plist-put project 'run_cmd + (reverse run_cmd)))) + (set 'project (plist-put project 'debug_post_cmd + (reverse debug_post_cmd))) + (set 'project (plist-put project 'debug_pre_cmd + (reverse debug_pre_cmd))) + + ;; Kill the project buffer + (kill-buffer nil) + (set-buffer ada-buffer) + ) + + ;; Else the file wasn't readable (probably the default project). + ;; We initialize it with the current environment variables. + ;; We need to add the startup directory in front so that + ;; files locally redefined are properly found. We cannot + ;; add ".", which varies too much depending on what the + ;; current buffer is. + (set 'project + (plist-put project 'src_dir + (append + (list command-line-default-directory) + (split-string (or (getenv "ADA_INCLUDE_PATH") "") ":") + (list "." default-directory)))) + (set 'project + (plist-put project 'obj_dir + (append + (list command-line-default-directory) + (split-string (or (getenv "ADA_OBJECTS_PATH") "") ":") + (list "." default-directory)))) + ) + ;; Delete the default project file from the list, if it is there. ;; Note that in that case, this default project is the only one in ;; the list (if (assoc nil ada-xref-project-files) (setq ada-xref-project-files nil)) - + ;; Memorize the newly read project file (if (assoc prj-file ada-xref-project-files) (setcdr (assoc prj-file ada-xref-project-files) project) (add-to-list 'ada-xref-project-files (cons prj-file project))) - ;; Set the project file as the active one. - (setq ada-prj-default-project-file prj-file) - ;; Sets up the compilation-search-path so that Emacs is able to ;; go to the source of the errors in a compilation buffer (setq compilation-search-path (ada-xref-get-src-dir-field)) @@ -923,35 +822,31 @@ The current buffer should be the ada-file buffer." (progn (setq ada-case-exception-file (reverse casing)) (ada-case-read-exceptions))) - + ;; Add the directories to the search path for ff-find-other-file ;; Do not add the '/' or '\' at the end - (setq ada-search-directories + (setq ada-search-directories-internal (append (mapcar 'directory-file-name compilation-search-path) ada-search-directories)) - - ;; Kill the .ali buffer - (kill-buffer nil) - (set-buffer ada-buffer) (ada-xref-update-project-menu) ) ;; No prj file ? => Setup default values ;; Note that nil means that all compilation modes will first look in the - ;; current directory, and only then in the current file's directory. This + ;; current directory, and only then in the current file's directory. This ;; current file is assumed at this point to be in the common source ;; directory. (setq compilation-search-path (list nil default-directory)) )) - - -(defun ada-find-references (&optional pos) + + +(defun ada-find-references (&optional pos arg local-only) "Find all references to the entity under POS. -Calls gnatfind to find the references." - (interactive "") - (unless pos - (set 'pos (point))) +Calls gnatfind to find the references. +If ARG is t, the contents of the old *gnatfind* buffer is preserved. +If LOCAL-ONLY is t, only the declarations in the current file are returned." + (interactive "d\nP") (ada-require-project-file) (let* ((identlist (ada-read-identifier pos)) @@ -965,20 +860,32 @@ Calls gnatfind to find the references." (file-newer-than-file-p (ada-file-of identlist) alifile)) (ada-find-any-references (ada-name-of identlist) (ada-file-of identlist) - nil nil) + nil nil local-only arg) (ada-find-any-references (ada-name-of identlist) (ada-file-of identlist) (ada-line-of identlist) - (ada-column-of identlist)))) + (ada-column-of identlist) local-only arg))) ) -(defun ada-find-any-references (entity &optional file line column) +(defun ada-find-local-references (&optional pos arg) + "Find all references to the entity under POS. +Calls `gnatfind' to find the references. +If ARG is t, the contents of the old *gnatfind* buffer is preserved." + (interactive "d\nP") + (ada-find-references pos arg t)) + +(defun ada-find-any-references + (entity &optional file line column local-only append) "Search for references to any entity whose name is ENTITY. -ENTITY was first found the location given by FILE, LINE and COLUMN." +ENTITY was first found the location given by FILE, LINE and COLUMN. +If LOCAL-ONLY is t, then list only the references in FILE, which +is much faster. +If APPEND is t, then append the output of the command to the existing +buffer `*gnatfind*', if there is one." (interactive "sEntity name: ") (ada-require-project-file) - ;; Prepare the gnatfind command. Note that we must protect the quotes + ;; Prepare the gnatfind command. Note that we must protect the quotes ;; around operators, so that they are correctly handled and can be ;; processed (gnatfind \"+\":...). (let* ((quote-entity @@ -988,62 +895,51 @@ ENTITY was first found the location given by FILE, LINE and COLUMN." (concat "'\"" (substring entity 1 -1) "\"'")) entity)) (switches (ada-xref-get-project-field 'gnatfind_opt)) - (command (concat "gnatfind " switches " " + (command (concat "gnat find " switches " " quote-entity (if file (concat ":" (file-name-nondirectory file))) (if line (concat ":" line)) - (if column (concat ":" column))))) + (if column (concat ":" column)) + (if local-only (concat " " (file-name-nondirectory file))) + )) + old-contents) ;; If a project file is defined, use it (if (and ada-prj-default-project-file (not (string= ada-prj-default-project-file ""))) - (setq command (concat command " -p" ada-prj-default-project-file))) + (if (string-equal (file-name-extension ada-prj-default-project-file) + "gpr") + (setq command (concat command " -P" ada-prj-default-project-file)) + (setq command (concat command " -p" ada-prj-default-project-file)))) + + (if (and append (get-buffer "*gnatfind*")) + (save-excursion + (set-buffer "*gnatfind*") + (setq old-contents (buffer-string)))) - (compile-internal command "No more references" "gnatfind") + (let ((compilation-error "reference")) + (compilation-start command)) ;; Hide the "Compilation" menu (save-excursion (set-buffer "*gnatfind*") - (local-unset-key [menu-bar compilation-menu])) + (local-unset-key [menu-bar compilation-menu]) + + (if old-contents + (progn + (goto-char 1) + (insert old-contents) + (goto-char (point-max))))) ) ) (defalias 'ada-change-prj (symbol-function 'ada-set-default-project-file)) -;; ----- Identlist manipulation ------------------------------------------- -;; An identlist is a vector that is used internally to reference an identifier -;; To facilitate its use, we provide the following macros - -(defmacro ada-make-identlist () (make-vector 8 nil)) -(defmacro ada-name-of (identlist) (list 'aref identlist 0)) -(defmacro ada-line-of (identlist) (list 'aref identlist 1)) -(defmacro ada-column-of (identlist) (list 'aref identlist 2)) -(defmacro ada-file-of (identlist) (list 'aref identlist 3)) -(defmacro ada-ali-index-of (identlist) (list 'aref identlist 4)) -(defmacro ada-declare-file-of (identlist) (list 'aref identlist 5)) -(defmacro ada-references-of (identlist) (list 'aref identlist 6)) -(defmacro ada-on-declaration (identlist) (list 'aref identlist 7)) - -(defmacro ada-set-name (identlist name) (list 'aset identlist 0 name)) -(defmacro ada-set-line (identlist line) (list 'aset identlist 1 line)) -(defmacro ada-set-column (identlist col) (list 'aset identlist 2 col)) -(defmacro ada-set-file (identlist file) (list 'aset identlist 3 file)) -(defmacro ada-set-ali-index (identlist index) (list 'aset identlist 4 index)) -(defmacro ada-set-declare-file (identlist file) (list 'aset identlist 5 file)) -(defmacro ada-set-references (identlist ref) (list 'aset identlist 6 ref)) -(defmacro ada-set-on-declaration (ident value) (list 'aset ident 7 value)) - -(defsubst ada-get-ali-buffer (file) - "Reads the ali file into a new buffer, and returns this buffer's name" - (find-file-noselect (ada-get-ali-file-name file))) - - - ;; ----- Identifier Completion -------------------------------------------- (defun ada-complete-identifier (pos) "Tries to complete the identifier around POS. -The feature is only available if the files where compiled not using the -gnatx -option." +The feature is only available if the files where compiled without +the option `-gnatx'." (interactive "d") (ada-require-project-file) @@ -1081,11 +977,29 @@ option." ;; ----- Cross-referencing ---------------------------------------- (defun ada-point-and-xref () - "Calls `mouse-set-point' and then `ada-goto-declaration'." + "Jump to the declaration of the entity below the cursor." (interactive) (mouse-set-point last-input-event) (ada-goto-declaration (point))) +(defun ada-point-and-xref-body () + "Jump to the body of the entity under the cursor." + (interactive) + (mouse-set-point last-input-event) + (ada-goto-body (point))) + +(defun ada-goto-body (pos &optional other-frame) + "Display the body of the entity around POS. +If the entity doesn't have a body, display its declaration. +As a side effect, the buffer for the declaration is also open." + (interactive "d") + (ada-goto-declaration pos other-frame) + + ;; Temporarily force the display in the same buffer, since we + ;; already changed previously + (let ((ada-xref-other-buffer nil)) + (ada-goto-declaration (point) nil))) + (defun ada-goto-declaration (pos &optional other-frame) "Display the declaration of the identifier around POS. The declaration is shown in another buffer if `ada-xref-other-buffer' is @@ -1102,9 +1016,22 @@ If OTHER-FRAME is non-nil, display the cross-reference in another frame." (let ((identlist (ada-read-identifier pos))) (condition-case nil (ada-find-in-ali identlist other-frame) - (error (ada-find-in-src-path identlist other-frame))))) - -(defun ada-goto-declaration-other-frame (pos &optional other-frame) + (error + (let ((ali-file (ada-get-ali-file-name (ada-file-of identlist)))) + + ;; If the ALI file was up-to-date, then we probably have a predefined + ;; entity, whose references are not given by GNAT + (if (and (file-exists-p ali-file) + (file-newer-than-file-p ali-file (ada-file-of identlist))) + (message "No cross-reference found--may be a predefined entity.") + + ;; Else, look in every ALI file, except if the user doesn't want that + (if ada-xref-search-with-egrep + (ada-find-in-src-path identlist other-frame) + (message "Cross-referencing information is not up-to-date; please recompile.") + ))))))) + +(defun ada-goto-declaration-other-frame (pos) "Display the declaration of the identifier around POS. The declation is shown in another frame if `ada-xref-other-buffer' is non-nil." (interactive "d") @@ -1122,12 +1049,13 @@ The declation is shown in another frame if `ada-xref-other-buffer' is non-nil." (defun ada-get-absolute-dir-list (dir-list root-dir) "Returns the list of absolute directories found in dir-list. -If a directory is a relative directory, the value of ROOT-DIR is added in -front." +If a directory is a relative directory, add the value of ROOT-DIR in front." (mapcar (lambda (x) (expand-file-name x root-dir)) dir-list)) (defun ada-set-environment () - "Return the new value for process-environment. + "Prepare an environment for Ada compilation. +This returns a new value to use for `process-environment', +but does not actually put it into use. It modifies the source path and object path with the values found in the project file." (let ((include (getenv "ADA_INCLUDE_PATH")) @@ -1152,7 +1080,7 @@ project file." process-environment)))) (defun ada-compile-application (&optional arg) - "Compiles the application, using the command found in the project file. + "Compile the application, using the command found in the project file. If ARG is not nil, ask for user confirmation." (interactive "P") (ada-require-project-file) @@ -1169,16 +1097,16 @@ If ARG is not nil, ask for user confirmation." ;; Make a single command from the list of commands, including the ;; commands to run it on a remote machine. (setq cmd (ada-remote (mapconcat 'identity cmd ada-command-separator))) - + (if (or ada-xref-confirm-compile arg) (setq cmd (read-from-minibuffer "enter command to compile: " cmd))) ;; Insert newlines so as to separate the name of the commands to run - ;; and the output of the commands. this doesn't work with cmdproxy.exe, + ;; and the output of the commands. This doesn't work with cmdproxy.exe, ;; which gets confused by newline characters. - (if (not (string-match "cmdproxy.exe" shell-file-name)) + (if (not (string-match ".exe" shell-file-name)) (setq cmd (concat cmd "\n\n"))) - + (compile (ada-quote-cmd cmd)))) (defun ada-compile-current (&optional arg prj-field) @@ -1192,26 +1120,26 @@ command, and should be either comp_cmd (default) or check_cmd." (cmd (ada-xref-get-project-field field)) (process-environment (ada-set-environment)) (compilation-scroll-output t)) - + (setq compilation-search-path (ada-xref-get-src-dir-field)) (unless cmd (setq cmd '("") arg t)) - + ;; Make a single command from the list of commands, including the ;; commands to run it on a remote machine. (setq cmd (ada-remote (mapconcat 'identity cmd ada-command-separator))) - + ;; If no project file was found, ask the user (if (or ada-xref-confirm-compile arg) (setq cmd (read-from-minibuffer "enter command to compile: " cmd))) ;; Insert newlines so as to separate the name of the commands to run - ;; and the output of the commands. this doesn't work with cmdproxy.exe, + ;; and the output of the commands. This doesn't work with cmdproxy.exe, ;; which gets confused by newline characters. - (if (not (string-match "cmdproxy.exe" shell-file-name)) + (if (not (string-match ".exe" shell-file-name)) (setq cmd (concat cmd "\n\n"))) - + (compile (ada-quote-cmd cmd)))) (defun ada-check-current (&optional arg) @@ -1222,7 +1150,7 @@ If ARG is not nil, ask for user confirmation of the command." (defun ada-run-application (&optional arg) "Run the application. -if ARG is not-nil, asks for user confirmation." +if ARG is not-nil, ask for user confirmation." (interactive) (ada-require-project-file) @@ -1239,7 +1167,7 @@ if ARG is not-nil, asks for user confirmation." ;; Modify the command to run remotely (setq command (ada-remote (mapconcat 'identity command ada-command-separator))) - + ;; Ask for the arguments to the command if required (if (or ada-xref-confirm-compile arg) (setq command (read-from-minibuffer "Enter command to execute: " @@ -1297,7 +1225,7 @@ If ARG is non-nil, ask the user to confirm the command." ;; We make sure that gvd swallows the new frame, not the one the ;; user has been using until now ;; The frame is made invisible initially, so that GtkPlug gets a - ;; chance to fully manage it. Then it works fine with Enlightenment + ;; chance to fully manage it. Then it works fine with Enlightenment ;; as well (let ((frame (make-frame '((visibility . nil))))) (set 'cmd (concat @@ -1313,11 +1241,10 @@ If ARG is non-nil, ask the user to confirm the command." (if (or arg ada-xref-confirm-compile) (set 'cmd (read-from-minibuffer "enter command to debug: " cmd))) - (let (comint-exec - in-post-mode - gud-gdb-massage-args) + (let ((old-comint-exec (symbol-function 'comint-exec))) ;; Do not add -fullname, since we can have a 'rsh' command in front. + ;; FIXME: This is evil but luckily a nop under Emacs-21.3.50 ! -stef (fset 'gud-gdb-massage-args (lambda (file args) args)) (set 'pre-cmd (mapconcat 'identity pre-cmd ada-command-separator)) @@ -1326,11 +1253,13 @@ If ARG is non-nil, ask the user to confirm the command." (set 'post-cmd (mapconcat 'identity post-cmd "\n")) (if post-cmd - (set 'post-cmd (concat post-cmd "\n"))) + (set 'post-cmd (concat post-cmd "\n"))) + ;; Temporarily replaces the definition of `comint-exec' so that we ;; can execute commands before running gdb. - (fset 'comint-exec + ;; FIXME: This is evil and not temporary !!! -stef + (fset 'comint-exec `(lambda (buffer name command startfile switches) (let (compilation-buffer-name-function) (save-excursion @@ -1347,12 +1276,17 @@ If ARG is non-nil, ask the user to confirm the command." ada-tight-gvd-integration (not (string-match "--tty" cmd))) (setq cmd (concat cmd "--tty"))) - + (if (and (string-match "jdb" (comint-arguments cmd 0 0)) (boundp 'jdb)) (funcall (symbol-function 'jdb) cmd) (gdb cmd)) + ;; Restore the standard fset command (or for instance C-U M-x shell + ;; wouldn't work anymore + + (fset 'comint-exec old-comint-exec) + ;; Send post-commands to the debugger (process-send-string (get-buffer-process (current-buffer)) post-cmd) @@ -1361,7 +1295,7 @@ If ARG is non-nil, ask the user to confirm the command." (end-of-buffer) ;; Display both the source window and the debugger window (the former - ;; above the latter). No need to show the debugger window unless it + ;; above the latter). No need to show the debugger window unless it ;; is going to have some relevant information. (if (or (not (string-match "gvd" (comint-arguments cmd 0 0))) (string-match "--tty" cmd)) @@ -1383,7 +1317,7 @@ automatically modifies the setup for all the Ada buffer that use this file." ;; Reread the location of the standard runtime library (ada-initialize-runtime-library - (or (ada-xref-get-project-field 'cross-prefix) "")) + (or (ada-xref-get-project-field 'cross_prefix) "")) ) ;; ------ Private routines @@ -1392,17 +1326,17 @@ automatically modifies the setup for all the Ada buffer that use this file." "Update the cross-references for FILE. This in fact recompiles FILE to create ALI-FILE-NAME. This function returns the name of the file that was recompiled to generate -the cross-reference information. Note that the ali file can then be deduced by -replacing the file extension with .ali" +the cross-reference information. Note that the ali file can then be deduced by +replacing the file extension with `.ali'." ;; kill old buffer (if (and ali-file-name (get-file-buffer ali-file-name)) (kill-buffer (get-file-buffer ali-file-name))) - + (let* ((name (ada-convert-file-name file)) (body-name (or (ada-get-body-name name) name))) - ;; Always recompile the body when we can. We thus temporarily switch to a + ;; Always recompile the body when we can. We thus temporarily switch to a ;; buffer than contains the body of the unit (save-excursion (let ((body-visible (find-buffer-visiting body-name)) @@ -1411,7 +1345,7 @@ replacing the file extension with .ali" (set-buffer body-visible) (find-file body-name)) - ;; Execute the compilation. Note that we must wait for the end of the + ;; Execute the compilation. Note that we must wait for the end of the ;; process, or the ALI file would still not be available. ;; Unfortunately, the underlying `compile' command that we use is ;; asynchronous. @@ -1434,20 +1368,20 @@ replacing the file extension with .ali" (while (and (not found) dir-list) (set 'found (concat (file-name-as-directory (car dir-list)) (file-name-nondirectory file))) - + (unless (file-exists-p found) (set 'found nil)) (set 'dir-list (cdr dir-list))) found)) (defun ada-find-ali-file-in-dir (file) - "Find an .ali file in obj_dir. The current buffer must be the Ada file. + "Find an .ali file in obj_dir. The current buffer must be the Ada file. Adds build_dir in front of the search path to conform to gnatmake's behavior, and the standard runtime location at the end." (ada-find-file-in-dir file (ada-xref-get-obj-dir-field))) (defun ada-find-src-file-in-dir (file) - "Find a source file in src_dir. The current buffer must be the Ada file. + "Find a source file in src_dir. The current buffer must be the Ada file. Adds src_dir in front of the search path to conform to gnatmake's behavior, and the standard runtime location at the end." (ada-find-file-in-dir file (ada-xref-get-src-dir-field))) @@ -1464,7 +1398,7 @@ the project file." ;; and look for this file ;; 2- If this file is found: ;; grep the "^U" lines, and make sure we are not reading the - ;; .ali file for a spec file. If we are, go to step 3. + ;; .ali file for a spec file. If we are, go to step 3. ;; 3- If the file is not found or step 2 failed: ;; find the name of the "other file", ie the body, and look ;; for its associated .ali file by subtituing the extension @@ -1472,9 +1406,9 @@ the project file." ;; We must also handle the case of separate packages and subprograms: ;; 4- If no ali file was found, we try to modify the file name by removing ;; everything after the last '-' or '.' character, so as to get the - ;; ali file for the parent unit. If we found an ali file, we check that + ;; ali file for the parent unit. If we found an ali file, we check that ;; it indeed contains the definition for the separate entity by checking - ;; the 'D' lines. This is done repeatedly, in case the direct parent is + ;; the 'D' lines. This is done repeatedly, in case the direct parent is ;; also a separate. (save-excursion @@ -1487,7 +1421,7 @@ the project file." ;; If we have a non-standard file name, and this is a spec, we first ;; look for the .ali file of the body, since this is the one that - ;; contains the most complete information. If not found, we will do what + ;; contains the most complete information. If not found, we will do what ;; we can with the .ali file for the spec... (if (not (string= (file-name-extension file) "ads")) @@ -1505,14 +1439,14 @@ the project file." (file-name-nondirectory (ada-other-file-name))) ".ali")))) - + (setq ali-file-name (or ali-file-name - + ;; Else we take the .ali file associated with the unit (ada-find-ali-file-in-dir short-ali-file-name) - + ;; else we did not find the .ali file Second chance: in case ;; the files do not have standard names (such as for instance @@ -1523,35 +1457,35 @@ the project file." (file-name-nondirectory (ada-other-file-name))) ".ali")) - + ;; If we still don't have an ali file, try to get the one ;; from the parent unit, in case we have a separate entity. (let ((parent-name (file-name-sans-extension (file-name-nondirectory file)))) - + (while (and (not ali-file-name) (string-match "^\\(.*\\)[.-][^.-]*" parent-name)) - + (set 'parent-name (match-string 1 parent-name)) (set 'ali-file-name (ada-find-ali-file-in-dir (concat parent-name ".ali"))) ) ali-file-name))) - + ;; If still not found, try to recompile the file (if (not ali-file-name) - ;; recompile only if the user asked for this. and search the ali - ;; filename again. We avoid a possible infinite recursion by + ;; Recompile only if the user asked for this, and search the ali + ;; filename again. We avoid a possible infinite recursion by ;; temporarily disabling the automatic compilation. - + (if ada-xref-create-ali (setq ali-file-name (concat (file-name-sans-extension (ada-xref-current file)) ".ali")) - (error "Ali file not found. Recompile your file")) - - + (error "`.ali' file not found; recompile your source file")) + + ;; same if the .ali file is too old and we must recompile it (if (and (file-newer-than-file-p file ali-file-name) ada-xref-create-ali) @@ -1563,7 +1497,7 @@ the project file." (defun ada-get-ada-file-name (file original-file) "Create the complete file name (+directory) for FILE. -The original file (where the user was) is ORIGINAL-FILE. Search in project +The original file (where the user was) is ORIGINAL-FILE. Search in project file for possible paths." (save-excursion @@ -1575,7 +1509,7 @@ file for possible paths." (set-buffer buffer) (find-file original-file) (ada-require-project-file))) - + ;; we choose the first possible completion and we ;; return the absolute file name (let ((filename (ada-find-src-file-in-dir file))) @@ -1583,7 +1517,7 @@ file for possible paths." (expand-file-name filename) (error (concat (file-name-nondirectory file) - " not found in src_dir. Please check your project file"))) + " not found in src_dir; please check your project file"))) ))) @@ -1605,7 +1539,7 @@ macros `ada-name-of', `ada-line-of', `ada-column-of', `ada-file-of',..." ;; If at end of buffer (e.g the buffer is empty), error (if (>= (point) (point-max)) (error "No identifier on point")) - + ;; goto first character of the identifier/operator (skip backward < and > ;; since they are part of multiple character operators (goto-char pos) @@ -1642,12 +1576,12 @@ macros `ada-name-of', `ada-line-of', `ada-column-of', `ada-file-of',..." (if (looking-at "[a-zA-Z0-9_]+") (set 'identifier (match-string 0)) (error "No identifier around"))) - + ;; Build the identlist (set 'identlist (ada-make-identlist)) (ada-set-name identlist (downcase identifier)) (ada-set-line identlist - (number-to-string (count-lines (point-min) (point)))) + (number-to-string (count-lines 1 (point)))) (ada-set-column identlist (number-to-string (1+ (current-column)))) (ada-set-file identlist (buffer-file-name)) @@ -1657,7 +1591,7 @@ macros `ada-name-of', `ada-line-of', `ada-column-of', `ada-file-of',..." (defun ada-get-all-references (identlist) "Completes and returns IDENTLIST with the information extracted from the ali file (definition file and places where it is referenced)." - + (let ((ali-buffer (ada-get-ali-buffer (ada-file-of identlist))) declaration-found) (set-buffer ali-buffer) @@ -1667,7 +1601,7 @@ from the ali file (definition file and places where it is referenced)." ;; First attempt: we might already be on the declaration of the identifier ;; We want to look for the declaration only in a definite interval (after ;; the "^X ..." line for the current file, and before the next "^X" line - + (if (re-search-forward (concat "^X [0-9]+ " (file-name-nondirectory (ada-file-of identlist))) nil t) @@ -1677,7 +1611,7 @@ from the ali file (definition file and places where it is referenced)." (concat "^" (ada-line-of identlist) "." (ada-column-of identlist) "[ *]" (ada-name-of identlist) - " \\(.*\\)$") bound t)) + "[{\(<= ]?\\(.*\\)$") bound t)) (if declaration-found (ada-set-on-declaration identlist t)) )) @@ -1686,7 +1620,7 @@ from the ali file (definition file and places where it is referenced)." ;; have to fall back on other algorithms (unless declaration-found - + ;; Since we alread know the number of the file, search for a direct ;; reference to it (goto-char (point-min)) @@ -1696,10 +1630,10 @@ from the ali file (definition file and places where it is referenced)." (number-to-string (ada-find-file-number-in-ali (ada-file-of identlist)))) (unless (re-search-forward (concat (ada-ali-index-of identlist) - "|\\([0-9]+.[0-9]+ \\)*" + "|\\([0-9]+[^0-9][0-9]+\\(\n\\.\\)? \\)*" (ada-line-of identlist) - "[^0-9]" - (ada-column-of identlist)) + "[^etpzkd<>=^]" + (ada-column-of identlist) "\\>") nil t) ;; if we did not find it, it may be because the first reference @@ -1707,12 +1641,14 @@ from the ali file (definition file and places where it is referenced)." ;; Or maybe we are already on the declaration... (unless (re-search-forward (concat - "^\\(\\([a-zA-Z0-9_.]+\\|\"[<>=+*-/a-z]\"\\)[ *]\\)*" + "^[0-9]+.[0-9]+[ *]" + (ada-name-of identlist) + "[ <{=\(]\\(.\\|\n\\.\\)*\\<" (ada-line-of identlist) "[^0-9]" - (ada-column-of identlist)) + (ada-column-of identlist) "\\>") nil t) - + ;; If still not found, then either the declaration is unknown ;; or the source file has been modified since the ali file was ;; created @@ -1729,17 +1665,17 @@ from the ali file (definition file and places where it is referenced)." (while (looking-at "^\\.") (previous-line 1)) (unless (looking-at (concat "[0-9]+.[0-9]+[ *]" - (ada-name-of identlist) "[ <]")) + (ada-name-of identlist) "[ <{=\(]")) (set 'declaration-found nil)))) ;; Still no success ! The ali file must be too old, and we need to - ;; use a basic algorithm based on guesses. Note that this only happens + ;; use a basic algorithm based on guesses. Note that this only happens ;; if the user does not want us to automatically recompile files ;; automatically (unless declaration-found (if (ada-xref-find-in-modified-ali identlist) (set 'declaration-found t) - ;; no more idea to find the declaration. Give up + ;; No more idea to find the declaration. Give up (progn (kill-buffer ali-buffer) (error (concat "No declaration of " (ada-name-of identlist) @@ -1747,7 +1683,7 @@ from the ali file (definition file and places where it is referenced)." ))) ) - + ;; Now that we have found a suitable line in the .ali file, get the ;; information available (beginning-of-line) @@ -1770,13 +1706,13 @@ from the ali file (definition file and places where it is referenced)." identlist (ada-get-ada-file-name (match-string 1) (ada-file-of identlist))) - + ;; Else clean up the ali file (error (kill-buffer ali-buffer) (error (error-message-string err))) )) - + (ada-set-references identlist current-line) )) )) @@ -1802,7 +1738,7 @@ This function is disabled for operators, and only works for identifiers." (goto-char (point-max)) (while (re-search-backward my-regexp nil t) (save-excursion - (set 'line-ali (count-lines (point-min) (point))) + (set 'line-ali (count-lines 1 (point))) (beginning-of-line) ;; have a look at the line and column numbers (if (looking-at "^\\([0-9]+\\).\\([0-9]+\\)[ *]") @@ -1829,16 +1765,16 @@ This function is disabled for operators, and only works for identifiers." (error (concat "No declaration of " (ada-name-of identlist) " recorded in .ali file"))) - + ;; one => should be the right one ((= len 1) (goto-line (caar declist))) - + ;; more than one => display choice list (t (save-window-excursion (with-output-to-temp-buffer "*choice list*" - + (princ "Identifier is overloaded and Xref information is not up to date.\n") (princ "Possible declarations are:\n\n") (princ " no. in file at line col\n") @@ -1893,13 +1829,14 @@ opens a new window to show the declaration." (set 'locations (list (list (match-string 1 ali-line) ;; line (match-string 2 ali-line) ;; column (ada-declare-file-of identlist)))) - (while (string-match "\\([0-9]+\\)[bc]\\([0-9]+\\)" ali-line start) + (while (string-match "\\([0-9]+\\)[bc]\\(<[^>]+>\\)?\\([0-9]+\\)" + ali-line start) (setq line (match-string 1 ali-line) - col (match-string 2 ali-line) - start (match-end 2)) + col (match-string 3 ali-line) + start (match-end 3)) ;; it there was a file number in the same line - (if (string-match (concat "\\([0-9]+\\)|\\([^|bc]+\\)?" + (if (string-match (concat "[^{(<]\\([0-9]+\\)|\\([^|bc]+\\)?" (match-string 0 ali-line)) ali-line) (let ((file-number (match-string 1 ali-line))) @@ -1910,7 +1847,7 @@ opens a new window to show the declaration." ) ;; Else get the nearest file (set 'file (ada-declare-file-of identlist))) - + (set 'locations (append locations (list (list line col file))))) ;; Add the specs at the end again, so that from the last body we go to @@ -1923,7 +1860,7 @@ opens a new window to show the declaration." (setq line (caar locations) col (nth 1 (car locations)) file (nth 2 (car locations))) - + (while locations (if (and (string= (caar locations) (ada-line-of identlist)) (string= (nth 1 (car locations)) (ada-column-of identlist)) @@ -1962,27 +1899,27 @@ This command requires the external `egrep' program to be available. This works well when one is using an external librarie and wants to find the declaration and documentation of the subprograms one is is using." - + (let (list (dirs (ada-xref-get-obj-dir-field)) (regexp (concat "[ *]" (ada-name-of identlist))) line column choice file) - + (save-excursion - - ;; Do the grep in all the directories. We do multiple shell + + ;; Do the grep in all the directories. We do multiple shell ;; commands instead of one in case there is no .ali file in one ;; of the directory and the shell stops because of that. - + (set-buffer (get-buffer-create "*grep*")) (while dirs (insert (shell-command-to-string (concat "egrep -i -h '^X|" regexp "( |$)' " (file-name-as-directory (car dirs)) "*.ali"))) (set 'dirs (cdr dirs))) - + ;; Now parse the output (set 'case-fold-search t) (goto-char (point-min)) @@ -1996,23 +1933,23 @@ is using." column (match-string 2)) (re-search-backward "^X [0-9]+ \\(.*\\)$") (set 'file (list (match-string 1) line column)) - + ;; There could be duplicate choices, because of the structure ;; of the .ali files (unless (member file list) (set 'list (append list (list file)))))))) - + ;; Current buffer is still "*grep*" (kill-buffer "*grep*") ) - + ;; Now display the list of possible matches (cond - + ;; No choice found => Error ((null list) (error "No cross-reference found, please recompile your file")) - + ;; Only one choice => Do the cross-reference ((= (length list) 1) (set 'file (ada-find-src-file-in-dir (caar list))) @@ -2025,12 +1962,12 @@ is using." (error (concat (caar list) " not found in src_dir"))) (message "This is only a (good) guess at the cross-reference.") ) - + ;; Else, ask the user (t (save-window-excursion (with-output-to-temp-buffer "*choice list*" - + (princ "Identifier is overloaded and Xref information is not up to date.\n") (princ "Possible declarations are:\n\n") (princ " no. in file at line col\n") @@ -2072,7 +2009,7 @@ is using." (file line column identlist &optional other-frame) "Select and display FILE, at LINE and COLUMN. If we do not end on the same identifier as IDENTLIST, find the closest -match. Kills the .ali buffer at the end. +match. Kills the .ali buffer at the end. If OTHER-FRAME is non-nil, creates a new frame to show the file." (let (declaration-buffer) @@ -2231,7 +2168,7 @@ This function typically is to be hooked into `ff-file-created-hooks'." (progn (set-buffer-modified-p nil) (kill-buffer (current-buffer)))) - + ;; Make sure the current buffer is the spec (this might not be the case ;; if for instance the user was asked for a project file) @@ -2239,7 +2176,7 @@ This function typically is to be hooked into `ff-file-created-hooks'." (unless (buffer-file-name (car (buffer-list))) (set-buffer (cadr (buffer-list)))) - ;; Make sure we have a project file (for parameters to gnatstub). Note that + ;; Make sure we have a project file (for parameters to gnatstub). Note that ;; this might have already been done if we have been called from the hook, ;; but this is not an expensive call) (ada-require-project-file) @@ -2287,17 +2224,13 @@ This function typically is to be hooked into `ff-file-created-hooks'." "Function called by `ada-mode-hook' to initialize the ada-xref.el package. For instance, it creates the gnat-specific menus, sets some hooks for find-file...." - (make-local-hook 'ff-file-created-hooks) ;; This should really be an `add-hook'. -stef - (setq ff-file-created-hooks 'ada-make-body-gnatstub) - - ;; 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) + (setq ff-file-created-hook 'ada-make-body-gnatstub) ;; Completion for file names in the mini buffer should ignore .ali files (add-to-list 'completion-ignored-extensions ".ali") + + (ada-xref-update-project-menu) ) @@ -2305,9 +2238,9 @@ find-file...." ;; Use gvd or ddd as the default debugger if it was found ;; On windows, do not use the --tty switch for GVD, since this is -;; not supported. Actually, we do not use this on Unix either, since otherwise -;; there is no console window left in GVD, and people have to use the -;; Emacs one. +;; not supported. Actually, we do not use this on Unix either, +;; since otherwise there is no console window left in GVD, +;; and people have to use the Emacs one. ;; This must be done before initializing the Ada menu. (if (ada-find-file-in-dir "gvd" exec-path) (set 'ada-prj-default-debugger "gvd ") @@ -2316,29 +2249,17 @@ find-file...." (if (ada-find-file-in-dir "ddd" exec-path) (set 'ada-prj-default-debugger "ddd --tty -fullname -toolbar")))) -;; Set the keymap once and for all, so that the keys set by the user in his -;; config file are not overwritten every time we open a new file. -(ada-add-ada-menu) -(ada-add-keymap) - (add-hook 'ada-mode-hook 'ada-xref-initialize) ;; Initializes the cross references to the runtime library (ada-initialize-runtime-library "") ;; Add these standard directories to the search path -(set 'ada-search-directories +(set 'ada-search-directories-internal (append (mapcar 'directory-file-name ada-xref-runtime-library-specs-path) ada-search-directories)) -;; Make sure that the files are always associated with a project file. Since -;; the project file has some fields that are used for the editor (like the -;; casing exceptions), it has to be read before the user edits a file). -(add-hook 'ada-mode-hook - (lambda() - (let ((file (ada-prj-find-prj-file t))) - (if file (ada-reread-prj-file file))))) - (provide 'ada-xref) +;;; arch-tag: 415a39fe-577b-4676-b3b1-6ff6db7ca24e ;;; ada-xref.el ends here