Mercurial > emacs
changeset 25899:e5e3310746eb
New file. Use Gnat for lookup and completion in Ada mode
| author | Gerd Moellmann <gerd@gnu.org> |
|---|---|
| date | Thu, 07 Oct 1999 14:25:59 +0000 |
| parents | a39db912a76f |
| children | f14be0689a02 |
| files | lisp/progmodes/ada-xref.el |
| diffstat | 1 files changed, 1766 insertions(+), 0 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/progmodes/ada-xref.el Thu Oct 07 14:25:59 1999 +0000 @@ -0,0 +1,1766 @@ +;; @(#) ada-xref.el --- use Gnat for lookup and completion in Ada mode + +;; Copyright (C) 1994-1999 Free Software Foundation, Inc. + +;; Author: Markus Heritsch <Markus.Heritsch@studbox.uni-stuttgart.de> +;; Rolf Ebert <ebert@inf.enst.fr> +;; Emmanuel Briot <briot@gnat.com> +;; Maintainer: Emmanuel Briot <briot@gnat.com> +;; Ada Core Technologies's version: $Revision: 1.75 $ +;; Keywords: languages ada xref + +;; This file is not part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Commentary: +;;; This Package provides a set of functions to use the output of the +;;; cross reference capabilities of the GNAT Ada compiler +;;; for lookup and completion in Ada mode. +;;; +;;; The functions provided are the following ones : +;;; - `ada-complete-identifier': completes the current identifier as much as +;;; possible, depending of the known identifier in the unit +;;; - `ada-point-and-xref': moves the mouse pointer and shows the declaration +;;; of the selected identifier (either in the same buffer or in another +;;; buffer +;;; - `ada-goto-declaration': shows the declaration of the selected +;;; identifier (the one under the cursor), either in the same buffer or in +;;; another buffer +;;; - `ada-goto-declaration-other-frame': same as previous, but opens a new +;; frame to show the declaration +;;; - `ada-compile-application': recompile your whole application, provided +;;; that a project file exists in your directory +;;; - `ada-run-application': run your application directly from emacs +;;; - `ada-reread-prj-file': force emacs to read your project file again. +;;; Otherwise, this file is only read the first time emacs needs some +;;; informations, which are then kept in memory +;;; - `ada-change-prj': change the prj file associated with a buffer +;;; - `ada-change-default-prj': change the default project file used for +;;; every new buffer +;;; +;;; If a file *.`adp' exists in the ada-file directory, then it is +;;; 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 + +;; ----- Requirements ----------------------------------------------------- + +(require 'compile) +(require 'comint) + +;; ----- Dynamic byte compilation ----------------------------------------- +(defvar byte-compile-dynamic nil) +(make-local-variable 'byte-compile-dynamic) +(setq byte-compile-dynamic t) + +;; ------ Use variables +(defcustom ada-xref-other-buffer t + "*if non-nil then either use a buffer in the same frame or another frame. +If Nil, always jump to the declaration in the same buffer" + :type 'boolean :group 'ada) + +(defcustom ada-xref-create-ali t + "*if non-nil, run gcc whenever it is needed +if nil, the cross-reference mode will never run gcc" + :type 'boolean :group 'ada) + +(defcustom ada-xref-confirm-compile nil + "*if non-nil, ask for command confirmation before compiling or +running the application" + :type 'boolean :group 'ada) + +(defcustom ada-krunch-args "0" + "*Maximum number of characters for filename create by gnatkr +Set to 0, if you don't use crunched filenames." + :type 'string :group 'ada) + +(defcustom ada-prj-default-comp-cmd "${cross_prefix}gcc -c -g -gnatq ${comp_opt} -I${src_dir}" + "*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 syntax as in the project file." + :type 'string :group 'ada) + +(defcustom ada-prj-default-make-cmd + (concat "${cross_prefix}gnatmake ${main} -aI${src_dir} -aO${obj_dir} " + "-g -gnatq -cargs ${comp_opt} " + "-bargs ${bind_opt} -largs ${link_opt}") + "*Default command to be used to compile the application. +This is the same syntax as in the project file." + :type 'string :group 'ada) + +(defcustom ada-prj-default-project-file "" + "*Non nil means always use this project file, no matter what the +directory is. Emacs will not try to use the standard algorithm to +find the project file. +Note: you can use M-<TAB> in the customization buffer for completion" + :type '(file :must-match t) :group 'ada) + +(defcustom ada-gnatstub-opts "-q -I${src_dir}" + "*List of the options to pass to gnatsub when generating the body from +a spec file. This has the same syntax as in the project file (with +variable substitution" + :type 'string :group 'ada) + +(defcustom ada-always-ask-project nil + "*Non-nil means ask for the name of a project file to use when none is +found by the standard algorithm. +Nil means use default values when no project file was found") + +;; ------- Nothing to be modified by the user below this +(defvar ada-last-prj-file "" + "Name of the last project file entered by the user, when the +default algorithm did not find any possible project file") + +(defvar ada-check-switch " -gnats " + "Switch added to the command line to check the current file") + +(defvar ada-project-file-extension ".adp" + "The extension used for project files") + +(defconst is-windows (memq system-type (quote (windows-nt))) + "true if we are running on windows NT or windows 95") + +(defvar ada-xref-pos-ring '() + "This is the list of all the positions we went to with the +cross-references features. This is used to go back to these positions.") + +(defconst ada-xref-pos-ring-max 16 + "Number of positions kept in the list ada-xref-pos-ring") + +(defvar ada-operator-re + "\\+\\|-\\|/\\|\\*\\|=\\|mod\\|and\\|not\\|or\\|xor\\|<=\\|<\\|>=\\|>" + "Regexp to match for operators") + +(defvar ada-xref-default-prj-file nil + "name of the default prj file, per directory. +Every directory is potentially associated with a default project file +If it is nil, then the first prj file loaded will be the default for this +emacs session") + +;; These variables will be overwritted by buffer-local variables +(defvar ada-prj-prj-file nil + "Name of the project file for the current ada buffer") +(defvar ada-prj-src-dir nil + "List of directories to look into for ada sources") +(defvar ada-prj-obj-dir nil + "List of directories to look into for object and .ali files") +(defvar ada-prj-comp-opt nil + "Switches to use on the command line for the default compile +command (gcc)") +(defvar ada-prj-bind-opt nil + "Switches to use on the command line for the default bind +command (gnatbind)") +(defvar ada-prj-link-opt nil + "Switches to use on the command line for the default link +command (gnatlink)") +(defvar ada-prj-comp-cmd nil + "Command to use to compile the current file only") +(defvar ada-prj-make-cmd nil + "Command to use to compile the whole current application") +(defvar ada-prj-run-cmd nil + "Command to use to run the current application") +(defvar ada-prj-debug-cmd nil + "Command to use to run the debugger") +(defvar ada-prj-main nil + "Name of the main programm of the current application") +(defvar ada-prj-remote-machine nil + "Name of the machine to log on before a compilation") +(defvar ada-prj-cross-prefix nil + "Prefix to be added to the gnatmake, gcc, ... commands when +using a cross-compilation environment. +A '-' is automatically added at the end if not already present. +For instance, the compiler is called `ada-prj-cross-prefix'gnatmake") + +;; ----- 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 [f10] 'next-error) + (define-key ada-mode-map "\C-c\C-c" 'ada-compile-application) + (define-key ada-mode-map "\C-cb" 'ada-buffer-list) + (define-key ada-mode-map "\C-cc" 'ada-change-prj) + (define-key ada-mode-map "\C-cd" 'ada-change-default-prj) + (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) + ) + +;; ----- Menus -------------------------------------------------------------- +(defun ada-add-ada-menu () + "Add some items to the standard Ada mode menu (the menu defined in +ada-mode.el)" + (interactive) + + (if ada-xemacs + (progn + (add-menu-button '("Ada") ["Check file" ada-check-current t] "Goto") + (add-menu-button '("Ada") ["Compile file" ada-compile-current t] "Goto") + (add-menu-button '("Ada") ["Build" ada-compile-application t] "Goto") + (add-menu-button '("Ada") ["Run" ada-run-application t] "Goto") + (add-menu-button '("Ada") ["Debug" ada-gdb-application t] "Goto") + (add-menu-button '("Ada") ["--" nil t] "Goto") + (add-submenu '("Ada") '("Project" + ["Associate" ada-change-prj t] + ["Set Default" ada-set-default-project-file t] + ["List" ada-buffer-list t]) + "Goto") + (add-menu-button '("Ada" "Goto") ["Goto Parent Unit" ada-goto-parent t] + "Next compilation error") + (add-menu-button '("Ada" "Goto") ["Goto References to any entity" ada-find-any-references t] + "Next compilation error") + (add-menu-button '("Ada" "Goto") ["List References" ada-find-references t] + "Next compilation error") + (add-menu-button '("Ada" "Goto") ["Goto Declaration Other Frame" + ada-goto-declaration-other-frame t] + "Next compilation error") + (add-menu-button '("Ada" "Goto") ["Goto Declaration/Body" ada-goto-declaration t] + "Next compilation error") + (add-menu-button '("Ada" "Goto") ["Goto Previous Reference" ada-xref-goto-previous-reference t] + "Next compilation error") + (add-menu-button '("Ada" "Goto") ["--" nil t] + "Next compilation error") + (add-menu-button '("Ada" "Edit") ["Complete Identifier" ada-complete-identifier t] + "Indent Line") + (add-menu-button '("Ada" "Edit") ["--------" nil t] + "Indent Line") + (add-menu-button '("Ada" "Help") ["Gnat User Guide" (info "gnat_ug")]) + (add-menu-button '("Ada" "Help") ["Gnat Reference Manual" + (info "gnat_rm")]) + (add-menu-button '("Ada" "Help") ["Gcc Documentation" (info "gcc")]) + (add-menu-button '("Ada" "Help") ["Gdb Documentation" (info "gdb")]) + ) + + ;; for Emacs + (define-key-after (lookup-key ada-mode-map [menu-bar Ada]) [Check] + '("Check file" . ada-check-current) 'Customize) + (define-key-after (lookup-key ada-mode-map [menu-bar Ada]) [Compile] + '("Compile file" . ada-compile-current) 'Check) + (define-key-after (lookup-key ada-mode-map [menu-bar Ada]) [Build] + '("Build" . ada-compile-application) 'Compile) + (define-key-after (lookup-key ada-mode-map [menu-bar Ada]) [Run] + '("Run" . ada-run-application) 'Build) + (define-key-after (lookup-key ada-mode-map [menu-bar Ada]) [Debug] + '("Debug" . ada-gdb-application) 'Run) + (define-key-after (lookup-key ada-mode-map [menu-bar Ada]) [rem] + '("--" . nil) 'Debug) + (define-key-after (lookup-key ada-mode-map [menu-bar Ada]) [Project] + (cons "Project" (easy-menu-create-menu + "Project" + '(["Associate" ada-change-prj t] + ["Set Default" ada-set-default-project-file t] + ["List" ada-buffer-list t]))) + 'rem) + + (let ((help-submenu (lookup-key ada-mode-map [menu-bar Ada Help])) + (goto-submenu (lookup-key ada-mode-map [menu-bar Ada Goto])) + (edit-submenu (lookup-key ada-mode-map [menu-bar Ada Edit]))) + + (define-key help-submenu [Gnat_ug] + '("Gnat User Guide" . (lambda() (interactive) (info "gnat_ug")))) + (define-key help-submenu [Gnat_rm] + '("Gnat Reference Manual" . (lambda() (interactive) (info "gnat_rm")))) + (define-key help-submenu [Gcc] + '("Gcc Documentation" . (lambda() (interactive) (info "gcc")))) + (define-key help-submenu [gdb] + '("Ada Aware Gdb Documentation" . (lambda() (interactive) (info "gdb")))) + (define-key goto-submenu [rem] '("----" . nil)) + (define-key goto-submenu [Parent] '("Goto Parent Unit" . ada-goto-parent)) + (define-key goto-submenu [References-any] + '("Goto References to any entity" . ada-find-any-references)) + (define-key goto-submenu [References] + '("List References" . ada-find-references)) + (define-key goto-submenu [Prev] + '("Goto Previous Reference" . ada-xref-goto-previous-reference)) + (define-key goto-submenu [Decl-other] + '("Goto Declaration Other Frame" . ada-goto-declaration-other-frame)) + (define-key goto-submenu [Decl] + '("Goto Declaration/Body" . ada-goto-declaration)) + + (define-key edit-submenu [rem] '("----" . nil)) + (define-key edit-submenu [Complete] '("Complete Identifier" + . ada-complete-identifier)) + ) + )) + +;; ----- Utilities ------------------------------------------------- + +(defun ada-require-project-file () + "If no project file is assigned to this buffer, load one" + (if (not ( my-local-variable-if-set-p 'ada-prj-src-dir (current-buffer))) + (ada-parse-prj-file (ada-prj-find-prj-file)))) + +(defun my-local-variable-if-set-p (variable &optional buffer) + (and (local-variable-p variable buffer) + (save-excursion + (set-buffer buffer) + (symbol-value variable)))) + +(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)) + (if (> (length ada-xref-pos-ring) ada-xref-pos-ring-max) + (setcdr (nthcdr (1- ada-xref-pos-ring-max) ada-xref-pos-ring) nil))) + +(defun ada-xref-goto-previous-reference () + "Go to the previous cross-reference we were on" + (interactive) + (if ada-xref-pos-ring + (progn + (let ((pos (car ada-xref-pos-ring))) + (setq ada-xref-pos-ring (cdr ada-xref-pos-ring)) + (find-file (car (cdr pos))) + (goto-char (car pos)))))) + +(defun ada-convert-file-name (name) + "Function to convert from the buffer file name to the name given in +argument to the ada-compile-current function. This function is +overridden on VMS to convert from VMS filename to Unix filenames" + name) + +(defun ada-set-default-project-file (name) + (interactive "fName of project file:") + (set 'ada-prj-default-project-file name) + (ada-reread-prj-file t) + ) + +;; ------ Handling the project file ----------------------------- + +(defun ada-replace-substring (cmd-string search-for replace-with) + "Replace all instances of SEARCH-FOR with REPLACE-WITH in +string CMD-STRING" + (while (string-match search-for cmd-string) + (setq cmd-string (replace-match replace-with t t cmd-string))) + cmd-string) + +(defun ada-treat-cmd-string (cmd-string) + "Replace meta-sequences like ${...} with the appropriate value in CMD-STRING. +The current buffer must be the one where all local variable are definied (that +is the ada source)" + + (if ( my-local-variable-if-set-p 'ada-prj-src-dir (current-buffer)) + (if (string-match "\\(-[^-\$I]*I\\)\${src_dir}" cmd-string) + (progn + (let ((str-def (substring cmd-string (match-beginning 1) + (match-end 1)))) + (setq cmd-string + (ada-replace-substring cmd-string + "\\(-[^-\$I]*I\\)\${src_dir}" + (mapconcat + (lambda (x) (concat str-def x)) + ada-prj-src-dir " "))))))) + (if ( my-local-variable-if-set-p 'ada-prj-obj-dir (current-buffer)) + (if (string-match "\\(-[^-\$O]*O\\)\${obj_dir}" cmd-string) + (progn + (let ((str-def (substring cmd-string (match-beginning 1) + (match-end 1)))) + (setq cmd-string + (ada-replace-substring cmd-string + "\\(-[^-\$O]*O\\)\${obj_dir}" + (mapconcat + (lambda (x) (concat str-def x)) + ada-prj-obj-dir + " "))))))) + (if ( my-local-variable-if-set-p 'ada-prj-remote-machine (current-buffer)) + (setq cmd-string + (ada-replace-substring cmd-string "\${remote_machine}" + ada-prj-remote-machine))) + (if ( my-local-variable-if-set-p 'ada-prj-comp-opt (current-buffer)) + (setq cmd-string + (ada-replace-substring cmd-string "\${comp_opt}" + ada-prj-comp-opt))) + (if ( my-local-variable-if-set-p 'ada-prj-bind-opt (current-buffer)) + (setq cmd-string + (ada-replace-substring cmd-string "\${bind_opt}" + ada-prj-bind-opt))) + (if ( my-local-variable-if-set-p 'ada-prj-link-opt (current-buffer)) + (setq cmd-string + (ada-replace-substring cmd-string "\${link_opt}" + ada-prj-link-opt))) + (if ( my-local-variable-if-set-p 'ada-prj-main (current-buffer)) + (setq cmd-string + (ada-replace-substring cmd-string "\${main}" + ada-prj-main))) + (if ( my-local-variable-if-set-p 'ada-prj-cross-prefix (current-buffer)) + (setq cmd-string + (ada-replace-substring cmd-string "\${cross_prefix}" + ada-prj-cross-prefix))) + cmd-string) + + +(defun ada-prj-find-prj-file (&optional no-user-question) + "Find the prj file associated with the current buffer +The rules are the following ones : +- If the buffer is already associated with a prj file, use this one +- else if there's a default prj file for the same directory use it +- else if a prj file with the same filename exists, use it +- else if there's only one prj file in the directory, use it +- else if there are more than one prj file, ask the user +- else if there is no prj file and no-user-question is nil, ask the user + for the project file to use." + (let* ((current-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) + (prj-files (directory-files + dir t + (concat ".*" (regexp-quote ada-project-file-extension) "$"))) + (choice nil) + (default (assoc dir ada-xref-default-prj-file)) + ) + + (cond + + ((my-local-variable-if-set-p 'ada-prj-prj-file (current-buffer)) + ada-prj-prj-file) + + (default ;; directory default project file + (cdr default)) + + ;; global default project file + ((and ada-prj-default-project-file + (not (string= ada-prj-default-project-file ""))) + ada-prj-default-project-file) + + ((file-exists-p first-choice) + first-choice) + + ((= (length prj-files) 1) + (car prj-files)) + + ((> (length prj-files) 1) + ;; more than one possible prj file => ask the user + (with-output-to-temp-buffer "*choice list*" + (princ "There are more than one possible project file. Which one should\n") + (princ "I use ?\n\n") + (princ " no. file name \n") + (princ " --- ------------------------\n") + (let ((counter 1)) + (while (<= counter (length prj-files)) + (princ (format " %2d) %s\n" + counter + (nth (1- counter) prj-files))) + (setq counter (1+ counter)) + ) ; end of while + ) ; end of let + ) ; end of with-output-to ... + (setq choice nil) + (while (or + (not choice) + (not (integerp choice)) + (< choice 1) + (> choice (length prj-files))) + (setq choice (string-to-int + (read-from-minibuffer "Enter No. of your choice: " + )))) + (nth (1- choice) prj-files)) + + ((= (length prj-files) 0) + ;; no project file found. Ask the user about it (the default value + ;; is the last one the user entered. + (if (or no-user-question (not ada-always-ask-project)) + nil + (setq ada-last-prj-file + (read-file-name "project file:" nil ada-last-prj-file)) + (if (string= ada-last-prj-file "") nil ada-last-prj-file)) + ) + ))) + + +(defun ada-parse-prj-file (prj-file) + "Reads and parses the PRJ-FILE file if it was found. +The current buffer should be the ada-file buffer" + + (let ((tmp-src-dir nil) + (tmp-obj-dir nil) + (tmp-comp-opt nil) + (tmp-bind-opt nil) + (tmp-link-opt nil) + (tmp-main nil) + (tmp-comp-cmd nil) + (tmp-make-cmd nil) + (tmp-run-cmd nil) + (tmp-debug-cmd nil) + (tmp-remote-machine nil) + (tmp-cross-prefix nil) + (tmp-cd-cmd (if prj-file + (concat "cd " (file-name-directory prj-file) " && ") + (concat "cd " (file-name-directory (buffer-file-name (current-buffer))) " && "))) + (ada-buffer (current-buffer)) + ) + ;; tries to find a project file in the current directory + (if prj-file + (progn + (find-file prj-file) + + ;; first look for the src_dir lines + (widen) + (goto-char (point-min)) + (while + (re-search-forward "^src_dir=\\(.*\\)" nil t) + (progn + (setq tmp-src-dir (cons + (file-name-as-directory + (match-string 1)) + tmp-src-dir + )))) + ;; then for the obj_dir lines + (goto-char (point-min)) + (while (re-search-forward "^obj_dir=\\(.*\\)" nil t) + (setq tmp-obj-dir (cons + (file-name-as-directory + (match-string 1)) + tmp-obj-dir + ))) + + ;; then for the options lines + (goto-char (point-min)) + (if (re-search-forward "^comp_opt=\\(.*\\)" nil t) + (setq tmp-comp-opt (match-string 1))) + (goto-char (point-min)) + (if (re-search-forward "^bind_opt=\\(.*\\)" nil t) + (setq tmp-bind-opt (match-string 1))) + (goto-char (point-min)) + (if (re-search-forward "^link_opt=\\(.*\\)" nil t) + (setq tmp-link-opt (match-string 1))) + (goto-char (point-min)) + (if (re-search-forward "^main=\\(.*\\)" nil t) + (setq tmp-main (match-string 1))) + (goto-char (point-min)) + (if (re-search-forward "^comp_cmd=\\(.*\\)" nil t) + (setq tmp-comp-cmd (match-string 1))) + (goto-char (point-min)) + (if (re-search-forward "^remote_machine=\\(.*\\)" nil t) + (setq tmp-remote-machine (match-string 1))) + (goto-char (point-min)) + (if (re-search-forward "^cross_prefix=\\(.*\\)" nil t) + (setq tmp-cross-prefix (match-string 1))) + (goto-char (point-min)) + (if (re-search-forward "^make_cmd=\\(.*\\)" nil t) + (setq tmp-make-cmd (match-string 1))) + (goto-char (point-min)) + (if (re-search-forward "^run_cmd=\\(.*\\)" nil t) + (setq tmp-run-cmd (match-string 1))) + (goto-char (point-min)) + (if (re-search-forward "^debug_cmd=\\(.*\\)" nil t) + (setq tmp-debug-cmd (match-string 1))) + + ;; kills the project file buffer, and go back to the ada buffer + (kill-buffer nil) + (set-buffer ada-buffer) + )) + + ;; creates local variables (with default values if needed) + (set (make-local-variable 'ada-prj-prj-file) prj-file) + + (set (make-local-variable 'ada-prj-src-dir) + (if tmp-src-dir (reverse tmp-src-dir) '("./"))) + + (set (make-local-variable 'ada-prj-obj-dir) + (if tmp-obj-dir (reverse tmp-obj-dir) '("./"))) + + (set (make-local-variable 'ada-prj-comp-opt) + (if tmp-comp-opt tmp-comp-opt "")) + + (set (make-local-variable 'ada-prj-bind-opt) + (if tmp-bind-opt tmp-bind-opt "")) + + (set (make-local-variable 'ada-prj-link-opt) + (if tmp-link-opt tmp-link-opt "")) + + (set (make-local-variable 'ada-prj-cross-prefix) + (if tmp-cross-prefix + (if (or (string= tmp-cross-prefix "") + (= (aref tmp-cross-prefix (1- (length tmp-cross-prefix))) ?-)) + tmp-cross-prefix + (concat tmp-cross-prefix "-")) + "")) + + (set (make-local-variable 'ada-prj-main) + (if tmp-main tmp-main + (substring (buffer-file-name) 0 -4))) + + (set (make-local-variable 'ada-prj-remote-machine) + (ada-treat-cmd-string + (if tmp-remote-machine tmp-remote-machine ""))) + + (set (make-local-variable 'ada-prj-comp-cmd) + (ada-treat-cmd-string + (if tmp-comp-cmd tmp-comp-cmd + (concat tmp-cd-cmd ada-prj-default-comp-cmd)))) + + (set (make-local-variable 'ada-prj-make-cmd) + (ada-treat-cmd-string + (if tmp-make-cmd tmp-make-cmd + (concat tmp-cd-cmd ada-prj-default-make-cmd)))) + + (set (make-local-variable 'ada-prj-run-cmd) + (ada-treat-cmd-string + (if tmp-run-cmd tmp-run-cmd + (if is-windows "${main}.exe" "${main}")))) + + (set (make-local-variable 'ada-prj-debug-cmd) + (ada-treat-cmd-string + (if tmp-debug-cmd tmp-debug-cmd + (if is-windows + "${cross_prefix}gdb ${main}.exe" + "${cross_prefix}gdb ${main}")))) + + ;; Add each directory in src_dir to the default prj list + (if prj-file + (mapcar (lambda (x) + (if (not (assoc (expand-file-name x) + ada-xref-default-prj-file)) + (setq ada-xref-default-prj-file + (cons (cons (expand-file-name x) + prj-file) + ada-xref-default-prj-file)))) + ada-prj-src-dir)) + + ;; Add the directories to the search path for ff-find-other-file + ;; Do not add the '/' or '\' at the end + (set (make-local-variable 'ff-search-directories) + (append (mapcar 'directory-file-name ada-prj-src-dir) + ada-search-directories)) + + ;; 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-prj-src-dir) + + )) + + +(defun ada-find-references (&optional pos) + "Find every references to the entity under POS +Calls gnatfind to find every references" + (interactive "") + (unless pos + (set 'pos (point))) + (ada-require-project-file) + + (let* ((identlist (ada-read-identifier pos)) + (alifile (ada-get-ali-file-name (ada-file-of identlist)))) + + (set-buffer (get-file-buffer (ada-file-of identlist))) + + ;; if the file is more recent than the executable + (if (or (buffer-modified-p (current-buffer)) + (file-newer-than-file-p (ada-file-of identlist) alifile)) + (ada-find-any-references (ada-name-of identlist) + (ada-file-of identlist) + nil nil) + (ada-find-any-references (ada-name-of identlist) + (ada-file-of identlist) + (ada-line-of identlist) + (ada-column-of identlist)))) + ) + +(defun ada-find-any-references (entity &optional file line column) + "Search for references to any entity" + (interactive "sEntity name: ") + (ada-require-project-file) + + (let* ((command (concat "gnatfind -rf " entity + (if file (concat ":" (file-name-nondirectory file))) + (if line (concat ":" line)) + (if column (concat ":" column))))) + + ;; If a project file is defined, use it + (if (my-local-variable-if-set-p 'ada-prj-prj-file (current-buffer)) + (setq command (concat command " -p" ada-prj-prj-file))) + + (compile-internal command + "No more references" + "gnatfind") + + ;; Hide the "Compilation" menu + (save-excursion + (set-buffer "*gnatfind*") + (local-unset-key [menu-bar compilation-menu])) + ) + ) + +(defun ada-buffer-list () + "Display a buffer with all the ada-mode buffers and their associated prj file" + (interactive) + (save-excursion + (set-buffer (get-buffer-create "*Buffer List*")) + (setq buffer-read-only nil) + (erase-buffer) + (setq standard-output (current-buffer)) + (princ "The following line is a list showing the associations between +directories and project file. It has the format : ((directory_1 . project_file1) +(directory2 . project_file2)...)\n\n") + (princ ada-xref-default-prj-file) + (princ "\n + Buffer Mode Project file + ------ ---- ------------ +\n") + (let ((bl (buffer-list))) + (while bl + (let* ((buffer (car bl)) + (buffer-name (buffer-name buffer)) + this-buffer-mode-name + this-buffer-project-file) + (save-excursion + (set-buffer buffer) + (setq this-buffer-mode-name + (if (eq buffer standard-output) + "Buffer Menu" mode-name)) + (if (string= this-buffer-mode-name + "Ada") + (setq this-buffer-project-file + (if ( my-local-variable-if-set-p 'ada-prj-prj-file + (current-buffer)) + (expand-file-name ada-prj-prj-file) + "")))) + (if (string= this-buffer-mode-name + "Ada") + (progn + (princ (format "%-19s " buffer-name)) + (princ (format "%-6s " this-buffer-mode-name)) + (princ this-buffer-project-file) + (princ "\n") + )) + ) ;; end let* + (setq bl (cdr bl)) + ) ;; end while + );; end let + ) ;; end save-excursion + (display-buffer "*Buffer List*") + (other-window 1) + ) + +(defun ada-change-prj (filename) + "Change the project file associated with the current buffer" + (interactive "fproject file:") + + ;; make sure we are using an Ada file + (if (not (string= mode-name "Ada")) + (error "You must be in ada-mode to use this function")) + + ;; create the local variable if necessay + (if (not ( my-local-variable-if-set-p 'ada-prj-prj-file (current-buffer))) + (make-local-variable 'ada-prj-prj-file)) + + ;; ask the user for the new file name + (setq ada-prj-prj-file filename) + + ;; force emacs to reread the prj file next-time + (ada-reread-prj-file) + ) + +(defun ada-change-default-prj (filename) + "Change the default project file used for all ada files from the +current directory" + (interactive "ffile name:") + (let ((dir (file-name-directory (buffer-file-name))) + (prj (expand-file-name filename))) + + ;; If the directory is already associated with a project file + (if (assoc dir ada-xref-default-prj-file) + + (setcdr (assoc dir ada-xref-default-prj-file) prj) + ;; Else create a new element in the list + (add-to-list 'ada-xref-default-prj-file (list dir prj))) + + ;; Reparse the project file + (ada-parse-prj-file ada-prj-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" + (interactive "d") + (ada-require-project-file) + + ;; Initialize function-local variablesand jump to the .ali buffer + ;; Note that for regexp search is case insensitive too + (let* ((curbuf (current-buffer)) + (identlist (ada-read-identifier pos)) + (sofar (concat "^[0-9]+[a-zA-Z][0-9]+[ *]\\(" + (regexp-quote (ada-name-of identlist)) + "[a-zA-Z0-9_]*\\)")) + (completed nil) + (symalist nil) + (insertpos nil)) + + ;; we are already in the .ali buffer + (goto-char (point-max)) + + ;; build an alist of possible completions + (while (re-search-backward sofar nil t) + (setq symalist (cons (cons (match-string 1) nil) symalist))) + + (setq completed (try-completion "" symalist)) + + ;; kills .ali buffer + (kill-buffer nil) + + ;; deletes the incomplete identifier in the buffer + (set-buffer curbuf) + (looking-at "[a-zA-Z0-9_]+") + (replace-match "") + ;; inserts the completed symbol + (insert completed) + )) + +;; ----- Cross-referencing ---------------------------------------- + +(defun ada-point-and-xref () + "Calls `mouse-set-point' and then `ada-goto-declaration'." + (interactive) + (mouse-set-point last-input-event) + (ada-goto-declaration (point))) + +(defun ada-goto-declaration (pos) + "Displays the declaration of the identifier around POS. +The declaration is shown in another buffer if `ada-xref-other-buffer' is non-nil" + (interactive "d") + (ada-require-project-file) + (push-mark pos) + (ada-xref-push-pos (buffer-file-name) pos) + (ada-find-in-ali (ada-read-identifier pos))) + +(defun ada-goto-declaration-other-frame (pos) + "Displays the declaration of the identifier around point. +The declation is shown in another frame if `ada-xref-other-buffer' is non-nil" + (interactive "d") + (ada-require-project-file) + (push-mark pos) + (ada-xref-push-pos (buffer-file-name) pos) + (ada-find-in-ali (ada-read-identifier pos) t)) + +(defun ada-compile (command) + "Start a compilation, on the machine specified in the project file, +using command COMMAND" + + (if (and (my-local-variable-if-set-p 'ada-prj-remote-machine (current-buffer)) + (not (string= ada-prj-remote-machine ""))) + (set 'command + (concat "rsh " ada-prj-remote-machine " '" + command "'"))) + (compile command)) + +(defun ada-compile-application () + "Compiles the whole application, using the command find in the gnat.prj file" + (interactive) + (ada-require-project-file) + + ;; prompt for command to execute + (ada-compile + (if ada-xref-confirm-compile + (read-from-minibuffer "enter command to compile: " + ada-prj-make-cmd) + ada-prj-make-cmd)) + ) + +(defun ada-compile-current () + "Recompile the current file" + (interactive) + (ada-require-project-file) + + ;; prompt for command to execute + (ada-compile + (if ada-xref-confirm-compile + (read-from-minibuffer "enter command to compile: " + (concat + ada-prj-comp-cmd " " (ada-convert-file-name (buffer-file-name)))) + (concat ada-prj-comp-cmd " " (ada-convert-file-name (buffer-file-name))))) + ) + +(defun ada-check-current () + "Recompile the current file" + (interactive) + (ada-require-project-file) + + ;; prompt for command to execute + (let ((command (concat ada-prj-comp-cmd ada-check-switch + (ada-convert-file-name (buffer-file-name))))) + (compile + (if ada-xref-confirm-compile + (read-from-minibuffer "enter command to compile: " command) + command)))) + + +(defun ada-run-application () + "Run the application" + (interactive) + (ada-require-project-file) + + (if (and (my-local-variable-if-set-p 'ada-prj-cross-prefix (current-buffer)) + (not (string= ada-prj-cross-prefix ""))) + (error "This feature is not supported yet for cross-compilation environments")) + + (let ((command ada-prj-run-cmd) + (buffer (current-buffer))) + ;; Search the command name if necessary + (if (not (my-local-variable-if-set-p 'ada-prj-run-cmd (current-buffer))) + (setq command (file-name-sans-extension (buffer-name))) + ) + + ;; Ask for the arguments to the command + (setq command + (read-from-minibuffer "Enter command to execute: " + command)) + + ;; Run the command + (save-excursion + (set-buffer (get-buffer-create "*run*")) + (goto-char (point-max)) + (insert "\nRunning " command "\n\n") + (make-comint "run" + (comint-arguments command 0 0) + nil + (comint-arguments command 1 nil)) + ) + (display-buffer "*run*") + + ;; change to buffer *run* for interactive programs + (other-window 1) + (switch-to-buffer "*run*") + ) + ) + + +(defun ada-gdb-application () + "Run the application" + (interactive) + + (require 'gud) + (let ((buffer (current-buffer)) + gdb-buffer) + (ada-require-project-file) + + (if (and (my-local-variable-if-set-p 'ada-prj-cross-prefix buffer) + (not (string= ada-prj-cross-prefix ""))) + (error "This feature is not supported yet for cross-compilation environments")) + + ;; If the command to use was given in the project file + (if (my-local-variable-if-set-p 'ada-prj-debug-cmd buffer) + (gdb ada-prj-debug-cmd) + ;; Else the user will have to enter the command himself + (gdb "") + ) + + (set 'gdb-buffer (current-buffer)) + + ;; Switch back to the source buffer + ;; and Activate the debug part in the contextual menu + (switch-to-buffer buffer) + + (if (functionp 'gud-make-debug-menu) + (gud-make-debug-menu)) + + ;; Warning: on Emacs >= 20.3.8, same-window-regexps includes gud-*, + ;; so the following call to display buffer will select the + ;; buffer instead of displaying it in another window + ;; This is why the second argument to display-buffer is 't' + (display-buffer gdb-buffer t) + )) + + +(defun ada-reread-prj-file (&optional for-all-buffer) + "Forces emacs to read the project file again. +Otherwise, this file is only read once, and never read again +If `for-all-buffer' is non-nil, or the function was called with \C-u prefix, +then do this for every opened buffer" + (interactive "P") + (if for-all-buffer + + ;; do this for every buffer + (mapcar (lambda (x) + (save-excursion + (set-buffer x) + ;; if we have the ada-mode and there is a real file + ;; associated with the buffer + (if (and (string= mode-name "Ada") + (buffer-file-name)) + (progn + (kill-local-variable 'ada-prj-src-dir) + (kill-local-variable 'ada-prj-obj-dir) + (ada-parse-prj-file (ada-prj-find-prj-file)))) + )) + (buffer-list)) + + ;; else do this just for the current buffer + (kill-local-variable 'ada-prj-src-dir) + (kill-local-variable 'ada-prj-obj-dir) + (ada-parse-prj-file (ada-prj-find-prj-file))) + ) + +;; ------ Private routines + +(defun ada-xref-current (file &optional ali-file-name) + "Creates a new ali file from the FILE source file, +assuming the ali file will be called ALI-FILE-NAME. +Uses the function `compile' to execute the commands +defined in the project file." + ;; kill old buffer + (if (and ali-file-name + (get-file-buffer ali-file-name)) + (kill-buffer (get-file-buffer ali-file-name))) + ;; prompt for command to execute + (setq compile-command (concat ada-prj-comp-cmd + " " + file)) + (compile + (if ada-xref-confirm-compile + (read-from-minibuffer "enter command to execute gcc: " + compile-command) + compile-command)) + ) + +(defun ada-first-non-nil (list) + "Returns the first non-nil element of the list" + (cond + ((not list) nil) + ((car list) (car list)) + (t (ada-first-non-nil (cdr list))) + )) + + +(defun ada-find-ali-file-in-dir (file) + "Search for FILE in obj_dir +The current buffer must be the Ada file" + (ada-first-non-nil + (mapcar (lambda (x) + (if (file-exists-p (concat (file-name-directory x) + file)) + (concat (file-name-directory x) file) + nil)) + ada-prj-obj-dir)) + ) + +(defun ada-get-ali-file-name (file) + "create the ali file name for the ada-file FILE +The file is searched for in every directory shown in the +obj_dir lines of the project file" + + ;; This function has to handle the special case of non-standard + ;; file names (i.e. not .adb or .ads) + ;; The trick is the following: + ;; 1- replace the extension of the current file with .ali, + ;; 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. + ;; 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 + + (save-excursion + (set-buffer (get-file-buffer file)) + (let ((short-ali-file-name + (concat (file-name-sans-extension (file-name-nondirectory file)) + ".ali")) + (ali-file-name "")) + ;; First step + ;; we take the first possible completion + (setq ali-file-name (ada-find-ali-file-in-dir short-ali-file-name)) + + ;; If we have found the .ali file, but the source file was a spec + ;; with a non-standard name, search the .ali file for the body if any, + ;; since the xref information is more complete in that one + (unless ali-file-name + (if (not (string= (file-name-extension file) ".ads")) + (let ((is-spec nil) + (specs ada-spec-suffixes) + body-ali) + (while specs + (if (string-match (concat (regexp-quote (car specs)) "$") + file) + (set 'is-spec t)) + (set 'specs (cdr specs))) + + (if is-spec + (set 'body-ali + (ada-find-ali-file-in-dir + (concat (file-name-sans-extension + (file-name-nondirectory + (ada-other-file-name))) + ".ali")))) + (if body-ali + (set 'ali-file-name body-ali)))) + + ;; else we did not find the .ali file + ;; Second chance: in case the files do not have standard names (such + ;; as for instance file_s.ada and file_b.ada), try to go to the + ;; other file and look for its ali file + (setq short-ali-file-name + (concat (file-name-sans-extension + (file-name-nondirectory (ada-other-file-name))) + ".ali")) + (setq ali-file-name (ada-find-ali-file-in-dir short-ali-file-name)) + + ;; If still not found, try to recompile the file + (if (not ali-file-name) + (progn + ;; recompile only if the user asked for this + (if ada-xref-create-ali + (ada-xref-current file ali-file-name)) + (error "Ali file not found. Recompile your 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) + (ada-xref-current file ali-file-name)) + + ;; else returns the correct absolute file name + (expand-file-name ali-file-name)) + )) + +(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 file for possible paths" + + (save-excursion + (set-buffer (get-file-buffer original-file)) + ;; we choose the first possible completion and we + ;; return the absolute file name + (let ((filename + (ada-first-non-nil (mapcar (lambda (x) + (if (file-exists-p (concat (file-name-directory x) + (file-name-nondirectory file))) + (concat (file-name-directory x) + (file-name-nondirectory file)) + nil)) + ada-prj-src-dir)))) + + (if filename + (expand-file-name filename) + (error (concat + (file-name-nondirectory file) + " not found in src_dir. Please check your project file"))) + + ))) + +(defun ada-find-file-number-in-ali (file) + "Returns the file number for FILE in the associated ali file" + (set-buffer (ada-get-ali-buffer file)) + (goto-char (point-min)) + + (let ((begin (re-search-forward "^D"))) + (beginning-of-line) + (re-search-forward (concat "^D " (file-name-nondirectory file))) + (count-lines begin (point)))) + +(defun ada-read-identifier (pos) + "Returns the identlist around POS and switch to the .ali buffer" + + ;; If there's a compilation in progress, it's probably because the + ;; .ali file didn't exist. So we should wait... + (if compilation-in-progress + (progn + (message "Compilation in progress. Try again when it is finished") + (set 'quit-flag t))) + + ;; 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) + (skip-chars-backward "a-zA-Z0-9_<>") + + ;; check if it really is an identifier + (if (ada-in-comment-p) + (error "Inside comment")) + + (let (identifier identlist) + ;; Just in front of a string => we could have an operator declaration, + ;; as in "+", "-", .. + (if (= (char-after) ?\") + (forward-char 1)) + + ;; if looking at an operator + (if (looking-at ada-operator-re) + (progn + (if (and (= (char-before) ?\") + (= (char-after (+ (length (match-string 0)) (point))) ?\")) + (forward-char -1)) + (set 'identifier (concat "\"" (match-string 0) "\""))) + + (if (ada-in-string-p) + (error "Inside string or character constant")) + (if (looking-at (concat ada-keywords "[^a-zA-Z_]")) + (error "No cross-reference available for reserved keyword")) + (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)))) + (ada-set-column identlist + (number-to-string (1+ (current-column)))) + (ada-set-file identlist (buffer-file-name)) + identlist + )) + +(defun ada-get-all-references (identlist) + "Completes and returns the 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) + (goto-char (point-min)) + (ada-set-on-declaration identlist nil) + + ;; 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) + (let ((bound (save-excursion (re-search-forward "^X " nil t)))) + (set 'declaration-found + (re-search-forward + (concat "^" (ada-line-of identlist) + "." (ada-column-of identlist) + "[ *]" (regexp-quote (ada-name-of identlist)) + " \\(.*\\)$") bound t)) + (if declaration-found + (ada-set-on-declaration identlist t)) + )) + + ;; If declaration is still nil, then we were not on a declaration, and + ;; 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)) + (set 'declaration-found t) + (ada-set-ali-index + identlist + (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]+ \\)*" + (ada-line-of identlist) + "[^0-9]" + (ada-column-of identlist)) + nil t) + + ;; if we did not find it, it may be because the first reference + ;; is not required to have a 'unit_number|' item included. + ;; Or maybe we are already on the declaration... + (unless (re-search-forward (concat "^\\([a-zA-Z0-9_.\"]+[ *]\\)*" + (ada-line-of identlist) + "[^0-9]" + (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 + (set 'declaration-found nil) + ) + ) + + ;; Last check to be completly sure we have found the correct line (the + ;; ali might not be up to date for instance) + (if declaration-found + (progn + (beginning-of-line) + ;; while we have a continuation line, go up one line + (while (looking-at "^\\.") + (previous-line 1)) + (unless (looking-at (concat "[0-9]+.[0-9]+[ *]" + (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 + ;; if the user does not want us to automatically recompile files + ;; automatically + (unless declaration-found + (unless (ada-xref-find-in-modified-ali identlist) + ;; no more idea to find the declaration. Give up + (progn + (kill-buffer ali-buffer) + (error (concat "No declaration of " (ada-name-of identlist) + " found.")) + ))) + ) + + + ;; Now that we have found a suitable line in the .ali file, get the + ;; information available + (beginning-of-line) + (if declaration-found + (let ((current-line (buffer-substring + (point) (save-excursion (end-of-line) (point))))) + (save-excursion + (next-line 1) + (beginning-of-line) + (while (looking-at "^\\.\\(.*\\)") + (set 'current-line (concat current-line (match-string 1))) + (next-line 1)) + ) + + (if (re-search-backward "^X [0-9]+ \\([a-zA-Z0-9_.-]+\\)" nil t) + (ada-set-declare-file + identlist + (ada-get-ada-file-name (match-string 1) + (ada-file-of identlist)))) + + (ada-set-references identlist current-line) + )) + )) + +(defun ada-xref-find-in-modified-ali (identlist) + "Find the matching position for IDENTLIST in the current ali buffer. +This function is only called when the file was not up-to-date, so we need +to make some guesses. +This function is disabled for operators, and only works for identifiers" + + (unless (= (string-to-char (ada-name-of identlist)) ?\") + (progn + (let ((declist '()) ;;; ( (line_in_ali_file line_in_ada) ( ... )) + (my-regexp (concat "[ *]" + (regexp-quote (ada-name-of identlist)) " ")) + (line-ada "--") + (col-ada "--") + (line-ali 0) + (len 0) + (choice 0)) + + (goto-char (point-max)) + (while (re-search-backward my-regexp nil t) + (save-excursion + (set 'line-ali (count-lines (point-min) (point))) + (beginning-of-line) + ;; have a look at the line and column numbers + (if (looking-at "^\\([0-9]+\\).\\([0-9]+\\)[ *]") + (progn + (setq line-ada (match-string 1)) + (setq col-ada (match-string 2))) + (setq line-ada "--") + (setq col-ada "--") + ) + ;; construct a list with the file names and the positions within + (if (re-search-backward "^X [0-9]+ \\([a-zA-Z0-9._-]+\\)" nil t) + (add-to-list + 'declist (list line-ali (match-string 1) line-ada col-ada)) + ) + ) + ) + + ;; how many possible declarations have we found ? + (setq len (length declist)) + (cond + ;; none => error + ((= len 0) + (kill-buffer (current-buffer)) + (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 + (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") + (princ " --- --------------------- ---- ----\n") + (let ((counter 1)) + (while (<= counter len) + (princ (format " %2d) %-21s %4s %4s\n" + counter + (ada-get-ada-file-name + (nth 1 (nth (1- counter) declist)) + (ada-file-of identlist)) + (nth 2 (nth (1- counter) declist)) + (nth 3 (nth (1- counter) declist)) + )) + (setq counter (1+ counter)) + ) ; end of while + ) ; end of let + ) ; end of with-output-to ... + (setq choice nil) + (while (or + (not choice) + (not (integerp choice)) + (< choice 1) + (> choice len)) + (setq choice (string-to-int + (read-from-minibuffer "Enter No. of your choice: ")))) + (goto-line (car (nth (1- choice) declist))) + )))))) + + +(defun ada-find-in-ali (identlist &optional other-frame) + "Look in the .ali file for the definition of the identifier +if OTHER-FRAME is non nil, and `ada-xref-other-buffer' is non nil, +opens a new window to show the declaration" + + (ada-get-all-references identlist) + (let ((ali-line (ada-references-of identlist)) + file line col) + + ;; If we were on a declaration, go to the body + (if (ada-on-declaration identlist) + (if (string-match "\\([0-9]+\\)[bc]\\([0-9]+\\)" ali-line) + (progn + (setq line (match-string 1 ali-line) + col (match-string 2 ali-line)) + ;; it there was a file number in the same line + (if (string-match "\\([0-9]+\\)|\\([^|bc]+\\)?[bc]" ali-line) + (let ((file-number (match-string 1 ali-line))) + (goto-char (point-min)) + (re-search-forward "^D \\([a-zA-Z0-9_.-]+\\)" nil t + (string-to-number file-number)) + (set 'file (match-string 1)) + ) + ;; Else get the nearest file + (re-search-backward "^X [0-9]+ \\([a-zA-Z0-9_.-]+\\)" nil t) + (set 'file (match-string 1)) + ) + ) + (error "No body found")) + + ;; Else we were not on the declaration, find the place for it + (string-match "\\([0-9]+\\)[a-zA-Z+]\\([0-9]+\\)[ *]" ali-line) + (setq line (match-string 1 ali-line) + col (match-string 2 ali-line) + file (ada-declare-file-of identlist)) + ) + + ;; Now go to the buffer + (ada-xref-change-buffer + (ada-get-ada-file-name file (ada-file-of identlist)) + (string-to-number line) + (1- (string-to-number col)) + identlist + other-frame) + )) + +(defun ada-xref-change-buffer + (file line column identlist &optional other-frame) + "Select and display FILE, at LINE and COLUMN. The new file is +associated with the same project file as the one for IDENTLIST. +If we do not end on the same identifier as IDENTLIST, find the closest +match. Kills the .ali buffer at the end" + + (let (prj-file + declaration-buffer + (ali-buffer (current-buffer))) + + ;; get the current project file for the source ada file + (save-excursion + (set-buffer (get-file-buffer (ada-file-of identlist))) + (set 'prj-file ada-prj-prj-file)) + + ;; Select and display the destination buffer + (if ada-xref-other-buffer + (if other-frame + (find-file-other-frame file) + (set 'declaration-buffer (find-file-noselect file)) + (set-buffer declaration-buffer) + (switch-to-buffer-other-window declaration-buffer) + ) + (find-file file) + ) + + ;; If the new buffer is not already associated with a project file, do it + (unless (my-local-variable-if-set-p 'ada-prj-prj-file (current-buffer)) + (progn + (make-local-variable 'ada-prj-prj-file) + (set 'ada-prj-prj-file prj-file))) + + ;; move the cursor to the correct position + (push-mark) + (goto-line line) + (move-to-column column) + + ;; If we are not on the identifier, the ali file was not up-to-date. + ;; Try to find the nearest position where the identifier is found, + ;; this is probably the right one. + (unless (looking-at (ada-name-of identlist)) + (ada-xref-search-nearest (ada-name-of identlist))) + + (kill-buffer ali-buffer))) + + +(defun ada-xref-search-nearest (name) + "Searches for NAME nearest to the position recorded in the Xref file. +It returns the position of the declaration in the buffer or nil if not found." + (let ((orgpos (point)) + (newpos nil) + (diff nil)) + + (goto-char (point-max)) + + ;; loop - look for all declarations of name in this file + (while (search-backward name nil t) + + ;; check if it really is a complete Ada identifier + (if (and + (not (save-excursion + (goto-char (match-end 0)) + (looking-at "_"))) + (not (ada-in-string-or-comment-p)) + (or + ;; variable declaration ? + (save-excursion + (skip-chars-forward "a-zA-Z_0-9" ) + (ada-goto-next-non-ws) + (looking-at ":[^=]")) + ;; procedure, function, task or package declaration ? + (save-excursion + (ada-goto-previous-word) + (looking-at "\\<[pP][rR][oO][cC][eE][dD][uU][rR][eE]\\>\\|\\<[fF][uU][nN][cC][tT][iI][oO][nN]\\>\\|\\<[tT][yY][pP][eE]\\>\\|\\<[tT][aA][sS][kK]\\>\\|\\<[pP][aA][cC][kK][aA][gG][eE]\\>\\|\\<[bB][oO][dD][yY]\\>")))) + + ;; check if it is nearer than the ones before if any + (if (or (not diff) + (< (abs (- (point) orgpos)) diff)) + (progn + (setq newpos (point) + diff (abs (- newpos orgpos)))))) + ) + + (if newpos + (progn + (message "ATTENTION: this declaration is only a (good) guess ...") + (goto-char newpos)) + nil))) + + +;; Find the parent library file of the current file +(defun ada-goto-parent () + "go to the parent library file" + (interactive) + (ada-require-project-file) + + (let ((buffer (ada-get-ali-buffer (buffer-file-name))) + (unit-name nil) + (body-name nil) + (ali-name nil)) + (save-excursion + (set-buffer buffer) + (goto-char (point-min)) + (re-search-forward "^U \\([^ \t%]+\\)%[bs][ \t]+\\([^ \t]+\\)") + (setq unit-name (match-string 1)) + (if (not (string-match "\\(.*\\)\\.[^.]+" unit-name)) + (progn + (kill-buffer buffer) + (error "No parent unit !")) + (setq unit-name (match-string 1 unit-name)) + ) + + ;; look for the file name for the parent unit specification + (goto-char (point-min)) + (re-search-forward (concat "^W " unit-name + "%s[ \t]+\\([^ \t]+\\)[ \t]+" + "\\([^ \t\n]+\\)")) + (setq body-name (match-string 1)) + (setq ali-name (match-string 2)) + (kill-buffer buffer) + ) + + (setq ali-name (ada-find-ali-file-in-dir ali-name)) + + (save-excursion + ;; Tries to open the new ali file to find the spec file + (if ali-name + (progn + (find-file ali-name) + (goto-char (point-min)) + (re-search-forward (concat "^U " unit-name "%s[ \t]+" + "\\([^ \t]+\\)")) + (setq body-name (match-string 1)) + (kill-buffer (current-buffer)) + ) + ) + ) + + (find-file body-name) + )) + +(defun ada-make-filename-from-adaname (adaname) + "Determine the filename of a package/procedure from its own Ada name." + ;; this is done simply by calling `gnatkr', when we work with GNAT. It + ;; must be a more complex function in other compiler environments. + (let (krunch-buf) + (setq krunch-buf (generate-new-buffer "*gkrunch*")) + (save-excursion + (set-buffer krunch-buf) + ;; send adaname to external process `gnatkr'. + (call-process "gnatkr" nil krunch-buf nil + adaname ada-krunch-args) + ;; fetch output of that process + (setq adaname (buffer-substring + (point-min) + (progn + (goto-char (point-min)) + (end-of-line) + (point)))) + (kill-buffer krunch-buf))) + adaname + ) + + +(defun ada-make-body-gnatstub () + "Create an Ada package body in the current buffer. +This function uses the `gnatstub' program to create the body. +This function typically is to be hooked into `ff-file-created-hooks'." + (interactive) + + (save-some-buffers nil nil) + + (ada-require-project-file) + + (delete-region (point-min) (point-max)) + + ;; Call the external process gnatstub + (let* ((gnatstub-opts (ada-treat-cmd-string ada-gnatstub-opts)) + (filename (buffer-file-name (car (cdr (buffer-list))))) + (output (concat (file-name-sans-extension filename) ".adb")) + (gnatstub-cmd (concat "gnatstub " gnatstub-opts " " filename)) + (buffer (get-buffer-create "*gnatstub*"))) + + (save-excursion + (set-buffer buffer) + (compilation-minor-mode 1) + (erase-buffer) + (insert gnatstub-cmd) + (newline) + ) + ;; call gnatstub to create the body file + (call-process shell-file-name nil buffer nil "-c" gnatstub-cmd) + + (if (save-excursion + (set-buffer buffer) + (goto-char (point-min)) + (search-forward "command not found" nil t)) + (progn + (message "gnatstub was not found -- using the basic algorithm") + (sleep-for 2) + (kill-buffer buffer) + (ada-make-body)) + + ;; Else clean up the output + + ;; Kill the temporary buffer created by find-file + (set-buffer-modified-p nil) + (kill-buffer (current-buffer)) + + (if (file-exists-p output) + (progn + (find-file output) + (kill-buffer buffer)) + + ;; display the error buffer + (display-buffer buffer) + ) + ))) + + +(defun ada-xref-initialize () + "Function called by ada-mode-hook to initialize the ada-xref.el package. +For instance, it creates the gnat-specific menus, set some hooks for +find-file...." + (ada-add-ada-menu) + (make-local-hook 'ff-file-created-hooks) + (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) + + ;; Completion for file names in the mini buffer should ignore .ali files + (add-to-list 'completion-ignored-extensions ".ali") + ) + + +;; ----- Add to ada-mode-hook --------------------------------------------- + +;; 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-keymap) + +(add-hook 'ada-mode-hook 'ada-xref-initialize) + +(provide 'ada-xref) + +;;; ada-xref.el ends here