[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[elpa] externals-release/gpr-query 57365547c8: Add files to gpr-query
|
From: |
Stephen Leake |
|
Subject: |
[elpa] externals-release/gpr-query 57365547c8: Add files to gpr-query |
|
Date: |
Tue, 1 Nov 2022 16:22:31 -0400 (EDT) |
branch: externals-release/gpr-query
commit 57365547c89b97c8e5435d84101e76b5b8a366a0
Author: Stephen Leake <stephen_leake@stephe-leake.org>
Commit: Stephen Leake <stephen_leake@stephe-leake.org>
Add files to gpr-query
---
Alire.make | 9 +
ELPA.make | 86 +++
NEWS | 11 +
README | 23 +
alire.toml | 23 +
build.sh | 46 ++
doclicense.texi | 507 +++++++++++++
emacs_gpr_query.gpr | 100 +++
emacs_gpr_query_config_devel.gpr | 51 ++
emacs_gpr_query_config_release.gpr | 26 +
gnatcoll-2021-sql.diff | 20 +
gpr-query.el | 1106 +++++++++++++++++++++++++++++
gpr-query.prj | 2 +
gpr-query.texi | 212 ++++++
gpr_query.adb | 1380 ++++++++++++++++++++++++++++++++++++
gpr_query.trace | 2 +
install.sh | 27 +
notes.text | 178 +++++
prj-eglot.el | 41 ++
prj.el | 18 +
20 files changed, 3868 insertions(+)
diff --git a/Alire.make b/Alire.make
new file mode 100644
index 0000000000..b002db006e
--- /dev/null
+++ b/Alire.make
@@ -0,0 +1,9 @@
+# For compiling gpr-query Ada code with Alire
+
+STEPHES_ADA_LIBRARY_ALIRE_PREFIX ?= $(CURDIR)/../org.stephe_leake.sal
+
+include $(STEPHES_ADA_LIBRARY_ALIRE_PREFIX)/build/alire_rules.make
+
+# Local Variables:
+# eval: (load-file "prj-eglot.el")
+# End:
diff --git a/ELPA.make b/ELPA.make
new file mode 100644
index 0000000000..9128803062
--- /dev/null
+++ b/ELPA.make
@@ -0,0 +1,86 @@
+# For compiling gpr-query Ada code in elpa or devel worktree
+
+#export Standard_Common_Build := Debug
+
+.PHONY : all force
+
+all : build byte-compile autoloads
+
+docs : gpr-query.info
+
+build : config/emacs_gpr_query_config.gpr force
+ gprbuild -p -j8 emacs_gpr_query.gpr
+
+install : bin/gpr_query$(EXE_EXT)
+ gprinstall -f -p -P emacs_gpr_query.gpr --install-name=gpr_query
+
+ifeq ($(shell uname),Linux)
+EMACS_EXE ?= emacs
+else ifeq ($(shell uname),Darwin)
+EMACS_EXE ?= "/Applications/Emacs.app/Contents/MacOS/Emacs"
+else
+# windows
+# specify uniscribe to workaround weird Windows harfbuzz bug
+EMACS_EXE ?= emacs -xrm Emacs.fontBackend:uniscribe
+endif
+
+BYTE_COMPILE := "(progn (setq byte-compile-error-on-warn
t)(batch-byte-compile))"
+byte-compile : byte-compile-clean
+ $(EMACS_EXE) -Q -batch -L . -L $(GNAT_COMPILER) -L $(WISI) --eval
$(BYTE_COMPILE) *.el
+
+byte-compile-clean :
+ rm -f *.elc
+
+autoloads : force
+ $(EMACS_EXE) -Q -batch --eval "(progn (setq generated-autoload-file
(expand-file-name \"autoloads.el\"))(update-directory-autoloads \".\"))"
+
+%.info : %.texi
+ makeinfo $< -o ../$@
+
+clean : force
+ rm -rf gpr-query.info obj gpr_query$(EXE_EXT)
+
+recursive-clean : force
+ gprclean -r -P emacs_gpr_query.gpr
+
+### publish to elpa package
+ELPA_ROOT ?= $(shell cd ../elpa; pwd -W)
+
+pub : force | $(ELPA_ROOT)/packages/gpr-query
+ rm -rf $(ELPA_ROOT)/packages/gpr-query/*
+ cp *.el *.gpr *.make *.prj *.sh *.texi $(ELPA_ROOT)/packages/gpr-query
+ cp NEWS README $(ELPA_ROOT)/packages/gpr-query
+ cd $(ELPA_ROOT)/packages/gpr-query; rm autoloads.el
+
+# builds $(ELPA_ROOT)/archive-devel/*, from the last commit, _not_ the
+# current workspace Also checks copyright; run elpa/GNUMakefile
+# check/<pkg> first if added files.
+build-elpa : force
+ rm -rf $(ELPA_ROOT)/archive-devel
+ make -C $(ELPA_ROOT)/ build/gpr-query
+
+config/emacs_gpr_query_config.gpr :
+ cp emacs_gpr_query_config_devel.gpr config/emacs_gpr_query_config.gpr
+
+### misc stuff
+BRANCH := $(notdir $(shell cd ..; pwd))
+
+ifeq ($(BRANCH),org.emacs.gpr-query)
+ TAR_FILE := org.emacs.gpr-query-$(GPR_QUERY_VERSION)
+else
+ TAR_FILE := $(BRANCH)
+endif
+
+zip :
+ rm -rf $(TAR_FILE)
+ mtn checkout --branch $(BRANCH) $(TAR_FILE)
+ tar jcf $(TAR_FILE).tar.bz2 --exclude _MTN -C .. $(TAR_FILE)
+
+tag :
+ mtn tag h:org.emacs.gpr-query org.emacs.gpr-query-$(GPR_QUERY_VERSION)
+
+
+# Local Variables:
+# eval: (load-file "prj.el")
+# End:
+# end of file
diff --git a/NEWS b/NEWS
new file mode 100644
index 0000000000..35bf501f41
--- /dev/null
+++ b/NEWS
@@ -0,0 +1,11 @@
+GNU Emacs gpr-query NEWS -- history of user-visible changes.
+
+Copyright (C) 2022 Free Software Foundation, Inc.
+
+Please send gpr-query bug reports to bug-gnu-emacs@gnu.org, with
+'gpr-query' in the subject. If possible, use M-x report-emacs-bug.
+
+
+* gpr-query 1.0.1
+
+** Split out from ada-mode
diff --git a/README b/README
new file mode 100644
index 0000000000..8687544f76
--- /dev/null
+++ b/README
@@ -0,0 +1,23 @@
+Emacs gpr-query version 1.0.1
+
+gpr-query provides an emacs xref backend using the cross-reference
+information output by the AdaCore GNAT compiler.
+
+gpr-query uses a separate executable provided as Ada source code that
+must be compiled and installed, either directly or using the Alire
+package tool:
+
+cd ~/.emacs.d/elpa/gpr-query-i.j.k
+./build.sh
+./install.sh
+
+install.sh can take an option "--prefix=<dir>" to set the installation
+directory.
+
+Both shell scripts use Alire if the 'alr' executable is found in PATH.
+
+See gpr-query.info section Installation for more information on
+installing; if not using Alire, you may need additional packages.
+
+Ada mode will automatically load gpr-query if the gpr_query executable
+is found in PATH; this may be overridden by setting ada-xref-tool.
diff --git a/alire.toml b/alire.toml
new file mode 100644
index 0000000000..f9e1a75412
--- /dev/null
+++ b/alire.toml
@@ -0,0 +1,23 @@
+name = "emacs_gpr_query"
+description = "Emacs xref backend using information output by GNAT compiler."
+tags = ["emacs", "xref"]
+version = "1.0.1"
+licenses = "GPL-3.0-or-later"
+
+authors = ["Stephen Leake"]
+maintainers = ["Stephen Leake <stephen_leake@stephe-leake.org>"]
+maintainers-logins = ["stephe-ada-guru"]
+
+website = "https://elpa.gnu.org/packages/gpr-query.html";
+
+project-files = ["emacs_gpr_query.gpr"]
+
+executables = ["gpr_query"]
+
+[[depends-on]]
+gnatcoll = "^22.0.0"
+gnatcoll_sqlite = "^22.0.0"
+gnatcoll_xref = "^22.0.0"
+
+# We use Ada 2022 syntax, so need the -gnat2022 switch; introduced in gnat FSF
11, Community 2021.
+gnat = ">=11 & <2000"
diff --git a/build.sh b/build.sh
new file mode 100644
index 0000000000..2c70e6607a
--- /dev/null
+++ b/build.sh
@@ -0,0 +1,46 @@
+#!/bin/sh
+# Build the gpr_query executable.
+# build.sh options when not using Alire; <other gprbuild options>
+# e.g. 'build.sh -j0' : use all available processors to compile
+# 'build.sh -wn' : treat warnings as warnings.
+# 'build.sh -vh' : Verbose output (high verbosity)
+#
+# See install.sh for install
+
+if type alr; then
+ # alr can be installed from https://alire.ada.dev/
+ echo "building gpr_query via Alire"
+ alr get emacs_gpr_query~1.0.1
+ cd emacs_gpr_query_*; alr build --release
+
+elif type gprbuild; then
+ echo "building gpr_query via gnat compiler"
+
+ # As of gnat pro 21, gnat_util is no longer provided or required
+ echo 'with "gnat_util"; abstract project check is end check;' > check.gpr
+ gprbuild -P check.gpr > /dev/null 2>&1
+ if test $? -eq 0 ; then
+ HAVE_GNAT_UTIL=yes
+ else
+ HAVE_GNAT_UTIL=no
+ fi
+
+ echo "gnatprep " $args
+ gnatprep $args
+
+ mkdir -p config
+ cp emacs_gpr_query_config_release.gpr config/emacs_gpr_query_config.gpr
+
+ # Allow running build.sh again, since it often fails the first time.
+ # - Run gprclean, to allow changing compilers and other drastic things
+
+ gprclean -r -P emacs_gpr_query.gpr
+
+ gprbuild -p -j8 -P emacs_gpr_query.gpr "$@"
+
+else
+ echo "neither Alire nor gnat compiler found"
+ exit 1
+fi
+
+# end of file
diff --git a/doclicense.texi b/doclicense.texi
new file mode 100644
index 0000000000..a511ffcd5a
--- /dev/null
+++ b/doclicense.texi
@@ -0,0 +1,507 @@
+@c -*-texinfo-*-
+@c The GNU Free Documentation License.
+@center Version 1.3, 3 November 2008
+
+@c This file is intended to be included within another document,
+@c hence no sectioning command or @node.
+
+@display
+Copyright @copyright{} 2000, 2001, 2002, 2007, 2008, 2009 Free Software
Foundation, Inc.
+@uref{http://fsf.org/}
+
+Everyone is permitted to copy and distribute verbatim copies
+of this license document, but changing it is not allowed.
+@end display
+
+@enumerate 0
+@item
+PREAMBLE
+
+The purpose of this License is to make a manual, textbook, or other
+functional and useful document @dfn{free} in the sense of freedom: to
+assure everyone the effective freedom to copy and redistribute it,
+with or without modifying it, either commercially or noncommercially.
+Secondarily, this License preserves for the author and publisher a way
+to get credit for their work, while not being considered responsible
+for modifications made by others.
+
+This License is a kind of ``copyleft'', which means that derivative
+works of the document must themselves be free in the same sense. It
+complements the GNU General Public License, which is a copyleft
+license designed for free software.
+
+We have designed this License in order to use it for manuals for free
+software, because free software needs free documentation: a free
+program should come with manuals providing the same freedoms that the
+software does. But this License is not limited to software manuals;
+it can be used for any textual work, regardless of subject matter or
+whether it is published as a printed book. We recommend this License
+principally for works whose purpose is instruction or reference.
+
+@item
+APPLICABILITY AND DEFINITIONS
+
+This License applies to any manual or other work, in any medium, that
+contains a notice placed by the copyright holder saying it can be
+distributed under the terms of this License. Such a notice grants a
+world-wide, royalty-free license, unlimited in duration, to use that
+work under the conditions stated herein. The ``Document'', below,
+refers to any such manual or work. Any member of the public is a
+licensee, and is addressed as ``you''. You accept the license if you
+copy, modify or distribute the work in a way requiring permission
+under copyright law.
+
+A ``Modified Version'' of the Document means any work containing the
+Document or a portion of it, either copied verbatim, or with
+modifications and/or translated into another language.
+
+A ``Secondary Section'' is a named appendix or a front-matter section
+of the Document that deals exclusively with the relationship of the
+publishers or authors of the Document to the Document's overall
+subject (or to related matters) and contains nothing that could fall
+directly within that overall subject. (Thus, if the Document is in
+part a textbook of mathematics, a Secondary Section may not explain
+any mathematics.) The relationship could be a matter of historical
+connection with the subject or with related matters, or of legal,
+commercial, philosophical, ethical or political position regarding
+them.
+
+The ``Invariant Sections'' are certain Secondary Sections whose titles
+are designated, as being those of Invariant Sections, in the notice
+that says that the Document is released under this License. If a
+section does not fit the above definition of Secondary then it is not
+allowed to be designated as Invariant. The Document may contain zero
+Invariant Sections. If the Document does not identify any Invariant
+Sections then there are none.
+
+The ``Cover Texts'' are certain short passages of text that are listed,
+as Front-Cover Texts or Back-Cover Texts, in the notice that says that
+the Document is released under this License. A Front-Cover Text may
+be at most 5 words, and a Back-Cover Text may be at most 25 words.
+
+A ``Transparent'' copy of the Document means a machine-readable copy,
+represented in a format whose specification is available to the
+general public, that is suitable for revising the document
+straightforwardly with generic text editors or (for images composed of
+pixels) generic paint programs or (for drawings) some widely available
+drawing editor, and that is suitable for input to text formatters or
+for automatic translation to a variety of formats suitable for input
+to text formatters. A copy made in an otherwise Transparent file
+format whose markup, or absence of markup, has been arranged to thwart
+or discourage subsequent modification by readers is not Transparent.
+An image format is not Transparent if used for any substantial amount
+of text. A copy that is not ``Transparent'' is called ``Opaque''.
+
+Examples of suitable formats for Transparent copies include plain
+@sc{ascii} without markup, Texinfo input format, La@TeX{} input
+format, @acronym{SGML} or @acronym{XML} using a publicly available
+@acronym{DTD}, and standard-conforming simple @acronym{HTML},
+PostScript or @acronym{PDF} designed for human modification. Examples
+of transparent image formats include @acronym{PNG}, @acronym{XCF} and
+@acronym{JPG}. Opaque formats include proprietary formats that can be
+read and edited only by proprietary word processors, @acronym{SGML} or
+@acronym{XML} for which the @acronym{DTD} and/or processing tools are
+not generally available, and the machine-generated @acronym{HTML},
+PostScript or @acronym{PDF} produced by some word processors for
+output purposes only.
+
+The ``Title Page'' means, for a printed book, the title page itself,
+plus such following pages as are needed to hold, legibly, the material
+this License requires to appear in the title page. For works in
+formats which do not have any title page as such, ``Title Page'' means
+the text near the most prominent appearance of the work's title,
+preceding the beginning of the body of the text.
+
+The ``publisher'' means any person or entity that distributes copies
+of the Document to the public.
+
+A section ``Entitled XYZ'' means a named subunit of the Document whose
+title either is precisely XYZ or contains XYZ in parentheses following
+text that translates XYZ in another language. (Here XYZ stands for a
+specific section name mentioned below, such as ``Acknowledgements'',
+``Dedications'', ``Endorsements'', or ``History''.) To ``Preserve the Title''
+of such a section when you modify the Document means that it remains a
+section ``Entitled XYZ'' according to this definition.
+
+The Document may include Warranty Disclaimers next to the notice which
+states that this License applies to the Document. These Warranty
+Disclaimers are considered to be included by reference in this
+License, but only as regards disclaiming warranties: any other
+implication that these Warranty Disclaimers may have is void and has
+no effect on the meaning of this License.
+
+@item
+VERBATIM COPYING
+
+You may copy and distribute the Document in any medium, either
+commercially or noncommercially, provided that this License, the
+copyright notices, and the license notice saying this License applies
+to the Document are reproduced in all copies, and that you add no other
+conditions whatsoever to those of this License. You may not use
+technical measures to obstruct or control the reading or further
+copying of the copies you make or distribute. However, you may accept
+compensation in exchange for copies. If you distribute a large enough
+number of copies you must also follow the conditions in section 3.
+
+You may also lend copies, under the same conditions stated above, and
+you may publicly display copies.
+
+@item
+COPYING IN QUANTITY
+
+If you publish printed copies (or copies in media that commonly have
+printed covers) of the Document, numbering more than 100, and the
+Document's license notice requires Cover Texts, you must enclose the
+copies in covers that carry, clearly and legibly, all these Cover
+Texts: Front-Cover Texts on the front cover, and Back-Cover Texts on
+the back cover. Both covers must also clearly and legibly identify
+you as the publisher of these copies. The front cover must present
+the full title with all words of the title equally prominent and
+visible. You may add other material on the covers in addition.
+Copying with changes limited to the covers, as long as they preserve
+the title of the Document and satisfy these conditions, can be treated
+as verbatim copying in other respects.
+
+If the required texts for either cover are too voluminous to fit
+legibly, you should put the first ones listed (as many as fit
+reasonably) on the actual cover, and continue the rest onto adjacent
+pages.
+
+If you publish or distribute Opaque copies of the Document numbering
+more than 100, you must either include a machine-readable Transparent
+copy along with each Opaque copy, or state in or with each Opaque copy
+a computer-network location from which the general network-using
+public has access to download using public-standard network protocols
+a complete Transparent copy of the Document, free of added material.
+If you use the latter option, you must take reasonably prudent steps,
+when you begin distribution of Opaque copies in quantity, to ensure
+that this Transparent copy will remain thus accessible at the stated
+location until at least one year after the last time you distribute an
+Opaque copy (directly or through your agents or retailers) of that
+edition to the public.
+
+It is requested, but not required, that you contact the authors of the
+Document well before redistributing any large number of copies, to give
+them a chance to provide you with an updated version of the Document.
+
+@item
+MODIFICATIONS
+
+You may copy and distribute a Modified Version of the Document under
+the conditions of sections 2 and 3 above, provided that you release
+the Modified Version under precisely this License, with the Modified
+Version filling the role of the Document, thus licensing distribution
+and modification of the Modified Version to whoever possesses a copy
+of it. In addition, you must do these things in the Modified Version:
+
+@enumerate A
+@item
+Use in the Title Page (and on the covers, if any) a title distinct
+from that of the Document, and from those of previous versions
+(which should, if there were any, be listed in the History section
+of the Document). You may use the same title as a previous version
+if the original publisher of that version gives permission.
+
+@item
+List on the Title Page, as authors, one or more persons or entities
+responsible for authorship of the modifications in the Modified
+Version, together with at least five of the principal authors of the
+Document (all of its principal authors, if it has fewer than five),
+unless they release you from this requirement.
+
+@item
+State on the Title page the name of the publisher of the
+Modified Version, as the publisher.
+
+@item
+Preserve all the copyright notices of the Document.
+
+@item
+Add an appropriate copyright notice for your modifications
+adjacent to the other copyright notices.
+
+@item
+Include, immediately after the copyright notices, a license notice
+giving the public permission to use the Modified Version under the
+terms of this License, in the form shown in the Addendum below.
+
+@item
+Preserve in that license notice the full lists of Invariant Sections
+and required Cover Texts given in the Document's license notice.
+
+@item
+Include an unaltered copy of this License.
+
+@item
+Preserve the section Entitled ``History'', Preserve its Title, and add
+to it an item stating at least the title, year, new authors, and
+publisher of the Modified Version as given on the Title Page. If
+there is no section Entitled ``History'' in the Document, create one
+stating the title, year, authors, and publisher of the Document as
+given on its Title Page, then add an item describing the Modified
+Version as stated in the previous sentence.
+
+@item
+Preserve the network location, if any, given in the Document for
+public access to a Transparent copy of the Document, and likewise
+the network locations given in the Document for previous versions
+it was based on. These may be placed in the ``History'' section.
+You may omit a network location for a work that was published at
+least four years before the Document itself, or if the original
+publisher of the version it refers to gives permission.
+
+@item
+For any section Entitled ``Acknowledgements'' or ``Dedications'', Preserve
+the Title of the section, and preserve in the section all the
+substance and tone of each of the contributor acknowledgements and/or
+dedications given therein.
+
+@item
+Preserve all the Invariant Sections of the Document,
+unaltered in their text and in their titles. Section numbers
+or the equivalent are not considered part of the section titles.
+
+@item
+Delete any section Entitled ``Endorsements''. Such a section
+may not be included in the Modified Version.
+
+@item
+Do not retitle any existing section to be Entitled ``Endorsements'' or
+to conflict in title with any Invariant Section.
+
+@item
+Preserve any Warranty Disclaimers.
+@end enumerate
+
+If the Modified Version includes new front-matter sections or
+appendices that qualify as Secondary Sections and contain no material
+copied from the Document, you may at your option designate some or all
+of these sections as invariant. To do this, add their titles to the
+list of Invariant Sections in the Modified Version's license notice.
+These titles must be distinct from any other section titles.
+
+You may add a section Entitled ``Endorsements'', provided it contains
+nothing but endorsements of your Modified Version by various
+parties---for example, statements of peer review or that the text has
+been approved by an organization as the authoritative definition of a
+standard.
+
+You may add a passage of up to five words as a Front-Cover Text, and a
+passage of up to 25 words as a Back-Cover Text, to the end of the list
+of Cover Texts in the Modified Version. Only one passage of
+Front-Cover Text and one of Back-Cover Text may be added by (or
+through arrangements made by) any one entity. If the Document already
+includes a cover text for the same cover, previously added by you or
+by arrangement made by the same entity you are acting on behalf of,
+you may not add another; but you may replace the old one, on explicit
+permission from the previous publisher that added the old one.
+
+The author(s) and publisher(s) of the Document do not by this License
+give permission to use their names for publicity for or to assert or
+imply endorsement of any Modified Version.
+
+@item
+COMBINING DOCUMENTS
+
+You may combine the Document with other documents released under this
+License, under the terms defined in section 4 above for modified
+versions, provided that you include in the combination all of the
+Invariant Sections of all of the original documents, unmodified, and
+list them all as Invariant Sections of your combined work in its
+license notice, and that you preserve all their Warranty Disclaimers.
+
+The combined work need only contain one copy of this License, and
+multiple identical Invariant Sections may be replaced with a single
+copy. If there are multiple Invariant Sections with the same name but
+different contents, make the title of each such section unique by
+adding at the end of it, in parentheses, the name of the original
+author or publisher of that section if known, or else a unique number.
+Make the same adjustment to the section titles in the list of
+Invariant Sections in the license notice of the combined work.
+
+In the combination, you must combine any sections Entitled ``History''
+in the various original documents, forming one section Entitled
+``History''; likewise combine any sections Entitled ``Acknowledgements'',
+and any sections Entitled ``Dedications''. You must delete all
+sections Entitled ``Endorsements.''
+
+@item
+COLLECTIONS OF DOCUMENTS
+
+You may make a collection consisting of the Document and other documents
+released under this License, and replace the individual copies of this
+License in the various documents with a single copy that is included in
+the collection, provided that you follow the rules of this License for
+verbatim copying of each of the documents in all other respects.
+
+You may extract a single document from such a collection, and distribute
+it individually under this License, provided you insert a copy of this
+License into the extracted document, and follow this License in all
+other respects regarding verbatim copying of that document.
+
+@item
+AGGREGATION WITH INDEPENDENT WORKS
+
+A compilation of the Document or its derivatives with other separate
+and independent documents or works, in or on a volume of a storage or
+distribution medium, is called an ``aggregate'' if the copyright
+resulting from the compilation is not used to limit the legal rights
+of the compilation's users beyond what the individual works permit.
+When the Document is included in an aggregate, this License does not
+apply to the other works in the aggregate which are not themselves
+derivative works of the Document.
+
+If the Cover Text requirement of section 3 is applicable to these
+copies of the Document, then if the Document is less than one half of
+the entire aggregate, the Document's Cover Texts may be placed on
+covers that bracket the Document within the aggregate, or the
+electronic equivalent of covers if the Document is in electronic form.
+Otherwise they must appear on printed covers that bracket the whole
+aggregate.
+
+@item
+TRANSLATION
+
+Translation is considered a kind of modification, so you may
+distribute translations of the Document under the terms of section 4.
+Replacing Invariant Sections with translations requires special
+permission from their copyright holders, but you may include
+translations of some or all Invariant Sections in addition to the
+original versions of these Invariant Sections. You may include a
+translation of this License, and all the license notices in the
+Document, and any Warranty Disclaimers, provided that you also include
+the original English version of this License and the original versions
+of those notices and disclaimers. In case of a disagreement between
+the translation and the original version of this License or a notice
+or disclaimer, the original version will prevail.
+
+If a section in the Document is Entitled ``Acknowledgements'',
+``Dedications'', or ``History'', the requirement (section 4) to Preserve
+its Title (section 1) will typically require changing the actual
+title.
+
+@item
+TERMINATION
+
+You may not copy, modify, sublicense, or distribute the Document
+except as expressly provided under this License. Any attempt
+otherwise to copy, modify, sublicense, or distribute it is void, and
+will automatically terminate your rights under this License.
+
+However, if you cease all violation of this License, then your license
+from a particular copyright holder is reinstated (a) provisionally,
+unless and until the copyright holder explicitly and finally
+terminates your license, and (b) permanently, if the copyright holder
+fails to notify you of the violation by some reasonable means prior to
+60 days after the cessation.
+
+Moreover, your license from a particular copyright holder is
+reinstated permanently if the copyright holder notifies you of the
+violation by some reasonable means, this is the first time you have
+received notice of violation of this License (for any work) from that
+copyright holder, and you cure the violation prior to 30 days after
+your receipt of the notice.
+
+Termination of your rights under this section does not terminate the
+licenses of parties who have received copies or rights from you under
+this License. If your rights have been terminated and not permanently
+reinstated, receipt of a copy of some or all of the same material does
+not give you any rights to use it.
+
+@item
+FUTURE REVISIONS OF THIS LICENSE
+
+The Free Software Foundation may publish new, revised versions
+of the GNU Free Documentation License from time to time. Such new
+versions will be similar in spirit to the present version, but may
+differ in detail to address new problems or concerns. See
+@uref{http://www.gnu.org/copyleft/}.
+
+Each version of the License is given a distinguishing version number.
+If the Document specifies that a particular numbered version of this
+License ``or any later version'' applies to it, you have the option of
+following the terms and conditions either of that specified version or
+of any later version that has been published (not as a draft) by the
+Free Software Foundation. If the Document does not specify a version
+number of this License, you may choose any version ever published (not
+as a draft) by the Free Software Foundation. If the Document
+specifies that a proxy can decide which future versions of this
+License can be used, that proxy's public statement of acceptance of a
+version permanently authorizes you to choose that version for the
+Document.
+
+@item
+RELICENSING
+
+``Massive Multiauthor Collaboration Site'' (or ``MMC Site'') means any
+World Wide Web server that publishes copyrightable works and also
+provides prominent facilities for anybody to edit those works. A
+public wiki that anybody can edit is an example of such a server. A
+``Massive Multiauthor Collaboration'' (or ``MMC'') contained in the
+site means any set of copyrightable works thus published on the MMC
+site.
+
+``CC-BY-SA'' means the Creative Commons Attribution-Share Alike 3.0
+license published by Creative Commons Corporation, a not-for-profit
+corporation with a principal place of business in San Francisco,
+California, as well as future copyleft versions of that license
+published by that same organization.
+
+``Incorporate'' means to publish or republish a Document, in whole or
+in part, as part of another Document.
+
+An MMC is ``eligible for relicensing'' if it is licensed under this
+License, and if all works that were first published under this License
+somewhere other than this MMC, and subsequently incorporated in whole
+or in part into the MMC, (1) had no cover texts or invariant sections,
+and (2) were thus incorporated prior to November 1, 2008.
+
+The operator of an MMC Site may republish an MMC contained in the site
+under CC-BY-SA on the same site at any time before August 1, 2009,
+provided the MMC is eligible for relicensing.
+
+@end enumerate
+
+@page
+@heading ADDENDUM: How to use this License for your documents
+
+To use this License in a document you have written, include a copy of
+the License in the document and put the following copyright and
+license notices just after the title page:
+
+@smallexample
+@group
+ Copyright (C) @var{year} @var{your name}.
+ Permission is granted to copy, distribute and/or modify this document
+ under the terms of the GNU Free Documentation License, Version 1.3
+ or any later version published by the Free Software Foundation;
+ with no Invariant Sections, no Front-Cover Texts, and no Back-Cover
+ Texts. A copy of the license is included in the section entitled ``GNU
+ Free Documentation License''.
+@end group
+@end smallexample
+
+If you have Invariant Sections, Front-Cover Texts and Back-Cover Texts,
+replace the ``with@dots{}Texts.'' line with this:
+
+@smallexample
+@group
+ with the Invariant Sections being @var{list their titles}, with
+ the Front-Cover Texts being @var{list}, and with the Back-Cover Texts
+ being @var{list}.
+@end group
+@end smallexample
+
+If you have Invariant Sections without Cover Texts, or some other
+combination of the three, merge those two alternatives to suit the
+situation.
+
+If your document contains nontrivial examples of program code, we
+recommend releasing these examples in parallel under your choice of
+free software license, such as the GNU General Public License,
+to permit their use in free software.
+
+
+@c Local Variables:
+@c ispell-local-pdict: "ispell-dict"
+@c End:
diff --git a/emacs_gpr_query.gpr b/emacs_gpr_query.gpr
new file mode 100644
index 0000000000..e2a539f6a1
--- /dev/null
+++ b/emacs_gpr_query.gpr
@@ -0,0 +1,100 @@
+-- Abstract :
+--
+-- GNAT project file for building Emacs gpr-query executables with Alire
+--
+-- Copyright (C) 2022 Free Software Foundation, Inc.
+--
+-- This program is free software; you can redistribute it and/or
+-- modify it under terms of the GNU General Public License as
+-- published by the Free Software Foundation; either version 3, 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
+-- distributed with this program; see file COPYING. If not, write to
+-- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
+-- MA 02110-1335, USA.
+
+with "config/emacs_gpr_query_config.gpr";
+with "gnatcoll";
+with "gnatcoll_sqlite";
+with "gnatcoll_xref";
+project Emacs_Gpr_Query is
+
+ for Source_Dirs use (".", "config/");
+
+ for Object_Dir use "obj/" & Emacs_Gpr_Query_Config.Build_Profile;
+ for Create_Missing_Dirs use "True";
+ for Exec_Dir use "bin";
+ for Main use ("gpr_query.adb");
+
+ package Compiler is
+ Style_Checks := ("-gnaty3abcefhiklnOprtx", "-gnatyM120");
+
+ Common_Switches :=
+ ("-gnat2020", -- GNAT 11.3 (Debian testing as of Sept 2022) doesn't
have -gnat2022
+ "-fstack-check",
+ "-g",
+ "-gnatfqQ", -- f = all error messages, qQ = process semantics,
generate .ali if syntax errors
+ "-gnatw.d", -- warnings about tags
+ "-gnatwaBCeJL"
+ -- wa = most warnings
+ -- wB = no warn on bad fixed values
+ -- wC = no warn on conditionals
+ -- we = error on warning
+ -- wJ = no warn on obsolescent (including () for array indices!)
+ -- wL = no warn on elaboration
+ );
+
+ -- -gnatVa causes some inline procedures to be non-inlineable;
+ -- suppress that warning with -gnatwP.
+ Debug_Switches := Common_Switches &
+ (
+ "-O0", -- we don't use -Og because that causes gdb to report
incorrect results in some cases in Ada.
+ "-gnatVa", -- validity checks
+ "-gnateE", -- extra info in exceptions
+ "-gnatwP", -- no warn on Inline
+ "-gnata" -- assertions, pre/post-conditions
+ );
+
+ -- -O3 is measurably faster than -O2 for wisitoken generate
+ -- LR1. We include -fstack-check because it catches
+ -- hard-to-find bugs, and the processors are so fast.
+ -- -fno-var-tracking-assignments speeds compiling of large
+ -- files; var tracking is only useful for debugging.
+ Release_Switches := Common_Switches &
+ (
+ "-O3",
+ "-gnatn",
+ "-fno-var-tracking-assignments"
+ );
+
+ case Emacs_Gpr_Query_Config.Build_Profile is
+ when "release" =>
+ for Default_Switches ("Ada") use Release_Switches & Style_Checks;
+
+ for Switches ("gpr_query.adb") use
+ -- WORKAROUND: GNAT Community 2021 with gnatcoll 21.2 and -gnat2020
reports a missing "overrides"
+ -- AdaCore ticket U618-051
+ Common_Switches &
+ "-gnaty3abcefhiklnprtx" & "-gnatyM120" & -- not overriding
+ Release_Switches;
+
+ when "validation" | "development" =>
+ for Default_Switches ("Ada") use Debug_Switches & Style_Checks;
+
+ for Switches ("gpr_query.adb") use
+ -- WORKAROUND: GNAT Community 2021 reports that gnatcoll 21.2 is
missing an "overrides" somewhere
+ Common_Switches &
+ "-gnaty3abcefhiklnprtx" & -- not overrding
+ Debug_Switches;
+
+ end case;
+ end Compiler;
+
+ package Binder is
+ for Switches ("Ada") use ("-Es"); -- Symbolic traceback
+ end Binder;
+
+end Emacs_Gpr_Query;
diff --git a/emacs_gpr_query_config_devel.gpr b/emacs_gpr_query_config_devel.gpr
new file mode 100644
index 0000000000..6233fd247c
--- /dev/null
+++ b/emacs_gpr_query_config_devel.gpr
@@ -0,0 +1,51 @@
+-- Configuration for emacs_gpr_query generated by Alire
+with "gnatcoll.gpr";
+with "gnatcoll_sqlite.gpr";
+with "gnatcoll_xref.gpr";
+abstract project Emacs_Gpr_Query_Config is
+ Crate_Version := "0.1.0-dev";
+ Crate_Name := "emacs_gpr_query";
+
+ Alire_Host_OS := "linux";
+
+ Alire_Host_Arch := "x86_64";
+
+ Alire_Host_Distro := "debian";
+ Ada_Compiler_Switches := External_As_List ("ADAFLAGS", " ") &
+ (
+ "-Og" -- Optimize for debug
+ ,"-ffunction-sections" -- Separate ELF section for each function
+ ,"-fdata-sections" -- Separate ELF section for each variable
+ ,"-g" -- Generate debug info
+ ,"-gnatwa" -- Enable all warnings
+ ,"-gnatw.X" -- Disable warnings for No_Exception_Propagation
+ ,"-gnatVa" -- All validity checks
+ ,"-gnaty3" -- Specify indentation level of 3
+ ,"-gnatya" -- Check attribute casing
+ ,"-gnatyA" -- Use of array index numbers in array attributes
+ ,"-gnatyB" -- Check Boolean operators
+ ,"-gnatyb" -- Blanks not allowed at statement end
+ ,"-gnatyc" -- Check comments
+ ,"-gnaty-d" -- Disable check no DOS line terminators present
+ ,"-gnatye" -- Check end/exit labels
+ ,"-gnatyf" -- No form feeds or vertical tabs
+ ,"-gnatyh" -- No horizontal tabs
+ ,"-gnatyi" -- Check if-then layout
+ ,"-gnatyI" -- check mode IN keywords
+ ,"-gnatyk" -- Check keyword casing
+ ,"-gnatyl" -- Check layout
+ ,"-gnatym" -- Check maximum line length
+ ,"-gnatyn" -- Check casing of entities in Standard
+ ,"-gnatyO" -- Check that overriding subprograms are explicitly
marked as such
+ ,"-gnatyp" -- Check pragma casing
+ ,"-gnatyr" -- Check identifier references casing
+ ,"-gnatyS" -- Check no statements after THEN/ELSE
+ ,"-gnatyt" -- Check token spacing
+ ,"-gnatyu" -- Check unnecessary blank lines
+ ,"-gnatyx" -- Check extra parentheses
+ );
+
+ type Build_Profile_Kind is ("release", "validation", "development");
+ Build_Profile : Build_Profile_Kind := "development";
+
+end Emacs_Gpr_Query_Config;
diff --git a/emacs_gpr_query_config_release.gpr
b/emacs_gpr_query_config_release.gpr
new file mode 100644
index 0000000000..a1b274841e
--- /dev/null
+++ b/emacs_gpr_query_config_release.gpr
@@ -0,0 +1,26 @@
+-- Configuration for emacs_gpr_query generated by Alire
+with "gnatcoll.gpr";
+with "gnatcoll_sqlite.gpr";
+with "gnatcoll_xref.gpr";
+abstract project Emacs_Gpr_Query_Config is
+ Crate_Version := "1.0.1";
+ Crate_Name := "emacs_gpr_query";
+
+ Alire_Host_OS := "windows";
+
+ Alire_Host_Arch := "x86_64";
+
+ Alire_Host_Distro := "msys2";
+ Ada_Compiler_Switches := External_As_List ("ADAFLAGS", " ");
+ Ada_Compiler_Switches := Ada_Compiler_Switches &
+ (
+ "-O3" -- Optimize for performance
+ ,"-gnatn" -- Enable inlining
+ ,"-ffunction-sections" -- Separate ELF section for each function
+ ,"-fdata-sections" -- Separate ELF section for each variable
+ );
+
+ type Build_Profile_Kind is ("release", "validation", "development");
+ Build_Profile : Build_Profile_Kind := "release";
+
+end Emacs_Gpr_Query_Config;
diff --git a/gnatcoll-2021-sql.diff b/gnatcoll-2021-sql.diff
new file mode 100644
index 0000000000..24ff3b1fc1
--- /dev/null
+++ b/gnatcoll-2021-sql.diff
@@ -0,0 +1,20 @@
+--- sql/gnatcoll-sql_impl.adb.orig 2021-05-20 01:25:55.000000000 -0700
++++ sql/gnatcoll-sql_impl.adb 2021-06-21 09:44:09.437292100 -0700
+@@ -188,15 +188,9 @@
+ (Self : Field;
+ To : in out SQL_Field_List'Class;
+ Is_Aggregate : in out Boolean)
+- is
+- FC : access SQL_Field_Internal'Class;
+- begin
++ is begin
+ if not Self.Data.Is_Null then
+- -- !!! Could not use Element call result in the
+- -- Append_If_Not_Aggregate parameter because of GNAT bug OB03-009
+-
+- FC := Self.Data.Get.Element;
+- Append_If_Not_Aggregate (FC, To, Is_Aggregate);
++ Append_If_Not_Aggregate (Self.Data.Get.Element, To, Is_Aggregate);
+ end if;
+ end Append_If_Not_Aggregate;
+ end Data_Fields;
diff --git a/gpr-query.el b/gpr-query.el
new file mode 100644
index 0000000000..d047c50f79
--- /dev/null
+++ b/gpr-query.el
@@ -0,0 +1,1106 @@
+;; gpr-query.el --- Minor mode for navigating sources using gpr_query -*-
lexical-binding:t -*-
+;;
+;; gpr-query supports Ada and any gcc language that supports the
+;; AdaCore -fdump-xref switch (which includes C, C++).
+;;
+;; Copyright (C) 2013 - 2022 Free Software Foundation, Inc.
+
+;; Author: Stephen Leake <stephen_leake@member.fsf.org>
+;; Maintainer: Stephen Leake <stephen_leake@member.fsf.org>
+;; Version: 1.0.1
+;; package-requires: ((emacs "25.3") (wisi "4.1") (gnat-compiler "1.0"))
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs 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 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs 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. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Usage:
+;;
+;; M-x gpr-query
+
+(require 'cl-lib)
+(require 'compile)
+(require 'gnat-compiler)
+(require 'xref)
+(require 'wisi-prj)
+
+(defgroup gpr-query nil
+ "gpr_query cross reference tool"
+ :group 'tools)
+
+(defcustom gpr-query-exec "gpr_query"
+ "Executable for gpr_query."
+ :type 'string)
+
+(defcustom gpr-query-no-symbols nil
+ "If non-nil, don't get symbol completion table from gpr-query.
+Reading all the symbols can be slow in a very large project."
+ :type 'boolean)
+
+(defcustom gpr-query-exec-opts '()
+ "Options for `gpr-query-exec'; a list of strings.
+\"--project\" is specified automatically. This can be used to
+override the database location by specifying
+\"--db=<writeable_file>\". See \"gpr_query --help\" for more
+options."
+ :type 'list)
+
+(defcustom gpr-query-env nil
+ "Environment variables needed by the gpr_query executable.
+Value must be a list where each element is \"<name>=<value>\""
+ ;; This could also be provided as a project file setting, But it is
+ ;; intended for LD_LIBRARY_PATH (info "(ada-mode)Ada executables"),
+ ;; which must be set for all projects on the system.
+ :type 'string)
+
+(defconst gpr-query-protocol-version "3"
+ "Defines data exchanged between this package and the background process.
+Must match gpr_query.adb Version.")
+
+;;;;; sessions
+
+;; gpr_query reads the project files and the database at startup,
+;; which is noticeably slow for a reasonably sized project. But
+;; running queries after startup is fast. So we leave gpr_query
+;; running, and send it new queries via stdin, getting responses via
+;; stdout.
+;;
+;; We maintain a cache of active sessions, one per gnat project.
+
+(cl-defstruct (gpr-query--session)
+ gpr-file ;; string absolute file name
+ process-env ;; copy of process-environment used to start a process
+ (xref-process nil) ;; running gpr_query, for xrefs; default-directory gives
location of db
+ no-symbols ;; boolean; if non-nil, don't start symbols process
+ (symbols-process nil);; runs 'complete' gpr_query command to get
symbol-locs, symbols; then dies.
+
+ symbol-locs ;; alist completion table, with locations; see
gpr-query--symbols-filter
+ symbols ;; symbols completion table.
+ symbols-valid ;; nil initialy, 'waiting when getting symbols, t when symbols
valid
+ symbols-count-total
+ )
+
+;; Starting the buffer name with a space hides it from some lists, and
+;; also disables font-lock. We sometimes use it to display xref
+;; locations in compilation-mode, so we want font-lock enabled.
+(defconst gpr-query-buffer-name-prefix "*gpr_query-")
+
+(defconst gpr-query-prompt "^>>> $"
+ ;; gpr_query output ends with this
+ "Regexp matching gpr_query prompt; indicates previous command is complete.")
+
+(defvar gpr-query--debug nil
+ "When non-nil, dispay debug messages.")
+
+(defvar-local gpr-query--local-session nil
+ "Buffer-local in gpr-query process buffer; the current session.")
+
+(defun gpr-query--check-startup ()
+ ;; current buffer is process output buffer
+ (goto-char (point-min))
+ (if (search-forward-regexp "version: \\([0-9]+\\)$" nil t)
+ (unless (string-equal (match-string 1) gpr-query-protocol-version)
+ (user-error "gpr-query version mismatch: elisp %s process %s"
+ gpr-query-protocol-version
+ (match-string 1)))
+ (user-error "'%s' is an old version (did not output version); expecting %s"
+ gpr-query-exec
+ gpr-query-protocol-version))
+
+ ;; Check for warnings about invalid directories etc. But some
+ ;; warnings are tolerable, so only abort if process actually
+ ;; died.
+ (goto-char (point-min))
+ (when (search-forward "warning:" nil t)
+ (if debug-on-error
+ (error "gpr_query warnings")
+ (beep)
+ (message "gpr_query warnings"))))
+
+(defun gpr-query--xref-filter (process text)
+ "Process filter for xref-process."
+ ;; First, wait for startup to complete, indicated by receiving the
+ ;; first prompt. Then start the symbols process; it does the same
+ ;; startup, which is faster after the xref startup due to disk
+ ;; caching. Then unregister the filter; it is not needed any more.
+ (when (buffer-name (process-buffer process))
+ ;; process buffer is not dead
+ (with-current-buffer (process-buffer process)
+ (let ((search-start (marker-position (process-mark process))))
+ (save-excursion
+ (goto-char (process-mark process))
+ (insert text)
+ (set-marker (process-mark process) (point)))
+
+ ;; Wait for current command (or startup) to finish, do next
+ ;; action.
+ (goto-char search-start)
+ ;; back up a line in case we got part of the prompt previously.
+ (forward-line -1)
+ (when (re-search-forward gpr-query-prompt (point-max) 1)
+ ;; startup completed
+ (gpr-query--check-startup)
+ (set-process-filter process nil)
+
+ (unless (gpr-query--session-no-symbols gpr-query--local-session)
+ ;; start the symbols process to get the symbols
+ (gpr-query--start-process gpr-query--local-session 'symbols))
+ )))))
+
+(defvar gpr-query--symbols-progress ""
+ ;; We assume only one gpr-query symbols process is active at a time
+ "For progress messages while waiting for symbols.")
+
+(defconst gpr-query--symbol-char "[-+*/=<>&[:alnum:]_.]")
+
+(defconst gpr-query-completion-regexp
+ (concat "\\(" gpr-query--symbol-char "+\\)\\((.*)\\)?<.*<[0-9]+>>")
+ "Regexp matching completion item from gpr-query--read-symbols.")
+
+(defun gpr-query--update-progress ()
+ ;; separate for debugging; update gpr-query--symbols-progress
+ (let* ((count (line-number-at-pos (point)))
+ (percent (/ (* 100 count) (gpr-query--session-symbols-count-total
gpr-query--local-session))))
+ (setq gpr-query--symbols-progress (format "%d%%" percent))
+ (when gpr-query--debug
+ (message "gpr-query update-progress %s" gpr-query--symbols-progress))
+ ))
+
+(defun gpr-query--symbols-filter (process text)
+ "Process filter for symbols process."
+ (when (buffer-live-p (process-buffer process))
+ (with-current-buffer (process-buffer process)
+ (let ((search-start (marker-position (process-mark process))))
+ (save-excursion
+ (goto-char (process-mark process))
+ (insert text)
+ (set-marker (process-mark process) (point)))
+
+ ;; Update session progress slots, accumulate symbols
+ (cond
+ ((null (gpr-query--session-symbols-count-total
gpr-query--local-session))
+ (goto-char search-start)
+ ;; back up a line in case we got part of the line previously.
+ (forward-line -1)
+
+ (when (re-search-forward "element count \\([0-9]+\\)" (point-max) t)
+ (setf (gpr-query--session-symbols-count-total
gpr-query--local-session)
+ (string-to-number (match-string 1)))
+ (when gpr-query--debug
+ (message "gpr-query symbols: total count received %d"
+ (gpr-query--session-symbols-count-total
gpr-query--local-session)))
+ ))
+ (t
+ (goto-char search-start)
+ ;; back up a line in case we got part of the line previously.
+ (forward-line -1)
+ ;; The gpr_query 'complete' command returns a fully qualified name
+ ;; and declaration location for each name:
+ ;;
+ ;; Wisi.Ada.Ada_Indent_Aggregate.Args
C:\Projects\org.emacs.ada-mode\wisi-ada.ads:102:7
+ ;;
+ ;; For subprograms it includes the parameters (but not a function
result):
+ ;;
+ ;; Gpr_Query.Process_Command_Single(Args)
C:\Projects\org.emacs.ada-mode\gpr_query.adb:109:14
+ ;;
+ ;; Build a completion table as an alist of:
+ ;;
+ ;; (simple_name(args)<prefix<line>> . location).
+ ;;
+ ;; The car matches wisi-xref-completion-regexp.
+ ;;
+ ;; We include the line number to make each name unique. This
+ ;; doesn't work for one-line parameter lists, variable
+ ;; declaration lists and similar, but they should be
+ ;; unique names anyway.
+ (while (not (eobp))
+ (cond
+ ;; We don't use gpr-query-completion-regexp here because we need
finer groups.
+ ((looking-at (concat "\\(" gpr-query--symbol-char "+\\)" ;; 1:
prefix
+ "\\.\\(" gpr-query--symbol-char "+\\)" ;; 2:
simple name
+ "\\((.*)\\)? " ;; 3:
args,
+ wisi-file-line-col-regexp)) ;; 4,
5, 6 file:line:col
+ ;; Process line. `cl-pushnew' would slow down the
+ ;; processing too much; it noticeably ties up the Emacs
+ ;; foreground process in large projects.
+ (push (match-string-no-properties 2) (gpr-query--session-symbols
gpr-query--local-session))
+ (push
+ (cons (concat (match-string-no-properties 2)
+ (match-string-no-properties 3)
+ "<" (match-string-no-properties 1) "<"
(match-string-no-properties 5) ">>")
+ (list (gpr-query--normalize-filename
(match-string-no-properties 4))
+ (string-to-number (match-string 5))
+ (1- (string-to-number (match-string 6)))))
+ (gpr-query--session-symbol-locs gpr-query--local-session))
+ )
+
+ (t ;; ignore line
+ nil)
+ )
+ (forward-line 1))
+
+ (gpr-query--update-progress)
+ ))
+
+ ;; Wait for last command to finish.
+ (goto-char search-start)
+ (forward-line -1)
+ (when (re-search-forward gpr-query-prompt (point-max) t)
+ (cond
+ ((null (gpr-query--session-symbols-count-total
gpr-query--local-session))
+ ;; startup complete; waiting for symbol count
+ (when gpr-query--debug
+ (message "gpr-query symbols: startup complete"))
+ (gpr-query--check-startup)
+ (erase-buffer)
+ (set-marker (process-mark process) (point-min))
+ (setf (gpr-query--session-symbols-count-total
gpr-query--local-session) nil)
+ (process-send-string process "complete \"\"\n")
+ (setq gpr-query--symbols-progress "0%")
+ (setf (gpr-query--session-symbols-valid gpr-query--local-session)
'waiting))
+
+ (t
+ ;; All symbols received; done
+ (when gpr-query--debug
+ (message "gpr-query symbols: all symbols received"))
+ (setf (gpr-query--session-symbols-valid gpr-query--local-session) t)
+ (set-process-filter process nil)
+ (process-send-string process "exit\n"))
+
+ ))
+ ))))
+
+(defun gpr-query--start-process (session command-type)
+ "Start a session process running gpr_query. COMMAND-TYPE is xref or symbols."
+ (unless (locate-file gpr-query-exec exec-path '("" ".exe"))
+ (user-error "'%s' not found on PATH" gpr-query-exec))
+
+ (when gpr-query--debug
+ (message "gpr-query-start %s" command-type))
+
+ ;; Reuse existing buffer if possible
+ (let* ((gpr-file (gpr-query--session-gpr-file session))
+ (process
+ (cl-ecase command-type
+ (xref (gpr-query--session-xref-process session))
+ (symbols (gpr-query--session-symbols-process session))))
+ (buffer (and process (process-buffer process)))
+ (process-environment (gpr-query--session-process-env session)))
+
+ (unless (buffer-live-p buffer)
+ ;; User may have killed buffer, which kills process
+ (let ((name (concat "*gpr-query-" (symbol-name command-type) "*-"
gpr-file)))
+ (setq buffer (get-buffer-create name))
+ (with-current-buffer buffer
+ (setq default-directory (file-name-directory gpr-file))
+ (compilation-mode) ;; kills all local variables, requires
default-directory
+ (buffer-disable-undo)
+ (setq gpr-query--local-session session)
+ (setq buffer-read-only nil))))
+
+ (with-current-buffer buffer
+ (erase-buffer); delete any previous messages, prompt
+ (setf (gpr-query--session-symbol-locs session) nil)
+ (setf (gpr-query--session-symbols session) nil)
+ (setf (gpr-query--session-symbols-valid session) nil)
+ (let ((args (cl-delete-if
+ 'null
+ (append
+ (list
+ (concat "--project=" (file-name-nondirectory gpr-file))
+ (when gpr-query--debug
+ "--tracefile=gpr_query.trace"
+ ;; The file gpr_query.trace should contain: gpr_query=yes
+ ))
+ gpr-query-exec-opts))))
+ (when gpr-query--debug
+ (message "gpr-query process args: %s" args))
+ (setq process
+ (apply #'start-process
+ (buffer-name)
+ buffer
+ gpr-query-exec
+ args)))
+ (cl-ecase command-type
+ (xref
+ (setf (gpr-query--session-xref-process session) process)
+ (set-process-filter process #'gpr-query--xref-filter))
+ (symbols
+ (setf (gpr-query--session-symbols-process session) process)
+ (set-process-filter process #'gpr-query--symbols-filter)))
+
+ (set-process-query-on-exit-flag process nil)
+ )))
+
+(defun gpr-query--make-session (project no-symbols)
+ "Create and return a session for the current project file.
+If NO-SYMBOLS is non-nil, don't create the symbols process."
+ (let ((session
+ (make-gpr-query--session
+ :gpr-file (gnat-compiler-gpr-file (wisi-prj-xref project))
+ :no-symbols no-symbols
+ :process-env (copy-sequence
+ (append
+ (wisi-prj-compile-env project)
+ (wisi-prj-file-env project)
+ gpr-query-env
+ process-environment)))))
+ (gpr-query--start-process session 'xref)
+ session))
+
+(defvar gpr-query--sessions '()
+ "Assoc list of sessions, indexed by absolute GNAT project file name.")
+
+(cl-defun gpr-query-cached-session (project &key no-symbols)
+ "Return a session for PROJECT, creating it if necessary.
+If NO-SYMBOLS is non-nil, don't create the symbols process."
+ (let* ((gpr-file (gnat-compiler-gpr-file (wisi-prj-xref project)))
+ (session (cdr (assoc gpr-file gpr-query--sessions))))
+ (if session
+ (progn
+ (setf (gpr-query--session-no-symbols session) (or no-symbols
gpr-query-no-symbols))
+ (unless (process-live-p (gpr-query--session-xref-process session))
+ (gpr-query--start-process session 'xref))
+ session)
+ ;; else
+ (prog1
+ (setq session (gpr-query--make-session project (or no-symbols
gpr-query-no-symbols)))
+ (push (cons gpr-file session) gpr-query--sessions)))
+ ))
+
+(defun gpr-query-session-wait (session command-type)
+ "Wait for the current COMMAND-TYPE command to complete.
+COMMAND-TYPE is one of xref or symbols."
+ (when gpr-query--debug
+ (message "gpr-query-session-wait %s" command-type))
+
+ (when (and
+ (eq command-type 'symbols)
+ (null (gpr-query--session-symbols-process session)))
+ ;; The symbols process is not started until the xref process
+ ;; returns its first prompt.
+ (gpr-query-session-wait session 'xref))
+
+ (let ((process
+ (cl-ecase command-type
+ (xref (gpr-query--session-xref-process session))
+ (symbols (gpr-query--session-symbols-process session))))
+ search-start
+ (done nil)
+ (wait-count 0))
+
+ (when (and (eq command-type 'xref)
+ (not (process-live-p process)))
+ (gpr-query--show-buffer session command-type)
+ (error "gpr-query process died"))
+
+ (while (and (process-live-p process)
+ (not done))
+ (cl-ecase command-type
+ (symbols
+ ;; The process filter is reading symbols text in the process
+ ;; buffer; don't move point or otherwise modify the buffer.
+ (cond
+ ((eq (gpr-query--session-symbols-valid session) t)
+ (setq done t))
+
+ (t
+ (message "gpr-query receiving symbols %s"
gpr-query--symbols-progress))))
+
+ (xref
+ (message "running gpr_query xref ... %d" wait-count)
+
+ ;; process output is inserted before point, so move back over it to
search it
+ (with-current-buffer (process-buffer process)
+ (setq search-start (point-min))
+
+ (goto-char search-start)
+ (if (re-search-forward gpr-query-prompt (point-max) 1)
+ (setq done t))))
+ )
+
+ (when (not done);; wait for more input
+ (unless (accept-process-output process 1.0)
+ ;; accept-process returns non-nil when we got output, so we
+ ;; did not wait for timeout.
+ (setq wait-count (1+ wait-count))
+ ))
+ )
+
+ (if (or (eq command-type 'symbols);; symbols process is supposed to die
+ (process-live-p process))
+ (cl-ecase command-type
+ (symbols
+ (message "gpr-query symbols done; symbols length %d"
+ (length (gpr-query--session-symbols session)))
+ )
+ (xref
+ (message (concat "running gpr_query ... done"))))
+ (gpr-query--show-buffer session command-type)
+ (error "gpr_query process died"))
+ ))
+
+(defun gpr-query--session-send (session cmd wait)
+ "Send CMD to SESSION gpr_query xref process.
+If WAIT is non-nil, wait for command to complete.
+Return buffer that holds output."
+ ;; Always wait for previous command to complete; also checks for
+ ;; dead process.
+ (gpr-query-session-wait session 'xref)
+ (when gpr-query--debug
+ (message "gpr-query-send: %s" cmd))
+ (with-current-buffer (process-buffer (gpr-query--session-xref-process
session))
+ (erase-buffer)
+ (process-send-string (gpr-query--session-xref-process session)
+ (concat cmd "\n"))
+ (when wait
+ (gpr-query-session-wait session 'xref))
+ (current-buffer)
+ ))
+
+(defun gpr-query--kill-process (process)
+ "Kill a gpr-query process nicely.
+Returns t if the process was live."
+ (when (process-live-p process)
+ (process-send-string process "exit\n")
+ (while (process-live-p process)
+ (accept-process-output process 1.0))
+ t))
+
+(defun gpr-query-kill-session (session)
+ "Kill the background processes of SESSION.
+Return t if either process was live."
+ (setf (gpr-query--session-symbol-locs session) nil)
+ (setf (gpr-query--session-symbols session) nil)
+ (setf (gpr-query--session-symbols-valid session) nil)
+ (let (result)
+ (setq result (gpr-query--kill-process (gpr-query--session-xref-process
session)))
+ (setq result (or (gpr-query--kill-process
(gpr-query--session-symbols-process session))
+ result))
+ result))
+
+(defun gpr-query-kill-all-sessions ()
+ (interactive)
+ (let ((count 0))
+ (mapc (lambda (assoc)
+ (when (gpr-query-kill-session (cdr assoc))
+ (setq count (1+ count))))
+ gpr-query--sessions)
+ (message "Killed %d sessions" count)
+ ))
+
+(defun gpr-query--show-buffer (session command-type)
+ (cl-ecase command-type
+ (xref (pop-to-buffer (process-buffer (gpr-query--session-xref-process
session))))
+ (symbols (pop-to-buffer (process-buffer
(gpr-query--session-symbols-process session))))))
+
+;;;;; utils
+
+(defun gpr-query-get-src-dirs (project src-dirs)
+ "Append list of source dirs in gpr project PROJECT to SRC-DIRS.
+Uses `gpr_query'. Returns new list."
+
+ (let ((session (gpr-query-cached-session project)))
+ (with-current-buffer (gpr-query--session-send session "source_dirs" t)
+ (goto-char (point-min))
+ (while (not (looking-at gpr-query-prompt))
+ (cl-pushnew
+ (expand-file-name ; Canonicalize path part.
+ (directory-file-name
+ (buffer-substring-no-properties (point) (line-end-position))))
+ src-dirs :test #'equal)
+ (forward-line 1))
+ ))
+ src-dirs)
+
+(defun gpr-query-get-prj-dirs (project prj-dirs)
+ "Append list of project dirs in gpr project PROJECT to PRJ-DIRS.
+Uses `gpr_query'. Returns new list."
+
+ (let ((session (gpr-query-cached-session project)))
+ (with-current-buffer (gpr-query--session-send session "project_path" t)
+ (goto-char (point-min))
+ (while (not (looking-at gpr-query-prompt))
+ (cl-pushnew
+ (let ((dir (buffer-substring-no-properties (point)
(line-end-position))))
+ (if (string= dir ".")
+ (directory-file-name default-directory)
+ (expand-file-name dir))) ; Canonicalize path part.
+ prj-dirs
+ :test #'equal)
+ (forward-line 1))
+ ))
+ prj-dirs)
+
+(defconst gpr-query-ident-file-regexp-alist
+ (list (concat "^" wisi-file-line-col-regexp) 1 2 3)
+ "For compilation-error-regexp-alist, matching gpr_query output")
+
+(defconst gpr-query-ident-file-type-regexp
+ (concat wisi-file-line-col-regexp " (\\(.*\\))")
+ "Regexp matching <file>:<line>:<column> (<type>)")
+
+(defun gpr-query-compilation (project identifier file line col cmd comp-err
&optional local_only append)
+ "Run gpr_query CMD IDENTIFIER:FILE:LINE:COL,
+with compilation-error-regexp-alist set to COMP-ERR."
+ ;; Useful when gpr_query will return a list of references; the user
+ ;; can navigate to each result in turn via `next-error'.
+
+ ;; Emacs column is 0-indexed, gpr_query is 1-indexed.
+ (let* ((cmd-1 (concat (format "%s %s:%s:%d:%d"
+ cmd identifier file line (1+ col))
+ (when (member cmd '("refs"))
+ (if local_only " local_only" " global"))
+ (when (member cmd '("overriding" "overridden_by"
"parent_types" "refs"))
+ (if wisi-xref-full-path " full_file_names" "
short_file_names"))))
+ (session (gpr-query-cached-session project))
+ (result-count 0)
+ start-pos prev-content
+ target-file target-line target-col)
+
+ (when append
+ (with-current-buffer (process-buffer (gpr-query--session-xref-process
session))
+ ;; don't include trailing prompt in `prev-content'
+ (goto-char (point-max))
+ (forward-line 0)
+ (setq prev-content (buffer-substring (point-min) (point)))))
+
+ (with-current-buffer (gpr-query--session-send session cmd-1 t)
+ ;; point is at EOB. gpr_query returns one line per result plus prompt,
warnings
+ (setq result-count (- (line-number-at-pos) 1))
+ (setq start-pos (point-min))
+
+ (setq buffer-read-only nil)
+ (when append
+ (goto-char (point-min))
+ (insert prev-content)
+ (setq start-pos (point))
+ (goto-char (point-max)))
+
+ (set (make-local-variable 'compilation-error-regexp-alist) (list
comp-err))
+
+ (compilation--flush-parse (point-min) (point-max))
+ (compilation--ensure-parse (point-max))
+
+ (goto-char start-pos)
+
+ (cond
+ ((looking-at "^warning: ")
+ (setq result-count (1- result-count))
+ (forward-line 1))
+ ((looking-at "^Error: entity not found")
+ (user-error (buffer-substring-no-properties (line-beginning-position)
(line-end-position))))
+ )
+
+ (cond
+ ((and (not append)
+ (= result-count 1))
+ ;; just go there, don't display session-buffer. We have to
+ ;; fetch the compilation-message while in the
+ ;; session-buffer. and call wisi-goto-source outside the
+ ;; with-current-buffer above.
+ (let* ((msg (compilation-next-error 0))
+ ;; IMPROVEME: '--' indicates internal-only. But we can't
+ ;; use compile-goto-error, because that displays the
+ ;; session-buffer.
+ (loc (compilation--message->loc msg)))
+ (setq target-file (caar (compilation--loc->file-struct loc))
+ target-line (caar (cddr (compilation--loc->file-struct loc)))
+ target-col (1- (compilation--loc->col loc))
+ )
+ ))
+
+ ((= result-count 0)
+ (user-error "gpr_query returned no results"))
+
+ (t
+ ;; for next-error, below
+ (setq next-error-last-buffer (current-buffer)))
+
+ ));; case, with-currrent-buffer
+
+ (if (and (not append)
+ (= result-count 1))
+ (wisi-goto-source target-file target-line target-col)
+
+ ;; more than one result; display session buffer, goto first ref
+ ;;
+ ;; compilation-next-error-function assumes there is not an error
+ ;; at point-min; work around that by moving forward 0 errors for
+ ;; the first one. Unless the first line contains "warning: ".
+ (pop-to-buffer next-error-last-buffer)
+ (goto-char start-pos)
+ (unless append
+ (if (looking-at "^warning: ")
+ (next-error 1 t)
+ (next-error 0 t)))
+ )
+ ))
+
+(defun gpr-query-dist (found-line line found-col col)
+ "Return distance between FOUND-LINE FOUND-COL and LINE COL."
+ (+ (abs (- found-col col))
+ (* (abs (- found-line line)) 250)))
+
+(defvar gpr-query-map
+ (let ((map (make-sparse-keymap)))
+ ;; C-c C-i prefix for gpr-query minor mode
+
+ (define-key map "\C-c\C-i\C-d" 'gpr-query-goto-declaration)
+ (define-key map "\C-c\C-i\C-q" 'gpr-query-refresh)
+ (define-key map "\C-c\C-i\C-r" 'gpr-query-show-references)
+ ;; IMPROVEME: (define-key map "\C-c\M-d" 'gpr-query-parents)
+ ;; IMPROVEME: overriding
+ map
+ ) "Local keymap used for gpr query minor mode.")
+
+(defvar gpr-query-menu (make-sparse-keymap "gpr-query"))
+(easy-menu-define gpr-query-menu gpr-query-map "Menu keymap for gpr-query
minor mode"
+ '("gpr-query"
+ ["Next xref" next-error t]
+ ["Goto declaration/body" xref-find-definitions t]
+ ["Show parent declarations" wisi-show-declaration-parents t]
+ ["Show references" wisi-show-references t]
+ ["Show overriding" wisi-show-overriding t]
+ ["Show overridden" wisi-show-overridden t]
+ ["Refresh cross reference cache" wisi-refresh-prj-cache t]
+ ))
+
+(define-minor-mode gpr-query
+ "Minor mode for navigating sources using GNAT cross reference tool.
+Enable mode if ARG is positive."
+ :initial-value t
+ :lighter " gpr-query" ;; mode line
+
+ ;; just enable the menu and keymap
+ )
+
+(defun gpr-query--normalize-filename (file)
+ "Convert FILE from native format to Emacs standard.
+FILE is from gpr-query."
+ ;; FILE must be abs
+ (cond
+ ((eq system-type 'windows-nt)
+ ;; 'expand-file-name' converts Windows directory separators to
+ ;; normal Emacs. Normally we would downcase here, but that
+ ;; interferes with completion table matching (buffer-file-name) in
+ ;; wisi-filter-table.
+ (expand-file-name file))
+
+ ((eq system-type 'darwin)
+ file)
+
+ (t ;; linux
+ file))
+ )
+
+;;;;; wisi-xref methods
+
+(cl-defstruct (gpr-query-xref (:include gnat-compiler))
+ ;; no new slots
+ )
+
+;;;###autoload
+(cl-defun create-gpr_query-xref (&key gpr-file)
+ ;; See note on `create-ada-prj' for why this is not a defalias.
+ (make-gpr-query-xref :gpr-file gpr-file))
+
+(cl-defmethod wisi-xref-parse-one ((xref gpr-query-xref) project name value)
+ (wisi-compiler-parse-one xref project name value))
+
+(cl-defmethod wisi-xref-parse-final ((xref gpr-query-xref) _project
prj-file-name)
+ (unless (gnat-compiler-gpr-file xref)
+ (if (string= "gpr" (file-name-extension prj-file-name))
+ (setf (gnat-compiler-gpr-file xref) prj-file-name)
+ (user-error "using gpr-query xref, but no gpr file provided"))))
+
+(cl-defmethod wisi-xref-select-prj ((_xref gpr-query-xref) project)
+ ;; Start the process if needed; it will read the db and return the
+ ;; symbols in the background.
+ (gpr-query-cached-session project)
+ nil)
+
+(cl-defmethod wisi-xref-refresh-cache ((xref gpr-query-xref) project no-full)
+ ;; Kill the current session and delete the database, to get changed
+ ;; env vars etc when it restarts.
+ ;;
+ ;; We need to delete the database files if the compiler version
+ ;; changed, or the database was built with an incorrect environment
+ ;; variable, or something else screwed up. However, rebuilding after
+ ;; that is a lot slower, so we only do that with permission.
+ (let* ((gpr-file (gnat-compiler-gpr-file xref))
+ (session (gpr-query-cached-session project :no-symbols t)) ;; we only
need the db file name.
+ (db-filename
+ (unless no-full
+ (condition-case nil
+ ;; gpr-query--session-send can fail if the .gpr file
+ ;; contains errors, for example if GPR_PROJECT_PATH is
+ ;; wrong.
+ (with-current-buffer (gpr-query--session-send session "db_name"
t)
+ (goto-char (point-min))
+ (buffer-substring-no-properties (line-beginning-position)
(line-end-position)))
+ (error
+ nil)
+ ))))
+
+ ;; We have to kill the process to delete the database. If we are
+ ;; not deleting the db, this is an easy way to refresh everything
+ ;; else.
+ (gpr-query-kill-session session)
+ (when (and db-filename
+ (file-exists-p db-filename))
+ (delete-file db-filename))
+
+ ;; recreate session from newly parsed project
+ (setq gpr-query--sessions (delete (cons gpr-file session)
gpr-query--sessions))
+
+ (setq session (gpr-query-cached-session project))
+ (message "project cache refreshed")
+ ))
+
+(defun gpr-query-refresh-lite ()
+ "Send a refresh command to the current gpr-query process."
+ (interactive)
+ (let* ((project (project-current))
+ (session (gpr-query-cached-session project))
+ (process (gpr-query--session-xref-process session)))
+
+ (process-send-string process "refresh\n")
+ (gpr-query-session-wait session 'xref)
+ (message "gpr_query refreshed")
+ ))
+
+(eval-and-compile
+ (when (version< emacs-version "28.0.60")
+ ;; WORKAROUND: in emacs 28 xref-location changed from defclass to
+ ;; cl-defstruct.
+ (require 'eieio)
+ (with-suppressed-warnings ;; "unknown slot" in emacs 28
+ (progn
+ (defun xref-item-summary (item) (oref item summary))
+ (defun xref-item-location (item) (oref item location))
+ (defun xref-file-location-file (location) (oref location file))
+ (defun xref-file-location-line (location) (oref location line))
+ (defun xref-file-location-column (location) (oref location column))
+ ))))
+
+(defun gpr-query-tree-refs (project item op)
+ "Run gpr_query tree command OP on ITEM (an xref-item), return list of
xref-items."
+ (let ((summary (xref-item-summary item))
+ (location (xref-item-location item))
+ (eieio-skip-typecheck t)) ;; 'location' may have line, column nil
+ (let ((file (xref-file-location-file location))
+ (line (xref-file-location-line location))
+ (column (xref-file-location-column location)))
+
+ (when (eq ?\" (aref summary 0))
+ ;; gpr_query wants the quotes stripped
+ (when column (setq column (+ 1 column)))
+ (setq summary (substring summary 1 (1- (length summary)))))
+
+ (let ((cmd (format "%s %s:%s:%s:%s full_file_names"
+ op
+ summary
+ (file-name-nondirectory file)
+ (or line "")
+ (if column (1+ column) "")))
+ (result nil)
+ (session (gpr-query-cached-session project)))
+
+ (with-current-buffer (gpr-query--session-send session cmd t)
+ ;; 'gpr_query tree_*' returns a list containing the declarations,
+ ;; bodies, and references (classwide), in no particular order.
+ ;;
+ ;; the format of each line is file:line:column (type)
+ ;; 1 2 3 4
+ ;;
+ ;; 'type' includes the type name
+
+ (goto-char (point-min))
+
+ (while (not (eobp))
+ (cond
+ ((looking-at gpr-query-ident-file-type-regexp)
+ ;; process line
+ (let ((found-file (match-string 1))
+ (found-line (string-to-number (match-string 2)))
+ (found-col (1- (string-to-number (match-string 3))))
+ (found-type (match-string 4))
+ )
+
+ (unless found-file
+ ;; Can be nil if actual file is renamed but gpr-query
+ ;; database not updated. We abort, rather than just
+ ;; ignoring this entry, because it means other ref are
+ ;; probably out of date as well.
+ (user-error "file '%s' not found; refresh?" (match-string 1)))
+
+ (setq found-file (gpr-query--normalize-filename found-file))
+
+ (push (xref-make
+ (cond
+ ((string= op "tree_refs")
+ (if found-type
+ (if (string-match ";" found-type)
+ ;; ref is to the identifier
+ (concat summary " " found-type)
+ ;; ref is to the controlling type of the
identifier
+ found-type)
+ summary))
+
+ ((string= op "tree_defs")
+ found-type)
+ )
+ (xref-make-file-location found-file found-line
found-col))
+ result)
+ ))
+
+ (t ;; ignore line
+ ;;
+ ;; This skips GPR_PROJECT_PATH and echoed command at start of
buffer.
+ ;;
+ ;; It also skips warning lines.
+ )
+ )
+ (forward-line 1)
+ )
+
+ (when (null result)
+ (user-error "gpr_query did not return any references; refresh?"))
+
+ (nreverse result) ;; root of tree first.
+ )))))
+
+(cl-defmethod wisi-xref-completion-table ((_xref gpr-query-xref) project)
+ (let ((session (gpr-query-cached-session project)))
+ (unless (consp (gpr-query--session-symbol-locs session))
+ (gpr-query-session-wait session 'symbols));; ensure symbol-locs is ready
+ (gpr-query--session-symbol-locs session)))
+
+(cl-defmethod wisi-xref-completion-delim-regex ((_xref gpr-query-xref))
+ (concat "[_(.<>*]"))
+
+(cl-defmethod wisi-xref-completion-regexp ((_xref gpr-query-xref))
+ gpr-query-completion-regexp)
+
+(cl-defmethod wisi-xref-completion-at-point-table ((_xref gpr-query-xref)
project)
+ (let ((session (gpr-query-cached-session project)))
+ ;; no wait for symbols to be ready; this is supposed to be fast
+ (gpr-query--session-symbols session)))
+
+(cl-defmethod wisi-xref-definitions ((_xref gpr-query-xref) project item)
+ (gpr-query-tree-refs project item "tree_defs"))
+
+(cl-defmethod wisi-xref-references ((_xref gpr-query-xref) project item)
+ (gpr-query-tree-refs project item "tree_refs"))
+
+(cl-defmethod wisi-xref-other ((_xref gpr-query-xref) project &key identifier
filename line column)
+ (when (eq ?\" (aref identifier 0))
+ ;; gpr_query wants the quotes stripped
+ (setq column (+ 1 column))
+ (setq identifier (substring identifier 1 (1- (length identifier))))
+ )
+
+ (let ((temp filename))
+
+ (unless (file-name-absolute-p temp)
+ (setq temp (locate-file filename compilation-search-path)))
+
+ (if temp
+ (setq filename temp)
+ (user-error "'%s' not found in current project - renamed?" filename)))
+
+ (setq filename (gpr-query--normalize-filename filename))
+
+ (let ((cmd (format "refs %s:%s:%s:%s global full_file_names"
+ identifier
+ (file-name-nondirectory filename)
+ (or line "")
+ (if column (1+ column) "")))
+ (decl-loc nil)
+ (body-loc nil)
+ (search-type nil)
+ (min-distance most-positive-fixnum)
+ (result nil)
+ (session (gpr-query-cached-session project)))
+
+ (with-current-buffer (gpr-query--session-send session cmd t)
+ ;; 'gpr_query refs' returns a list containing the declaration,
+ ;; the body, and all the references, in no particular order.
+ ;;
+ ;; We search the list, looking for the input location,
+ ;; declaration and body, then return the declaration or body as
+ ;; appropriate.
+ ;;
+ ;; the format of each line is file:line:column (type)
+ ;; 1 2 3 4
+ ;;
+ ;; 'type' can be:
+ ;; body
+ ;; declaration
+ ;; full declaration (for a private type)
+ ;; implicit reference
+ ;; reference
+ ;; static call
+ ;;
+ ;;
Module_Type:/home/Projects/GDS/work_stephe_2/common/1553/gds-hardware-bus_1553-wrapper.ads:171:9
(full declaration)
+ ;;
+ ;;
itc_assert:/home/Projects/GDS/work_stephe_2/common/itc/opsim/itc_dscovr_gdsi/Gds1553/src/Gds1553.cpp:830:9
(reference)
+
+ (message "parsing result ...")
+
+ (goto-char (point-min))
+
+ (while (not (eobp))
+ (cond
+ ((looking-at gpr-query-ident-file-type-regexp)
+ ;; process line
+ (let* ((found-file (match-string 1))
+ (found-line (string-to-number (match-string 2)))
+ (found-col (string-to-number (match-string 3)))
+ (found-type (match-string 4))
+ (dist (if (and line column)
+ (gpr-query-dist found-line line found-col
column)
+ most-positive-fixnum))
+ )
+
+ (unless found-file
+ ;; can be nil if actual file is renamed but gpr-query database
not updated
+ (user-error "file '%s' not found; refresh?" (match-string 1)))
+
+ (setq found-file (gpr-query--normalize-filename found-file))
+
+ (cond
+ ((string-equal found-type "declaration")
+ (setq decl-loc (list found-file found-line (1- found-col))))
+
+ ((or
+ (string-equal found-type "body")
+ (string-equal found-type "full declaration"))
+ (setq body-loc (list found-file found-line (1- found-col))))
+ )
+
+ (when (and (equal found-file filename)
+ (or
+ (string-equal found-type "body")
+ (string-equal found-type "full declaration")
+ (string-equal found-type "declaration"))
+ (<= dist min-distance))
+ ;; The source may have changed since the xref database
+ ;; was computed, so allow for fuzzy matches.
+ (setq min-distance dist)
+ (setq search-type found-type))
+ ))
+
+ (t ;; ignore line
+ ;;
+ ;; This skips GPR_PROJECT_PATH and echoed command at start of buffer.
+ ;;
+ ;; It also skips warning lines. For example,
+ ;; gnatcoll-1.6w-20130902 can't handle the Auto_Text_IO
+ ;; language, because it doesn't use the gprconfig
+ ;; configuration project. That gives lines like:
+ ;;
+ ;; common_text_io.gpr:15:07: language unknown for
"gds-hardware-bus_1553-time_tone.ads"
+ ;;
+ ;; There are probably other warnings that might be reported as well.
+ )
+ )
+ (forward-line 1)
+ )
+
+ (cond
+ ((and
+ line
+ (string-equal search-type "declaration")
+ body-loc)
+ ;; We started the search on the declaration; find the body
+ (setq result body-loc))
+
+ ((and
+ (not line)
+ (string-equal search-type "declaration"))
+ ;; We started in the spec file; find the declaration
+ ;;
+ ;; If the file has both declaration and body, this will go to
+ ;; declaration. Then a search with line, column can go to body.
+ (setq result decl-loc))
+
+ ((and
+ (not line)
+ (or
+ (string-equal search-type "body")
+ (string-equal search-type "full declaration")))
+ ;; We started n the body file; find the body
+ (setq result body-loc))
+
+ (decl-loc
+ (setq result decl-loc))
+ )
+
+ (when (null result)
+ (user-error "gpr_query did not return other item; refresh?"))
+
+ (message "parsing result ... done")
+ result)))
+
+(cl-defmethod wisi-xref-parents ((_xref gpr-query-xref) project &key
identifier filename line column)
+ (gpr-query-compilation project identifier filename line column
"parent_types" 'gpr-query-ident-file))
+
+(cl-defmethod wisi-xref-all ((_xref gpr-query-xref) project &key identifier
filename line column local-only append)
+ (gpr-query-compilation project identifier filename line column "refs"
'gpr-query-ident-file local-only append))
+
+(cl-defmethod wisi-xref-overriding ((_xref gpr-query-xref) project &key
identifier filename line column)
+ (gpr-query-compilation project identifier filename line column "overriding"
'gpr-query-ident-file))
+
+(cl-defmethod wisi-xref-overridden ((_xref gpr-query-xref) project &key
identifier filename line column)
+ (when (eq ?\" (aref identifier 0))
+ ;; gpr_query wants the quotes stripped
+ (setq column (+ 1 column))
+ (setq identifier (substring identifier 1 (1- (length identifier))))
+ )
+
+ (let ((cmd (format "overridden %s:%s:%d:%d %s"
+ identifier (file-name-nondirectory filename) line (1+
column)
+ (if wisi-xref-full-path "full_file_names"
"short_file_names")))
+ (session (gpr-query-cached-session project))
+ result)
+ (with-current-buffer (gpr-query--session-send session cmd t)
+
+ (goto-char (point-min))
+ (while (and (not result)
+ (not (eobp)))
+ (cond
+ ((looking-at wisi-file-line-col-regexp)
+ (setq result
+ (list
+ (match-string 1)
+ (string-to-number (match-string 2))
+ (string-to-number (match-string 3)))))
+
+ (t
+ (forward-line))
+ ))
+
+ (when (null result)
+ (user-error "gpr_query did not return a result; refresh?"))
+
+ (message "parsing result ... done")
+ result)))
+
+(add-to-list 'compilation-error-regexp-alist-alist
+ (cons 'gpr-query-ident-file gpr-query-ident-file-regexp-alist))
+
+(provide 'gpr-query)
+;;; end of file
diff --git a/gpr-query.prj b/gpr-query.prj
new file mode 100644
index 0000000000..d651ebeb6c
--- /dev/null
+++ b/gpr-query.prj
@@ -0,0 +1,2 @@
+gpr_file=emacs_gpr_query.gpr
+casing=gpr-query.casing
diff --git a/gpr-query.texi b/gpr-query.texi
new file mode 100644
index 0000000000..59a870a023
--- /dev/null
+++ b/gpr-query.texi
@@ -0,0 +1,212 @@
+\input texinfo @c -*-texinfo-*-
+@settitle gpr-query
+
+@copying
+Copyright @copyright{} 2022 Free Software Foundation, Inc.
+
+@quotation
+Permission is granted to copy, distribute and/or modify this document
+under the terms of the GNU Free Documentation License, Version 1.3 or
+any later version published by the Free Software Foundation; with no
+Invariant Sections, with the Front-Cover texts being ``A GNU Manual'',
+and with the Back-Cover Texts as in (a) below. A copy of the license
+is included in the section entitled ``GNU Free Documentation License''.
+
+(a) The FSF's Back-Cover Text is: ``You have the freedom to copy and
+modify this GNU manual. Buying copies from the FSF supports it in
+developing GNU and promoting software freedom.''
+@end quotation
+@end copying
+
+@dircategory Emacs
+@direntry
+* gpr-query: (gpr-query). Minor mode providing cross-reference
information from the GNAT compiler.
+@end direntry
+
+@titlepage
+@sp 10
+@title gpr-query Version 1.0.1
+@page
+@vskip 0pt plus 1filll
+@insertcopying
+@end titlepage
+
+@contents
+
+@ifnottex
+@node Top, Overview, (dir), (dir)
+@top Top
+
+gpr-query Version 1.0.1
+
+@node Overview
+@chapter Overview
+
+gpr-query is an Emacs minor mode that provides an xref backend using
+cross-reference information output by the GNAT compiler. It uses an
+external program @code{gpr_query} to interface to the information.
+
+It can also be used with the wisi package, as ada-mode does.
+
+@code{gpr_query} is similar to the AdaCore utility @code{gnatxref},
+but supports additional queries.
+
+When @code{gpr_query} reads the compiler output, it caches the results in a
+database. As the code is edited and compiled, that database gets out
+of date. It can be refreshed by invoking @key{C-c C-q}, which is bound
+to @code{wisi-refresh-prj-cache}.
+
+@node Installation
+@chapter Installation
+
+The easiest way to install @code{gpr_query} is via the Ada package
+mangager Alire. You can also install the required libraries manually,
+and then build @code{gpr_query} manually.
+
+If you are building with Alire, and planning to use gpr-query with the
+system Ada compiler (ie, not one provided by Alire), then you must
+first tell Alire to use that compiler to compile and install
+gpr-query. To do this:
+@example
+alr toolchain --select --local gnat_external
+@end example
+
+Sometimes Alire does not properly detect a corresponding external
+gprbuild; then you must use the toolchain assistant:
+@example
+alr toolchain --select --local
+@end example
+
+You can also install a compiler provided by Alire in an external
+directory, to be used outside Alire:
+@example
+alr toolchain --install --install-dir $HOME/.local gnat_native
+alr toolchain --install --install-dir $HOME/.local gprbuild
+@end example
+
+Then add the installed @code{bin} directories to your @code{PATH}.
+
+
+In any case, after installing the gpr-query ELPA package:
+@example
+cd ~/.emacs.d/elpa/gpr-query-1.0.x
+./build.sh
+./install.sh
+@end example
+
+Both scripts will use Alire if @code{alr} is found in @code{PATH};
+otherwise, they use @code{gprbuild} and @code{gprinstall}.
+
+By default, @file{install.sh} installs the parser executable in the
+same directory as the GNAT executable (using @file{gprinstall}),
+because it depends on data output by the compiler, which can change
+with the compiler version. If you don't have write privileges there,
+or if you want to install somewhere else, use @code{install.sh
+--prefix=<dir>}.
+
+When building manually, @code{gpr_query} requires the @code{GNATCOLL}
+library provided by AdaCore, distributed with GNAT GPL 2017 or later,
+and also available at Github
+(@url{https://github.com/AdaCore/gnatcoll}). The parser builds with
+the gnatcoll distributed with the gnat compiler. However, that
+gnatcoll does not include the xref package, which is required by
+@code{gpr_query}. So we must build gnatcoll xref from sources
+downloaded from github.
+
+The notes below assume that the compiler is installed at
+@file{$prefix}, e.g. @file{/usr/local/gnat-2019}, and that
+@file{$prefix/bin} is first on the @code{PATH}. If you are running
+Windows, use mingw64 @code{bash} to run these commands.
+
+On some operating systems, we must install gnatcoll-iconv; other
+operating systems don't need it.
+
+In general, @code{gpr_query} should be compiled with the compiler
+version that is used to generate the user project @file{.ali} files;
+the @file{ali} file format can change with each compiler
+version. @code{gpr_query} creates a database of cross reference
+information; that database must be deleted if the compiler version
+changes, to force a complete rebuild.
+
+@file{gpr_query} requires the @code{pthread} library. On Windows, this
+is available in Mingw64 as package
+@code{mingw64/mingw-w64-x86_64-winpthreads-git}.
+
+@menu
+* Building GNATCOLL::
+* Building the executables::
+@end menu
+
+@node Building GNATCOLL
+@subsection Building GNATCOLL
+
+The GNAT Community and GNAT pro binary installs have some of the
+GNATCOLL packages we need, but we need to install others from source.
+
+Debian 11 provides binary packages for the GNATCOLL packages we need;
+@table @samp
+@item libgnatcoll-db-bin
+@item libgnatcoll-iconv20-dev
+@item libgnatcoll-sql4-dev
+@item libgnatcoll-sqlite20-dev
+@item libgnatcoll-xref21-dev
+@end table
+
+Debian does not provide a binary for gnatstub.
+
+If you are using GNAT Community, download gnatcoll-db from
+@url{https://github.com/AdaCore/gnatcoll-db}; select the latest
+release branch (or the one that matches your compiler), click on the
+``clone or download'' button, select ``Download ZIP''.
+
+If you are using GNAT Pro, download @file{gnatcoll-db.tar.gz} from the
+GNAT Studio sources in GNAT Tracker.
+
+Similarly, if needed for your OS, download gnatcoll-bindings from the
+GNAT Community sources. This is for gnatcoll-iconv; not needed on
+Windows.
+
+@c debian/comm-2020 requires gnatcoll-iconv
+@c debian/pro-21.1 requires gnatcoll-iconv
+
+Then unpack, build, and install the required components. If you are
+unsure whether you need to install iconv, skip that step; a later step
+will complain if it is needed.
+
+If @code{./setup.py} complains it can't find @code{python}, try
+@code{python3 setup.py ...}.
+
+For github gnatcoll-db version 21.2, apply gnatcoll-2021-sql.diff.
+
+@example
+unzip ~/Downloads/gnatcoll-bindings-22.2.zip
+cd gnatcoll-bindings-22.2
+cd iconv
+./setup.py build
+./setup.py install
+
+unzip ~/Downloads/gnatcoll-db-22.2.zip
+cd gnatcoll-db-22.2
+make -C sql
+make -C sql install
+make -C sqlite
+make -C sqlite install
+make -C xref
+make -C xref install
+@end example
+
+@c To build gnatcoll-core with debug, edit the corresponding gpr file
+@c to delete @code{-gnatwe} (there are lots of warnings about license
+@c incompatibility, and a few other things). Then _do not_ build or
+@c install; just setup to create the .gpr files. Installing causes
+@c lots of spurious warnings about files need to be
+@c recompiled. Uninstall core, sql, sqlite, xref; add the build
+@c directories to GPR_PROJECT_PATH, add @code{BUILD=DEBUG} to the
+@c command line, edit the .gpr files to set OS. Sigh; that still
+@c doesn't work.
+
+@node GNU Free Documentation License
+@appendix GNU Free Documentation License
+@include doclicense.texi
+
+@end ifnottex
diff --git a/gpr_query.adb b/gpr_query.adb
new file mode 100644
index 0000000000..cff8b0f7fd
--- /dev/null
+++ b/gpr_query.adb
@@ -0,0 +1,1380 @@
+-- Abstract :
+--
+-- Support Emacs Ada mode and gpr-query minor mode queries about
+-- GNAT projects and cross reference data
+--
+-- Copyright (C) 2014 - 2022 Free Software Foundation All Rights Reserved.
+--
+-- This program is free software; you can redistribute it and/or
+-- modify it under terms of the GNU General Public License as
+-- published by the Free Software Foundation; either version 3, 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
+-- distributed with this program; see file COPYING. If not, write to
+-- the Free Software Foundation, 51 Franklin Street, Suite 500, Boston,
+-- MA 02110-1335, USA.
+
+pragma License (GPL);
+
+with Ada.Characters.Handling;
+with Ada.Command_Line;
+with Ada.Directories;
+with Ada.Environment_Variables;
+with Ada.Exceptions.Traceback;
+with Ada.IO_Exceptions;
+with Ada.Strings.Fixed;
+with Ada.Strings.Unbounded;
+with Ada.Text_IO;
+with GNAT.Command_Line;
+with GNAT.Directory_Operations;
+with GNAT.OS_Lib;
+with GNAT.Strings;
+with GNAT.Traceback.Symbolic;
+with GNATCOLL.Arg_Lists;
+with GNATCOLL.Paragraph_Filling;
+with GNATCOLL.Projects;
+with GNATCOLL.SQL.Exec;
+with GNATCOLL.SQL.Sqlite;
+with GNATCOLL.Traces;
+with GNATCOLL.Utils;
+with GNATCOLL.VFS;
+with GNATCOLL.VFS_Utils;
+with GNATCOLL.Xref;
+procedure Gpr_Query is
+ use all type GNATCOLL.VFS.File_Array;
+ use GNATCOLL;
+
+ Version : constant String := "3";
+ -- Changes once per release when the API (commands and responses)
+ -- changes; must match gpr-query.el gpr-query-protocol-version
+
+ Me : constant GNATCOLL.Traces.Trace_Handle := GNATCOLL.Traces.Create
("gpr_query");
+ -- See gnatcoll-xref.adb for xref traces.
+
+ DB_Error : exception;
+ Invalid_Command : exception;
+
+ function "+" (Item : in Ada.Strings.Unbounded.Unbounded_String) return
String
+ renames Ada.Strings.Unbounded.To_String;
+
+ function "+" (Item : in String) return
Ada.Strings.Unbounded.Unbounded_String
+ renames Ada.Strings.Unbounded.To_Unbounded_String;
+
+ function "+" (Item : in GNATCOLL.VFS.Filesystem_String) return String
+ is begin
+ return String (Item);
+ end "+";
+
+ procedure Process_Line (Line : String);
+ -- Process a full line of commands.
+ -- Raise Invalid_Command when the command is invalid.
+
+ function Get_Entity (Arg : String) return GNATCOLL.Xref.Entity_Information;
+ -- Return the entity matching the "name:file:line[:column]" argument
+
+ type My_Xref_Database is new GNATCOLL.Xref.Xref_Database with null record;
+ -- Derived so we can override Image to output full paths
+
+ Short_File_Names : Boolean; -- set by each command that calls Image
+ -- Full_File_Names_Arg : constant String := "full_file_names";
+ Short_File_Names_Arg : constant String := "short_file_names";
+
+ overriding function Image (Self : My_Xref_Database; File :
GNATCOLL.VFS.Virtual_File) return String;
+ function Image (Self : GNATCOLL.Xref.Entity_Information) return String;
+ -- Return a display version of the argument
+
+ Xref : aliased My_Xref_Database;
+ Env : GNATCOLL.Projects.Project_Environment_Access;
+ Tree : aliased GNATCOLL.Projects.Project_Tree;
+ Source_Search_Path : GNATCOLL.VFS.File_Array_Access;
+
+ Previous_Progress : Natural := 0;
+ Progress_Reporter : access procedure (Current, Total : Integer) := null;
+
+ -- Subprogram specs for subprograms used before bodies
+ procedure Check_Arg_Count (Args : in GNATCOLL.Arg_Lists.Arg_List; Expected
: in Integer);
+ procedure Dump (Curs : in out GNATCOLL.Xref.Entities_Cursor'Class);
+ procedure Dump (Refs : in out GNATCOLL.Xref.References_Cursor'Class;
Controlling_Type_Name : in String := "");
+ procedure Dump_Local (Refs : in out GNATCOLL.Xref.References_Cursor'Class;
Local_File_Name : in String);
+ -- Display the results of a query
+
+ procedure Put (Item : GNATCOLL.VFS.File_Array);
+
+ generic
+ with function Compute
+ (Self : in GNATCOLL.Xref.Xref_Database'Class;
+ Entity : in GNATCOLL.Xref.Entity_Information)
+ return GNATCOLL.Xref.Entity_Information;
+ procedure Process_Command_Single (Args : GNATCOLL.Arg_Lists.Arg_List);
+ -- Get the entity identified by Args, which must contain a single
+ -- argument. Then call Compute, and output the result.
+ --
+ -- Appropriate for queries that return a single entity result.
+
+ procedure Process_Command_Single (Args : GNATCOLL.Arg_Lists.Arg_List)
+ is
+ use GNATCOLL.Arg_Lists;
+ use GNATCOLL.Xref;
+
+ Entity : Entity_Information;
+ Comp : Entity_Information;
+ begin
+ Check_Arg_Count (Args, 2);
+
+ Short_File_Names := Nth_Arg (Args, 2) = Short_File_Names_Arg;
+
+ Entity := Get_Entity (Nth_Arg (Args, 1));
+ Comp := Compute (Xref, Entity);
+ if Comp /= No_Entity then
+ Ada.Text_IO.Put_Line (Image (Comp));
+ end if;
+ end Process_Command_Single;
+
+ generic
+ with procedure Compute
+ (Self : in GNATCOLL.Xref.Xref_Database'Class;
+ Entity : in GNATCOLL.Xref.Entity_Information;
+ Cursor : out GNATCOLL.Xref.Entities_Cursor'Class);
+ procedure Process_Command_Multiple (Args : GNATCOLL.Arg_Lists.Arg_List);
+
+ procedure Process_Command_Multiple (Args : GNATCOLL.Arg_Lists.Arg_List)
+ is
+ use GNATCOLL.Arg_Lists;
+ use GNATCOLL.Xref;
+
+ Entity : Entity_Information;
+ Descendants : Recursive_Entities_Cursor;
+
+ -- Apparently a generic formal parameter cannot match a subprogram
access type, so we need this:
+ procedure Do_Compute
+ (Self : in GNATCOLL.Xref.Xref_Database'Class;
+ Entity : in GNATCOLL.Xref.Entity_Information;
+ Cursor : out GNATCOLL.Xref.Entities_Cursor'Class)
+ is begin
+ Compute (Self, Entity, Cursor);
+ end Do_Compute;
+ begin
+ Check_Arg_Count (Args, 2);
+
+ Short_File_Names := Nth_Arg (Args, 2) = Short_File_Names_Arg;
+
+ Entity := Get_Entity (Nth_Arg (Args, 1));
+
+ Recursive
+ (Self => Xref'Unchecked_Access,
+ Entity => Entity,
+ Compute => Do_Compute'Unrestricted_Access,
+ Cursor => Descendants);
+
+ Dump (Descendants);
+
+ end Process_Command_Multiple;
+
+ -- Command procedures; Args is the command line.
+ --
+ -- Infrastructure commands
+ procedure Process_Help (Args : GNATCOLL.Arg_Lists.Arg_List);
+ procedure Process_Refresh (Args : GNATCOLL.Arg_Lists.Arg_List);
+ procedure Process_DB_Name (Args : GNATCOLL.Arg_Lists.Arg_List);
+
+ -- Queries; alphabetical
+ procedure Process_Complete (Args : GNATCOLL.Arg_Lists.Arg_List);
+ procedure Process_Overridden is new Process_Command_Single
(GNATCOLL.Xref.Overrides);
+ procedure Process_Overriding is new Process_Command_Multiple
(GNATCOLL.Xref.Overridden_By);
+ procedure Process_Parent_Types is new Process_Command_Multiple
(GNATCOLL.Xref.Parent_Types);
+ procedure Process_Project_Path (Args : GNATCOLL.Arg_Lists.Arg_List);
+ procedure Process_Refs (Args : GNATCOLL.Arg_Lists.Arg_List); --
wisi-xref-all
+ procedure Process_Tree_Defs (Args : GNATCOLL.Arg_Lists.Arg_List); --
wisi-xref-definitions
+ procedure Process_Tree_Refs (Args : GNATCOLL.Arg_Lists.Arg_List); --
wisi-xref-references
+ procedure Process_Source_Dirs (Args : GNATCOLL.Arg_Lists.Arg_List);
+
+ type Command_Descr is record
+ Name : GNAT.Strings.String_Access;
+ Args : GNAT.Strings.String_Access;
+ Help : GNAT.Strings.String_Access;
+ Handler : not null access procedure (Args : GNATCOLL.Arg_Lists.Arg_List);
+ end record;
+
+ Commands : constant array (Natural range <>) of Command_Descr :=
+ ((new String'("help"),
+ new String'("[command or variable name]"),
+ new String'("Display the list of commands and their syntax."),
+ Process_Help'Access),
+
+ (new String'("refresh"),
+ null,
+ new String'("Refresh the contents of the xref database."),
+ Process_Refresh'Access),
+
+ (new String'("db_name"),
+ null,
+ new String'("Report the root name of the database files."),
+ Process_DB_Name'Access),
+
+ -- queries
+
+ (new String'("complete"),
+ new String'("pattern"),
+ new String'("Names that complete the pattern."),
+ Process_Complete'Access),
+
+ (new String'("overridden"),
+ new String'("name:file:line[:column] {full_file_names |
short_file_names}"),
+ new String'("The entity that is overridden by the parameter"),
+ Process_Overridden'Access),
+
+ (new String'("overriding"),
+ new String'("name:file:line[:column] {full_file_names |
short_file_names}"),
+ new String'("The entities that override the parameter"),
+ Process_Overriding'Access),
+
+ (new String'("parent_types"),
+ new String'("name:file:line[:column] {full_file_names |
short_file_names}"),
+ new String'("The parent types of the entity."),
+ Process_Parent_Types'Access),
+
+ (new String'("project_path"),
+ null,
+ new String'("The project search path."),
+ Process_Project_Path'Access),
+
+ (new String'("refs"),
+ new String'("name:file:line[:column] {global | local_only}
{full_file_names | short_file_names}"),
+ new String'("All known references to the entity."),
+ Process_Refs'Access),
+
+ (new String'("tree_defs"),
+ new String'("name:file[:line[:column]] {full_file_names |
short_file_names}"),
+ new String'
+ ("All known references to the entity, and to child types or
overridden/overriding operations."),
+ Process_Tree_Defs'Access),
+
+ (new String'("tree_refs"),
+ new String'("name:file:line[:column] {full_file_names |
short_file_names}"),
+ new String'
+ ("All known references to the entity, and to parent/child types or
overridden/overriding operations."),
+ Process_Tree_Refs'Access),
+
+ (new String'("source_dirs"),
+ null,
+ new String'("The project source directories, recursively."),
+ Process_Source_Dirs'Access));
+
+ -- Parsed command line info
+ Cmdline : GNAT.Command_Line.Command_Line_Configuration;
+
+ ALI_Encoding : aliased GNAT.Strings.String_Access := new
String'("");
+ Commands_From_Switch : aliased GNAT.Strings.String_Access;
+ DB_Name : aliased GNAT.Strings.String_Access := new
String'("gpr_query.db");
+ Force_Refresh : aliased Boolean;
+ Gpr_Config_File : aliased GNAT.Strings.String_Access;
+ Nightly_DB_Name : aliased GNAT.Strings.String_Access;
+ Project_File_Name : aliased GNAT.Strings.String_Access;
+ Show_Progress : aliased Boolean;
+ Traces_Config_File : aliased GNAT.Strings.String_Access;
+
+ ----------
+ -- Procedure bodies, alphabetical
+
+ procedure Check_Arg_Count (Args : in GNATCOLL.Arg_Lists.Arg_List; Expected
: in Integer)
+ is
+ Count : constant Integer := GNATCOLL.Arg_Lists.Args_Length (Args);
+ begin
+ if Count /= Expected then
+ raise Invalid_Command with "Invalid number of arguments" &
Integer'Image (Count) &
+ "; expecting" & Integer'Image (Expected);
+ end if;
+ end Check_Arg_Count;
+
+ procedure Display_Progress (Current, Total : Integer) is
+ Now : constant Integer := Integer (Float'Floor (Float (Current) / Float
(Total) * 100.0));
+ begin
+ if Now /= Previous_Progress then
+ Ada.Text_IO.Put_Line
+ ("completed" & Current'Img
+ & " out of" & Total'Img
+ & " (" & GNATCOLL.Utils.Image (Now, Min_Width => 0) & "%)...");
+ Previous_Progress := Now;
+ end if;
+ end Display_Progress;
+
+ procedure Dump (Curs : in out GNATCOLL.Xref.Entities_Cursor'Class)
+ is
+ use GNATCOLL.Xref;
+ begin
+ while Curs.Has_Element loop
+ Ada.Text_IO.Put_Line (Image (Curs.Element));
+ Curs.Next;
+ end loop;
+ end Dump;
+
+ procedure Dump (Refs : in out GNATCOLL.Xref.References_Cursor'Class;
Controlling_Type_Name : in String := "")
+ is
+ use GNATCOLL.Xref;
+ begin
+ while Has_Element (Refs) loop
+ declare
+ Ref : constant Entity_Reference := Refs.Element;
+ begin
+ Ada.Text_IO.Put_Line
+ (Xref.Image (Ref) & " (" &
+ (if Controlling_Type_Name'Length = 0
+ then ""
+ else Controlling_Type_Name & "; ") &
+ (+Ref.Kind) & ")");
+ end;
+ Next (Refs);
+ end loop;
+ end Dump;
+
+ procedure Dump_Local (Refs : in out GNATCOLL.Xref.References_Cursor'Class;
Local_File_Name : in String)
+ is
+ use GNATCOLL.Xref;
+ begin
+ while Has_Element (Refs) loop
+ declare
+ Ref : constant Entity_Reference := Refs.Element;
+ begin
+ if Local_File_Name = "" or else Local_File_Name =
Ref.File.Display_Base_Name then
+ Ada.Text_IO.Put_Line (Xref.Image (Ref) & " (" & (+Ref.Kind) &
")");
+ end if;
+ end;
+ Next (Refs);
+ end loop;
+ end Dump_Local;
+
+ function Get_Entity (Arg : String) return GNATCOLL.Xref.Entity_Information
+ is
+ use GNAT.Directory_Operations;
+ use GNATCOLL.Xref;
+
+ Words : GNAT.Strings.String_List_Access := GNATCOLL.Utils.Split (Arg, On
=> ':');
+ Ref : GNATCOLL.Xref.Entity_Reference;
+ begin
+ case Words'Length is
+ when 4 =>
+ Ref := Xref.Get_Entity
+ (Name => Words (Words'First).all,
+ File => Format_Pathname
+ (Style => UNIX,
+ Path => Words (Words'First + 1).all),
+ Project => GNATCOLL.Projects.No_Project,
+ Line => Integer'Value (Words (Words'First + 2).all),
+ Column => Visible_Column
+ (Integer'Value (Words (Words'First + 3).all)));
+
+ when 3 =>
+ -- No column; assume good enough for a precise match
+ Ref := Xref.Get_Entity
+ (Name => Words (Words'First).all,
+ File => Format_Pathname
+ (Style => UNIX,
+ Path => Words (Words'First + 1).all),
+ Project => GNATCOLL.Projects.No_Project,
+ Line => Integer'Value (Words (Words'First + 2).all));
+
+ when 2 =>
+ -- No line or column; error.
+ GNAT.Strings.Free (Words);
+ raise Invalid_Command with "Invalid parameter '" & Arg & "',
expecting name:file:line[:column]]";
+
+ when others =>
+ -- No file, or bad args.
+ --
+ -- Xref.Get_Entity treats 'File => ""' as searching for pre-defined
entities such as "Integer".
+ --
+ -- To search for a name in all files, use "complete" command.
+ GNAT.Strings.Free (Words);
+
+ raise Invalid_Command with "Invalid parameter '" & Arg & "',
expecting name:file:line[:column]]";
+ end case;
+
+ GNAT.Strings.Free (Words);
+
+ if Ref.Entity = GNATCOLL.Xref.No_Entity then
+ Ada.Text_IO.Put_Line ("Error: entity not found '" & Arg & "'");
+
+ elsif GNATCOLL.Xref.Is_Fuzzy_Match (Ref.Entity) then
+ Ada.Text_IO.Put_Line ("warning: fuzzy match for the entity");
+ end if;
+
+ return Ref.Entity;
+ end Get_Entity;
+
+ overriding function Image (Self : My_Xref_Database; File :
GNATCOLL.VFS.Virtual_File) return String
+ is
+ pragma Unreferenced (Self);
+ begin
+ if Short_File_Names then
+ return File.Display_Base_Name;
+ else
+ return File.Display_Full_Name;
+ end if;
+ end Image;
+
+ function Image (Self : GNATCOLL.Xref.Entity_Information) return String
+ is
+ use GNATCOLL.Xref;
+ begin
+ if Self = No_Entity then
+ return "Unknown entity";
+ else
+ declare
+ Decl : constant Entity_Declaration := Xref.Declaration (Self);
+ begin
+ if Is_Predefined_Entity (Decl) then
+ return "predefined entity: " & (+Decl.Name);
+ else
+ return Xref.Image (Decl.Location);
+ end if;
+ end;
+ end if;
+ end Image;
+
+ procedure Process_DB_Name (Args : GNATCOLL.Arg_Lists.Arg_List)
+ is
+ pragma Unreferenced (Args);
+ begin
+ Ada.Text_IO.Put_Line (DB_Name.all);
+ end Process_DB_Name;
+
+ procedure Process_Help (Args : GNATCOLL.Arg_Lists.Arg_List)
+ is
+ use Ada.Text_IO;
+ use GNATCOLL.Arg_Lists;
+ use type GNAT.Strings.String_Access;
+ begin
+ for C in Commands'Range loop
+ if Args_Length (Args) <= 0 -- Empty_Command_Line returns -1
+ or else Nth_Arg (Args, 1) = Commands (C).Name.all
+ then
+ Put (" " & Commands (C).Name.all);
+ if Commands (C).Args = null then
+ New_Line;
+ else
+ Put_Line (" " & Commands (C).Args.all);
+ end if;
+
+ Put
+ (Ada.Strings.Unbounded.To_String
+ (GNATCOLL.Paragraph_Filling.Knuth_Fill
+ (Commands (C).Help.all,
+ Max_Line_Length => 70,
+ Line_Prefix => " ")));
+ end if;
+ end loop;
+ New_Line;
+ Put_Line ("'exit' to quit");
+ end Process_Help;
+
+ procedure Process_Line (Line : String)
+ is
+ Expr : GNAT.Strings.String_List_Access;
+ begin
+ if Ada.Strings.Fixed.Trim (Line, Ada.Strings.Both) = "" then
+ return;
+ end if;
+
+ Expr := GNATCOLL.Utils.Split (Line, On => ';');
+
+ for C in Expr'Range loop
+ if Ada.Strings.Fixed.Trim (Expr (C).all, Ada.Strings.Both) = "" then
+ null;
+
+ else
+ declare
+ use GNATCOLL.Arg_Lists;
+ List : constant Arg_List := Parse_String (Expr (C).all, Mode
=> Separate_Args);
+ Cmd : constant String := Ada.Characters.Handling.To_Lower
(Get_Command (List));
+ Found : Boolean := False;
+ begin
+ for Co in Commands'Range loop
+ if Commands (Co).Name.all = Cmd then
+ Commands (Co).Handler (List);
+ Found := True;
+ exit;
+ end if;
+ end loop;
+
+ if not Found then
+ raise Invalid_Command with "Invalid command: '" & Cmd & "'";
+ end if;
+ end;
+
+ end if;
+ end loop;
+
+ GNAT.Strings.Free (Expr);
+ end Process_Line;
+
+ function Get_Parameters (Entity : GNATCOLL.Xref.Entity_Information) return
String
+ is
+ use Ada.Strings.Unbounded;
+ use GNATCOLL.Xref;
+ Params : Parameters_Cursor := GNATCOLL.Xref.Parameters (Xref,
Entity);
+ Result : Unbounded_String;
+ Need_Paren : Boolean := True;
+ begin
+ loop
+ exit when not Has_Element (Params);
+ Result := Result &
+ ((if Need_Paren
+ then (if Length (Result) > 0 then " (" else "(")
+ else ", ") &
+ Xref.Declaration (Element (Params).Parameter).Name);
+ Need_Paren := False;
+ Next (Params);
+ end loop;
+ if not Need_Paren then
+ Result := Result & ")";
+ end if;
+ return +Result;
+ end Get_Parameters;
+
+ procedure Process_Complete (Args : GNATCOLL.Arg_Lists.Arg_List)
+ is
+ use Ada.Text_IO;
+ use GNATCOLL.Arg_Lists;
+ use GNATCOLL.Xref;
+ Prefix : constant String := Nth_Arg (Args, 1);
+ Matches : Entities_Cursor;
+ Count : Integer := 0;
+ begin
+ Short_File_Names := False;
+
+ -- First count all matches, so Emacs can show progress
+ Xref.From_Prefix
+ (Prefix,
+ Is_Partial => True,
+ Cursor => Matches);
+ loop
+ exit when not Has_Element (Matches);
+ Count := @ + 1;
+ Next (Matches);
+ end loop;
+
+ Ada.Text_IO.Put_Line ("element count" & Count'Image);
+
+ Xref.From_Prefix
+ (Prefix,
+ Is_Partial => True,
+ Cursor => Matches);
+ loop
+ exit when not Has_Element (Matches);
+ declare
+ Decl : constant Entity_Declaration := Xref.Declaration (Element
(Matches));
+ begin
+ Put (Xref.Qualified_Name (Element (Matches)));
+ if Decl.Flags.Is_Subprogram then
+ Ada.Text_IO.Put (Get_Parameters (Decl.Location.Entity));
+ end if;
+ end;
+ Ada.Text_IO.Put_Line (" " & Image (Element (Matches)));
+ Next (Matches);
+ end loop;
+ end Process_Complete;
+
+ procedure Process_Project_Path (Args : GNATCOLL.Arg_Lists.Arg_List)
+ is
+ pragma Unreferenced (Args);
+ Dirs : constant GNATCOLL.VFS.File_Array :=
GNATCOLL.Projects.Predefined_Project_Path (Env.all);
+ begin
+ Short_File_Names := False;
+ Put (Dirs);
+ end Process_Project_Path;
+
+ procedure Process_Refresh (Args : GNATCOLL.Arg_Lists.Arg_List)
+ is
+ pragma Unreferenced (Args);
+ begin
+ Parse_All_LI_Files
+ (Self => Xref,
+ Project => Tree.Root_Project,
+ Parse_Runtime_Files => False,
+ Show_Progress => Progress_Reporter,
+ ALI_Encoding => ALI_Encoding.all,
+ From_DB_Name => Nightly_DB_Name.all,
+ To_DB_Name => DB_Name.all,
+ Force_Refresh => Force_Refresh);
+ end Process_Refresh;
+
+ procedure Process_Refs (Args : GNATCOLL.Arg_Lists.Arg_List)
+ is
+ use GNATCOLL.Arg_Lists;
+ begin
+ Check_Arg_Count (Args, 3); -- entity, local/global, full/short
+
+ Short_File_Names := Nth_Arg (Args, 3) = Short_File_Names_Arg;
+
+ declare
+ use GNATCOLL.Xref;
+ Entity : constant Entity_Information := Get_Entity (Nth_Arg (Args,
1));
+ Refs : References_Cursor;
+ begin
+ Xref.References (Entity, Refs);
+ if Nth_Arg (Args, 2) = "local_only" then
+ -- Xref doesn't let us get the full file name of Entity (sigh)
+ declare
+ use Ada.Strings.Fixed;
+ First : constant Integer := 1 + Index (Nth_Arg (Args,
1), ":");
+ Last : constant Integer := -1 + Index (Nth_Arg
(Args, 1), ":", First);
+ Local_File_Name : constant String := Nth_Arg (Args, 1) (First
.. Last);
+ begin
+ Dump_Local (Refs, Local_File_Name);
+ end;
+ else
+ Dump (Refs);
+ end if;
+ end;
+ end Process_Refs;
+
+ function Has_Op
+ (Entity : in GNATCOLL.Xref.Entity_Information;
+ Primitive_Op_Name : in String := "")
+ return Boolean
+ is
+ use GNATCOLL.Xref;
+ Ops : Entities_Cursor;
+ begin
+ Xref.Methods (Entity, Ops);
+ loop
+ exit when not Has_Element (Ops);
+ if Primitive_Op_Name = +Xref.Declaration (Element (Ops)).Name then
+ return True;
+ end if;
+ Next (Ops);
+ end loop;
+ return False;
+ end Has_Op;
+
+ function Root_Parent_Type
+ (Entity : in GNATCOLL.Xref.Entity_Information;
+ Primitive_Op_Name : in String := "")
+ return GNATCOLL.Xref.Entity_Information
+ is
+ use GNATCOLL.Xref;
+ Result : Entity_Information := Entity;
+ Parents : Entities_Cursor;
+ begin
+ loop
+ Xref.Parent_Types (Result, Parents);
+ -- There is more than one parent when the type inherits interfaces.
+ -- We assume the first parent is a non-interface (if there is one),
+ -- and ignore the rest.
+ exit when (not Parents.Has_Element) or else
+ (Primitive_Op_Name'Length > 0 and then not Has_Op (Parents.Element,
Primitive_Op_Name));
+ Result := Parents.Element;
+ end loop;
+ return Result;
+ end Root_Parent_Type;
+
+ procedure All_Child_Types
+ (Entity : in GNATCOLL.Xref.Entity_Information;
+ Cursor : in out GNATCOLL.Xref.Recursive_Entities_Cursor)
+ is begin
+ GNATCOLL.Xref.Recursive
+ (Self => Xref'Unchecked_Access,
+ Entity => Entity,
+ Compute => GNATCOLL.Xref.Child_Types'Access,
+ Cursor => Cursor);
+ end All_Child_Types;
+
+ function Controlling_Type (Entity : in GNATCOLL.Xref.Entity_Information)
return GNATCOLL.Xref.Entity_Information
+ is
+ use GNATCOLL.Xref;
+ -- Method_Of returns a derived type if the subprogram is not
+ -- overridden for the child; the type we want is the non-child; the
+ -- last item in Controlling_Types.
+ Types : Entities_Cursor;
+ Result : Entity_Information := No_Entity;
+ begin
+ Xref.Method_Of (Entity, Types);
+ loop
+ exit when not Has_Element (Types);
+ Result := Types.Element;
+ Next (Types);
+ end loop;
+ return Result;
+ end Controlling_Type;
+
+ procedure Dump_Decl (Decl : in GNATCOLL.Xref.Entity_Declaration; Annotation
: in String := "")
+ is begin
+ Ada.Text_IO.Put_Line
+ (Xref.Image (Decl.Location) & " (" &
+ (+Decl.Name) & " " &
+ (if Annotation'Length = 0
+ then ""
+ else Annotation & " ") &
+ (+Decl.Kind) & ")");
+ end Dump_Decl;
+
+ procedure Dump_Ref (Ref : in GNATCOLL.Xref.Entity_Reference; Annotation :
in String := "")
+ is begin
+ Ada.Text_IO.Put_Line
+ (Xref.Image (Ref) & " (" &
+ (+Xref.Declaration (Ref.Entity).Name) & " " &
+ (if Annotation'Length = 0
+ then ""
+ else Annotation & " ") &
+ (+Ref.Kind) & ")");
+ end Dump_Ref;
+
+ procedure Dump_Entity (Entity : in GNATCOLL.Xref.Entity_Information;
Controlling_Type_Name : in String := "")
+ is
+ use Ada.Strings.Unbounded;
+ use GNATCOLL.Xref;
+ Spec_Decl : constant Entity_Declaration := Xref.Declaration (Entity);
+ Body_Decls : References_Cursor;
+ Parameters : Unbounded_String;
+ begin
+ if Controlling_Type_Name'Length > 0 then
+ Parameters := +Controlling_Type_Name & ";";
+ end if;
+
+ if Spec_Decl.Flags.Is_Subprogram then
+ Parameters := Parameters & Get_Parameters (Spec_Decl.Location.Entity);
+ end if;
+
+ Xref.Bodies (Entity, Body_Decls);
+ if not Has_Element (Body_Decls) then
+ Dump_Decl (Spec_Decl, +Parameters);
+ else
+ declare
+ use all type GNATCOLL.VFS.Virtual_File;
+ First_Body_Ref : constant Entity_Reference := Body_Decls.Element;
+ begin
+ if First_Body_Ref.File = Spec_Decl.Location.File and
+ First_Body_Ref.Line = Spec_Decl.Location.Line and
+ First_Body_Ref.Column = Spec_Decl.Location.Column
+ then
+ Ada.Text_IO.Put_Line
+ (Xref.Image (First_Body_Ref) & " (" & (+Spec_Decl.Name) & " "
&
+ (if Length (Parameters) = 0
+ then ""
+ else +Parameters & " ") &
+ (+Spec_Decl.Kind) & "/" & (+First_Body_Ref.Kind) & ")");
+ else
+ Dump_Decl (Spec_Decl, +Parameters);
+ Dump_Ref (First_Body_Ref, +Parameters);
+ end if;
+ end;
+
+ Next (Body_Decls);
+
+ loop
+ exit when not Has_Element (Body_Decls);
+ Dump_Ref (Body_Decls.Element, +Parameters);
+ Next (Body_Decls);
+ end loop;
+ end if;
+ end Dump_Entity;
+
+ procedure Process_Tree_Defs (Args : GNATCOLL.Arg_Lists.Arg_List)
+ is
+ -- "tree_defs" <name:loc> {short_file_names | full_file_names}
+
+ use GNATCOLL.Arg_Lists;
+ use GNATCOLL.Xref;
+
+ Words : GNAT.Strings.String_List_Access := GNATCOLL.Utils.Split
(Nth_Arg (Args, 1), On => ':');
+ Root_Parent : Entity_Information;
+
+ procedure One_Entity (Orig_Entity : in Entity_Information; No_Children :
in Boolean := False)
+ is
+ Orig_Decl : constant Entity_Declaration := Xref.Declaration
(Orig_Entity);
+ Orig_Short_Name : constant String := +Orig_Decl.Name;
+
+ procedure Dump_Method
+ (Type_Entity : in GNATCOLL.Xref.Entity_Information;
+ Primitive_Op_Name : in String)
+ is
+ Type_Name : constant String := Xref.Qualified_Name (Type_Entity);
+ Ops : Entities_Cursor;
+ begin
+ Xref.Methods (Type_Entity, Ops);
+ loop
+ exit when not Has_Element (Ops);
+ declare
+ Method_Name : constant String := +Xref.Declaration (Element
(Ops)).Name;
+ begin
+ if Primitive_Op_Name = Method_Name then
+ -- IMPROVEME: if the method is inherited but not
overridden, use the
+ -- type location.
+ Dump_Entity (Element (Ops), Type_Name);
+ end if;
+ end;
+ Next (Ops);
+ end loop;
+ end Dump_Method;
+
+ procedure Dump_Entities (Entities : in out Recursive_Entities_Cursor)
+ is begin
+ loop
+ exit when not Has_Element (Entities);
+ if Orig_Decl.Flags.Is_Subprogram then
+ Dump_Method (Entities.Element, Primitive_Op_Name =>
Orig_Short_Name);
+ else
+ Dump_Entity (Entities.Element);
+ end if;
+ Next (Entities);
+ end loop;
+ end Dump_Entities;
+ begin
+
+ if Orig_Decl.Flags.Is_Type then
+ -- It is tempting to find the highest ancestor type here, then
show
+ -- all types derived from that. But in Ada, that root ancestor is
+ -- often Ada.Finalization.[Limited_]Controlled (or some similar
root
+ -- type), so the tree is much larger than we really want. So we
just
+ -- show all children of the given type; the user can then climb
the
+ -- tree if they want to enlarge it. This also allows the user to
+ -- choose which anscestor to examine when there is more than one,
+ -- with interfaces.
+ Root_Parent := Orig_Entity;
+
+ elsif Orig_Decl.Flags.Is_Subprogram then
+ declare
+ Controlling : constant Entity_Information := Controlling_Type
(Orig_Entity);
+ begin
+ if Controlling = No_Entity then
+ -- Not a primitive subprogram
+ Dump_Entity (Orig_Entity);
+ return;
+ else
+ if No_Children then
+ Root_Parent := Controlling; -- for type name
+ else
+ -- Here we find the highest ancestor type that has this
method.
+ -- gnatcoll.xref does not let us get the type of each
parameter, so
+ -- we can't match profiles, just names.
+ Root_Parent := Root_Parent_Type (Controlling,
Primitive_Op_Name => Orig_Short_Name);
+ end if;
+ end if;
+ end;
+ else
+ -- Something else (variable, package, ...)
+ Dump_Decl (Orig_Decl);
+ return;
+ end if;
+
+ if No_Children then
+ if Orig_Decl.Flags.Is_Type then
+ Dump_Entity (Orig_Entity);
+ else
+ Dump_Entity (Orig_Entity, Controlling_Type_Name =>
Xref.Qualified_Name (Root_Parent));
+ end if;
+ else
+ declare
+ Child_Types : Recursive_Entities_Cursor;
+ begin
+ -- "Child_Types" includes generic formal parameters (ie
+ -- gen_run_wisi_lr_parse.ads Parse_Data_Type) in addition to
the
+ -- actual parameters.
+ All_Child_Types (Root_Parent, Child_Types);
+ if Orig_Decl.Flags.Is_Type then
+ Dump_Entity (Root_Parent);
+ else
+ Dump_Method (Root_Parent, +Orig_Decl.Name);
+ end if;
+ Dump_Entities (Child_Types);
+ end;
+ end if;
+ end One_Entity;
+
+ use GNAT.Directory_Operations;
+ begin
+ Short_File_Names := Nth_Arg (Args, 2) = Short_File_Names_Arg;
+
+ case Words'Length is
+ when 3 | 4 =>
+ One_Entity
+ (Xref.Get_Entity
+ (Name => Words (Words'First).all,
+ File => Format_Pathname
+ (Style => UNIX,
+ Path => Words (Words'First + 1).all),
+ Project => GNATCOLL.Projects.No_Project,
+ Line => Integer'Value (Words (Words'First + 2).all),
+ Column =>
+ (if Words'Length = 4
+ then Visible_Column (Integer'Value (Words (Words'First +
3).all))
+ else -1)) -- No column; assume good enough for a precise
match
+ .Entity);
+
+ when 2 =>
+ -- No line or column; find all matching names in file
+ declare
+ use GNATCOLL.VFS;
+
+ Multiple : Entities_Cursor;
+ Orig_File : constant Virtual_File := Locate_Regular_File
+ (File_Name => +Words (Words'First + 1).all,
+ Path => Source_Search_Path.all);
+ Orig_File_Name : constant Filesystem_String := Full_Name
(Orig_File);
+ begin
+ From_Prefix (Xref, Words (Words'First).all, Is_Partial => False,
Cursor => Multiple);
+
+ loop
+ exit when not Has_Element (Multiple);
+ declare
+ Decl : constant Entity_Declaration := Xref.Declaration
(Element (Multiple));
+
+ function Check_Body_File return Boolean
+ is
+ Bodies : References_Cursor;
+ begin
+ Xref.Bodies (Decl.Location.Entity, Bodies);
+ loop
+ exit when not Has_Element (Bodies);
+ declare
+ Ref : Entity_Reference renames Element (Bodies);
+ begin
+ if Orig_File_Name = Full_Name (Ref.File) then
+ return True;
+ end if;
+ end;
+ Next (Bodies);
+ end loop;
+ return False;
+ end Check_Body_File;
+
+ begin
+ if Orig_File_Name = Full_Name (Decl.Location.File) or else
+ Check_Body_File
+ then
+ One_Entity (Element (Multiple), No_Children => True);
+ end if;
+ end;
+ Next (Multiple);
+ end loop;
+ end;
+
+ when others =>
+ -- No file or bad arg.
+ GNAT.Strings.Free (Words);
+ raise Invalid_Command with "Invalid parameter '" & Nth_Arg (Args, 1) &
+ "', expecting name:file:[line[:column]]";
+ end case;
+
+ end Process_Tree_Defs;
+
+ procedure Process_Tree_Refs (Args : GNATCOLL.Arg_Lists.Arg_List)
+ is
+ -- "tree_refs" <name:loc> {short_file_names | full_file_names}
+
+ use GNATCOLL.Arg_Lists;
+ use GNATCOLL.Xref;
+
+ Orig_Entity : constant Entity_Information := Get_Entity (Nth_Arg (Args,
1));
+ Orig_Decl : constant Entity_Declaration := Xref.Declaration
(Orig_Entity);
+ Root_Parent : Entity_Information;
+
+ procedure Dump_Type (Type_Entity : in Entity_Information)
+ is
+ Methods : Entities_Cursor;
+ begin
+ if Orig_Decl.Flags.Is_Subprogram then
+ Xref.Methods (Type_Entity, Methods);
+ loop
+ exit when not Has_Element (Methods);
+ declare
+ Method_Name : constant String := +Xref.Declaration
(Methods.Element).Name;
+ Refs : References_Cursor;
+ begin
+ if Method_Name = +Orig_Decl.Name then
+ Xref.References (Methods.Element, Refs);
+ Dump (Refs, +Xref.Declaration (Type_Entity).Name);
+ end if;
+ end;
+ Next (Methods);
+ end loop;
+ else
+ Dump_Entity (Type_Entity);
+ end if;
+ end Dump_Type;
+
+ procedure Dump_Types (Types : in out Recursive_Entities_Cursor)
+ is begin
+ loop
+ exit when not Has_Element (Types);
+ Dump_Type (Types.Element);
+ Next (Types);
+ end loop;
+ end Dump_Types;
+ begin
+ Short_File_Names := Nth_Arg (Args, 2) = Short_File_Names_Arg;
+
+ if Orig_Decl.Flags.Is_Type then
+ -- See comment in Process_Tree_Defs
+ Root_Parent := Orig_Entity;
+
+ elsif Orig_Decl.Flags.Is_Subprogram then
+ declare
+ Controlling : constant Entity_Information := Controlling_Type
(Orig_Entity);
+ begin
+ if Controlling = No_Entity then
+ -- Not a primitive subprogram
+ declare
+ Refs : References_Cursor;
+ begin
+ Xref.References (Orig_Entity, Refs);
+ Dump (Refs);
+ return;
+ end;
+ else
+ Root_Parent := Root_Parent_Type (Controlling, Primitive_Op_Name
=> +Orig_Decl.Name);
+ end if;
+ end;
+ else
+ -- A variable
+ declare
+ Refs : References_Cursor;
+ begin
+ Xref.References (Orig_Entity, Refs);
+ Dump (Refs);
+ return;
+ end;
+ end if;
+
+ declare
+ Child_Types : Recursive_Entities_Cursor;
+ begin
+ All_Child_Types (Root_Parent, Child_Types);
+
+ Dump_Type (Root_Parent);
+ Dump_Types (Child_Types);
+ end;
+ end Process_Tree_Refs;
+
+ procedure Process_Source_Dirs (Args : GNATCOLL.Arg_Lists.Arg_List)
+ is
+ pragma Unreferenced (Args);
+ begin
+ Put (Source_Search_Path.all);
+ end Process_Source_Dirs;
+
+ procedure Put (Item : GNATCOLL.VFS.File_Array)
+ is
+ use GNATCOLL.VFS;
+ begin
+ for I in Item'Range loop
+ Ada.Text_IO.Put_Line (+Full_Name (Item (I)));
+ end loop;
+ end Put;
+
+ ----------
+ -- SQL error reporting
+ type SQL_Error_Reporter is new GNATCOLL.SQL.Exec.Error_Reporter with null
record;
+
+ overriding procedure On_Error
+ (Self : in out SQL_Error_Reporter;
+ Connection : access GNATCOLL.SQL.Exec.Database_Connection_Record'Class;
+ Message : in String)
+ is
+ pragma Unreferenced (Self, Connection);
+ begin
+ Ada.Text_IO.Put_Line ("gpr_query: sql error on create database: " &
Message);
+ end On_Error;
+
+ -- For some reason, gnat community 2020 doesn't like this:
+ -- overriding procedure On_Warning
+ -- (Self : in out SQL_Error_Reporter;
+ -- Connection : access
GNATCOLL.SQL.Exec.Database_Connection_Record'Class;
+ -- Message : in String)
+ -- is begin
+ -- Ada.Text_IO.Put_Line ("gpr_query: sql warning on create database: "
& Message);
+ -- end On_Warning;
+
+ Error_Reporter : aliased SQL_Error_Reporter;
+
+begin
+ Ada.Text_IO.Put_Line ("version: " & Version);
+
+ declare
+ use GNAT.Command_Line;
+ begin
+ Set_Usage
+ (Cmdline,
+ Help => "Query project info and cross-references on source code. See
ada-mode docs for more help.");
+
+ -- Switch variable alphabetic order
+ Define_Switch
+ (Cmdline,
+ Output => ALI_Encoding'Access,
+ Long_Switch => "--encoding=",
+ Switch => "-e=",
+ Help => "The character encoding used for source and ALI
files");
+ Define_Switch
+ (Cmdline,
+ Output => Commands_From_Switch'Access,
+ Switch => "-c:",
+ Long_Switch => "--command=",
+ Help => "Execute the commands from ARG, and exit");
+ Define_Switch
+ (Cmdline,
+ Output => DB_Name'Access,
+ Long_Switch => "--db=",
+ Help => "Specifies the name of the database file (or
':memory:')");
+ Define_Switch
+ (Cmdline,
+ Output => Force_Refresh'Access,
+ Long_Switch => "--force_refresh",
+ Help => "Force rebuilding the database.");
+ Define_Switch
+ (Cmdline,
+ Output => Gpr_Config_File'Access,
+ Long_Switch => "--autoconf=",
+ Help => "Specify the gpr configuration file (.cgpr)");
+ Define_Switch
+ (Cmdline,
+ Output => Nightly_DB_Name'Access,
+ Long_Switch => "--nightlydb=",
+ Help => "Specifies the name of a prebuilt database");
+ Define_Switch
+ (Cmdline,
+ Output => Project_File_Name'Access,
+ Switch => "-P:",
+ Long_Switch => "--project=",
+ Help => "Load the given project (mandatory)");
+ Define_Switch
+ (Cmdline,
+ Output => Show_Progress'Access,
+ Long_Switch => "--display_progress",
+ Switch => "-d",
+ Help => "Show progress as LI files are parsed");
+ Define_Switch
+ (Cmdline,
+ Output => Traces_Config_File'Access,
+ Long_Switch => "--tracefile=",
+ Help =>
+ "Specify a traces configuration file, set projects lib verbose.
File should contain ""gpr_query=yes""");
+
+ Getopt (Cmdline, Callback => null);
+ exception
+ when Exit_From_Command_Line =>
+ -- from "--help"
+ return;
+ end;
+
+ if Project_File_Name.all = "" then
+ Ada.Text_IO.Put_Line ("No project file specified");
+ GNAT.Command_Line.Display_Help (Cmdline);
+ return;
+ end if;
+
+ -- Only trace if user specifies --tracefile
+ if Traces_Config_File.all /= "" and then GNAT.OS_Lib.Is_Regular_File
(Traces_Config_File.all) then
+ GNATCOLL.Traces.Parse_Config_File
+ (Filename => Traces_Config_File.all,
+ Force_Activation => False);
+ GNATCOLL.Traces.Trace (Me, "trace enabled");
+ GNATCOLL.Traces.Trace (Me, "current directory: " &
Ada.Directories.Current_Directory);
+ end if;
+
+ GNATCOLL.Projects.Initialize (Env); -- for register_default_language
+
+ if Gpr_Config_File.all /= "" and then GNAT.OS_Lib.Is_Regular_File
(Gpr_Config_File.all) then
+ Env.Set_Config_File
+ (GNATCOLL.VFS.Create_From_UTF8
+ (GNAT.OS_Lib.Normalize_Pathname
+ (Name => Gpr_Config_File.all,
+ Directory => GNAT.Directory_Operations.Get_Current_Dir)));
+ else
+ -- Apparently Ada language extensions are already registered (sigh)
+
+ Env.Register_Default_Language_Extension
+ (Language_Name => "C",
+ Default_Spec_Suffix => ".h",
+ Default_Body_Suffix => ".c");
+
+ Env.Register_Default_Language_Extension
+ (Language_Name => "C++",
+ Default_Spec_Suffix => ".hh",
+ Default_Body_Suffix => ".cpp");
+
+ end if;
+
+ declare
+ use Ada.Environment_Variables;
+ use Ada.Text_IO;
+ use GNATCOLL.VFS;
+ use GNATCOLL.VFS_Utils;
+
+ Gpr_Project_Path : constant String :=
+ (if Exists ("GPR_PROJECT_PATH") then Ada.Directories.Current_Directory
&
+ GNAT.OS_Lib.Path_Separator &
+ Value ("GPR_PROJECT_PATH")
+ else Ada.Directories.Current_Directory);
+
+ Path : constant Virtual_File := -- must be an absolute file name
+ (if Is_Absolute_Path (+Project_File_Name.all) then
+ Create_From_UTF8 (Project_File_Name.all, Normalize => True)
+ else
+ Locate_Regular_File (+Project_File_Name.all, From_Path
(+Gpr_Project_Path)));
+ begin
+ GNATCOLL.Traces.Trace (Me, "GPR_PROJECT_PATH " & Gpr_Project_Path);
+
+ if not Path.Is_Regular_File then
+ declare
+ Path : constant File_Array := From_Path (+Gpr_Project_Path);
+ begin
+ Put_Line (Project_File_Name.all & ": not found on path:");
+ for P of Path loop
+ Put_Line (+Full_Name (P));
+ end loop;
+ end;
+ Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
+ return;
+ end if;
+
+ GNATCOLL.Traces.Trace (Me, "project file " & (+Path.Full_Name));
+
+ if Show_Progress then
+ Progress_Reporter := Display_Progress'Unrestricted_Access;
+ end if;
+
+ begin
+ -- Recompute_View => True registers all the source files
+ -- (among other things), so we will know that a .[ag]li
+ -- belongs to this project
+ Tree.Load
+ (Path, Env,
+ Errors => Ada.Text_IO.Put_Line'Access,
+ Recompute_View => True);
+ exception
+ when GNATCOLL.Projects.Invalid_Project =>
+ Ada.Text_IO.Put_Line ("project search path:");
+ Put (GNATCOLL.Projects.Predefined_Project_Path (Env.all));
+ raise GNATCOLL.Projects.Invalid_Project with +Path.Full_Name & ":
invalid project";
+ end;
+ end;
+
+ if DB_Name.all /= ":memory:" then
+ declare
+ use GNATCOLL.VFS;
+
+ N : constant String := DB_Name.all;
+ Temp : Virtual_File := Tree.Root_Project.Object_Dir;
+ Dir2 : Virtual_File;
+ begin
+ GNAT.Strings.Free (DB_Name);
+
+ -- If the project does not have an object directory, create
+ -- the database in the directory containing the project file.
+ if Temp = No_File then
+ Temp := Tree.Root_Project.Project_Path.Dir;
+ end if;
+
+ Temp := Create_From_Base (Base_Dir => Temp.Full_Name.all, Base_Name
=> +N);
+ Dir2 := Create (Temp.Dir_Name);
+
+ if not Dir2.Is_Directory then
+ Dir2.Make_Dir (Recursive => True);
+ end if;
+
+ DB_Name := new String'(Temp.Display_Full_Name);
+ end;
+ end if;
+
+ declare
+ -- Error if DB_Name does not exist but is in a read-only directory.
+ -- The Errors parameter to Sqlite.Setup does not help here; it
+ -- reports no error. Ada.Directories does not support a "writeable"
+ -- query.
+ use Ada.Directories;
+ begin
+ if DB_Name.all = ":memory:" then
+ null;
+
+ elsif Exists (DB_Name.all) then
+ -- If this is read-only, we assume it is up to date and the user is
+ -- just browsing.
+ null;
+
+ else
+ declare
+ use GNATCOLL.VFS;
+ Dir_Name : constant String := Containing_Directory
(DB_Name.all);
+ Dir_File : constant Virtual_File := Create (Filesystem_String
(Dir_Name));
+ begin
+ if Is_Writable (Dir_File) then
+ null;
+ else
+ raise DB_Error with "database file '" & DB_Name.all & "' does
not exist, and directory is not writeable";
+ end if;
+ end;
+ end if;
+ end;
+
+ declare
+ use type GNAT.Strings.String_Access;
+ Error : GNAT.Strings.String_Access;
+ begin
+ GNATCOLL.Traces.Trace (Me, "using database " & DB_Name.all);
+
+ Setup_DB
+ (Self => Xref,
+ Tree => Tree'Unchecked_Access,
+ DB => GNATCOLL.SQL.Sqlite.Setup
+ (Database => DB_Name.all,
+ Errors => Error_Reporter'Unchecked_Access),
+ Error => Error);
+
+ if Error /= null then
+ -- old db schema
+ raise DB_Error with Error.all;
+ end if;
+ end;
+
+ Process_Refresh (GNATCOLL.Arg_Lists.Empty_Command_Line);
+
+ Source_Search_Path := new GNATCOLL.VFS.File_Array'
+ (GNATCOLL.Projects.Source_Dirs
+ (Project => Tree.Root_Project,
+ Recursive => True) &
+ GNATCOLL.Projects.Predefined_Source_Path (Env.all));
+
+ if Commands_From_Switch.all /= "" then
+ Process_Line (Commands_From_Switch.all);
+ return;
+ end if;
+
+ loop
+ Ada.Text_IO.Put (">>> ");
+ declare
+ Input : constant String := Ada.Text_IO.Get_Line;
+ begin
+ exit when Input = "exit";
+ Process_Line (Input);
+ exception
+ when E : Invalid_Command =>
+ Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Message (E));
+ Process_Help (GNATCOLL.Arg_Lists.Empty_Command_Line);
+ end;
+ end loop;
+
+exception
+when Ada.IO_Exceptions.End_Error =>
+ null;
+when E : GNATCOLL.Projects.Invalid_Project =>
+ Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Message (E));
+ Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
+when E : DB_Error =>
+ Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Message (E));
+ Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
+when E : Invalid_Command =>
+ Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Message (E));
+ Process_Help (GNATCOLL.Arg_Lists.Empty_Command_Line);
+ Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
+when GNAT.Command_Line.Invalid_Switch =>
+ GNAT.Command_Line.Display_Help (Cmdline);
+ Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
+when E : others =>
+ Ada.Text_IO.Put_Line ("Unexpected exception");
+ Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
+ Ada.Text_IO.Put_Line (GNAT.Traceback.Symbolic.Symbolic_Traceback
(Ada.Exceptions.Traceback.Tracebacks (E)));
+ Ada.Command_Line.Set_Exit_Status (Ada.Command_Line.Failure);
+end Gpr_Query;
diff --git a/gpr_query.trace b/gpr_query.trace
new file mode 100644
index 0000000000..8fdfd53d2b
--- /dev/null
+++ b/gpr_query.trace
@@ -0,0 +1,2 @@
+gpr_query=yes
+ENTITIES.PARSING=yes
diff --git a/install.sh b/install.sh
new file mode 100644
index 0000000000..961272cba8
--- /dev/null
+++ b/install.sh
@@ -0,0 +1,27 @@
+#!/bin/sh
+# Install executables for gpr-query
+#
+# See build.sh for build (must be run before install).
+
+# $1 : optional --prefix=<dir>
+#
+# If you don't have write permission in the GNAT installation
+# directory, you need to use --prefix=<dir>, or run with root
+# privileges.
+
+# We use 'gprinstall', because it defaults to the gnat compiler
+# install directory; gpr_query relies on the format of the *.ali
+# files, so it is tightly tied to the compiler version.
+
+if type alr; then
+ alr exec -- gprinstall -f -p -P emacs_gpr_query.gpr
--install-name=emacs_gpr_query $1
+
+elif type gprbuild; then
+ gprinstall -f -p -P emacs_gpr_query.gpr --install-name=emacs_gpr_query $1
+
+else
+ echo "neither Alire nor gnat compiler found"
+ return 1
+fi
+
+# end of file.
diff --git a/notes.text b/notes.text
new file mode 100644
index 0000000000..66640653d3
--- /dev/null
+++ b/notes.text
@@ -0,0 +1,178 @@
+General notes on Emacs gpr-query minor mode
+
+Alire.make Alire
+ELPA.make elpa, devel
+
+o.e.gpr-query: release, in use
+
+(dvc-state-multiple
+'((xgit . "/Projects/org.emacs.wisi/")
+ (xgit . "/Projects/org.emacs.gnat-compiler/")
+ (xgit . "/Projects/org.emacs.gpr-query/")))
+
+ current work
+
+ release process
+keep status in ~/projects.text
+
+check for ELPA patches by others
+ (dvc-state-one "/Projects/elpa/packages/gpr-query")
+ (dvc-pull "/Projects/elpa")
+ (dvc-sync-review "/Projects/elpa")
+ update
+ clean, quit sync
+ cd c:/Projects/elpa
+ git log -2 -- packages/gpr-query
+ if changes:
+ (dvc-log "/Projects/elpa/packages/<dir>/<file>")
+ apply changes to current
+
+check emacs buglist
+ http://debbugs.gnu.org/cgi/pkgreport.cgi?package=gpr-query
+ to update a bug: nnn@debbugs.gnu.org
+ subject: from bug title, for people who rely on that.
+ if fixed in devel sources, add 'pending' tag:
+ control@debbugs.gnu.org
+ tags nnn + pending
+
+tested in ada-mode; it uses the same test sources for multiple xref backends.
+
+compare:
+ ELPA.make pub
+
+ (setq package-load-list '(all))
+ (list-packages)
+ install previous gpr-query from public ELPA for diffs
+
+ (ediff-directories "~/.emacs.d/elpa/gpr-query-3.1.7"
"/Projects/elpa/packages/gpr-query" nil)
+ ../org.emacs.gpr-query/NEWS
+ copyright date
+ add release date
+ add new features
+
+build in elpa; /Projects/elpa/packages/gpr-query/ELPA.make
+
+Check copyright on files in elpa
+ c:/Projects/elpa/GNUMakefile check-all
+ if any gpr-query files added to output, fix them (add or change to FSF)
+
+bump version
+ Gnu ELPA requires single digits between dots in versions
+
+ bump if _any_ changes other than autoloads, so ELPA package handler knows
to update
+ bump third digit for bug fixes, minor features, no user-incompatible
changes
+ bump second digit for major features, mostly backward-compatible
+ or if third digit gets to 10
+
+ bump first digit for really major elisp user-visible changes:
+
+ gpr-query.el
+ Version:
+
+ NEWS
+ if not done above
+
+ gpr-query.texi
+ @title
+ @node top
+
+ README
+ first line
+
+ alire.toml
+ version
+ depends-on versions
+
+(dvc-state-one ".")
+
+On Debian (alr publish --tar broken on Windows (alr version 1.2.1))
+ cd /Projects/org.emacs.gpr-query
+ alr publish --tar
+ # at "upload and enter url" prompt; in mys2
+ cd alire/archives
+ gpg -b *.tgz
+ scp *.tgz* stephen_leake@dl.sv.nongnu.org:/releases/ada-mode/
+ # wait until http download actually works; took 0.5 days
+ cd ~/Downloads; wget
https://download.savannah.nongnu.org/releases/ada-mode/emacs_gpr_query-1.0.0.tgz
+ # link is
https://download.savannah.nongnu.org/releases/ada-mode/emacs_gpr_query-i.j.k.tgz
+
+update elpa:
+ (gpr-query-kill-all-sessions)
+ ELPA.make pub
+
+ # sometimes this is useful
+ # (ediff-directories "/Projects/org.emacs.gpr-query"
"/Projects/elpa/packages/gpr-query" nil)
+
+ (dvc-state-multiple "/Projects/elpa/packages" t)
+ (dvc-push "/Projects/elpa")
+
+ ask for beta testers
+ edit notice below
+ ada-mode mailing list
+ comp.lang.ada
+
+ # 24 hrs for web repository to update
+
+after Gnu ELPA updated, test install from GNU ELPA
+ first install current version, to be sure upgrade requires new versions
+ ada-mode 7.1.5 should have required wisi 3.1.5
+
+ (list-packages)
+ 5.1.8 crashed emacs for me
+ see 'build.sh; install.sh' above for compiling
+
+ also wisitoken-grammar-mode
+
+(dvc-state-one ".")
+ELPA.make tag zip
+
+in cygwin console for gpg prompts:
+ cd /Projects/org.emacs.gpr-query/build/
+ ls *.tar*
+ rm <old>.tar*
+ gpg -b *.tar.*
+
+ scp *.tar.* stephen_leake@dl.sv.nongnu.org:/releases/gpr-query/
+
+publish on Alire
+ https://alire.ada.dev/
+
+create release branch
+
+post on:
+ emacs-ada-mode mailing list
+ c.l.a newsgroup
+ https://savannah.nongnu.org/news/submit.php?group_id=11631:
+
+-------------------
+Gnu Emacs gpr-query 1.0 released.
+-------------------
+
+Gnu Emacs gpr-query 1.0 is now available in GNU ELPA.
+
+See the NEWS files in ~/.emacs.d/elpa/gpr-query-7.1.6 and wisi-3.1.3,
+or at http://www.nongnu.org/gpr-query/, for more details.
+
+The required Ada code requires a manual compile step, after the normal
+list-packages installation ('install.sh' is new in this release):
+
+cd ~/.emacs.d/elpa/gpr-query-7.1.6
+./build.sh
+./install.sh
+
+If you are not using Alire, this requires AdaCore gnatcoll packages
+which you may not have installed; see gpr-query.info Installation for
+help in installing them.
+-------------------
+
+mark fixed bugs
+ http://debbugs.gnu.org/cgi/pkgreport.cgi?package=ada-mode
+ http://debbugs.gnu.org/cgi/pkgreport.cgi?package=gpr-query
+ http://debbugs.gnu.org/Developer.html
+ email to nnn-close@debbugs.gnu.org
+ subject: copy from bug report
+ body: closed by ada-mode version 7.2.1
+ don't include Version: header; that's an Emacs version
+ debbugs updates summary page within half an hour; no emails
+
+-- end of file
diff --git a/prj-eglot.el b/prj-eglot.el
new file mode 100644
index 0000000000..72788da0d8
--- /dev/null
+++ b/prj-eglot.el
@@ -0,0 +1,41 @@
+;; project settings for building gpr-query with Alire/editing with eglot -*-
no-byte-compile : t -*-
+
+(require 'ada-mode)
+;; This require is not needed for the following code, but is needed to
+;; ensure ada-mode-hook has sal-ada-mode-setup.
+
+(setq ada-indent-engine 'wisi) ;; ada_language_server 22.0 doesn't support
RangeFormatting
+
+(setq ada-xref-tool 'eglot)
+
+(add-hook 'ada-mode-hook #'ada-eglot-setup)
+
+(let* ((gpr-file (expand-file-name "emacs_gpr_query.gpr" (file-name-directory
load-file-name)))
+ (prj-file (expand-file-name "gpr-query.prj" (file-name-directory
load-file-name)))
+ (eglot-workspace-configuration (list `(ada (projectFile . ,gpr-file))))
+
+ (project
+ (create-alire-project
+ :prj-name "gpr-query main Alire eglot"
+ :prj-file prj-file
+ :gpr-file gpr-file)))
+
+ (wisi-prj-select-cache prj-file nil "Alire.make")
+
+ ;; ada_language_server gets GPR_PROJECT_PATH from its process
+ ;; environment, and the gpr file from eglot-workspace-configuration.
+ (let ((process-environment
+ (append
+ (copy-sequence process-environment)
+ (wisi-prj-compile-env project)
+ (wisi-prj-file-env project))))
+
+ (eglot 'ada-mode ;; managed-major-mode
+ project ;; project; project-root is server process directory
+ 'eglot-lsp-server ;; class
+ 'gnat-find-als ;; contact
+ "Ada" ;; language-id
+ ))
+ )
+
+;; end of file
diff --git a/prj.el b/prj.el
new file mode 100644
index 0000000000..bc6ad675f1
--- /dev/null
+++ b/prj.el
@@ -0,0 +1,18 @@
+;; Emacs wisi project definitions for compiling gpr-query in ELPA or devel
workspace -*- no-byte-compile: t; -*-
+;;
+;; Copyright (C) 2021, 2022 Free Software Foundation, Inc.
+
+(wisi-prj-select-cache
+ "gpr-query.prj"
+ (create-ada-prj
+ :name "gpr-query elpa"
+ :compile-env
+ (list
+ (concat "GNAT_COMPILER=" (expand-file-name "../org.emacs.gnat-compiler"))
+ (concat "WISI=" (expand-file-name "../org.emacs.wisi"))
+ ))
+ "ELPA.make"
+ )
+
+(ada-parse-require-process) ;; slow start due to lr1 parse table
+;; end of file