asis-2010.orig/0000755000175000017500000000000011574704442013204 5ustar lbrentalbrentaasis-2010.orig/CHANGE_1606180000644000175000017500000000002211574704441014672 0ustar lbrentalbrentatrunk/ASIS:160618 asis-2010.orig/COPYING0000644000175000017500000004312711574704441014245 0ustar lbrentalbrenta GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public 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. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19yy name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. asis-2010.orig/Makefile0000644000175000017500000000454211574704441014650 0ustar lbrentalbrenta include Makefile.stub all: lib/libasis$(arext) asistant BLD=prod tools = gnatstub gnatelim gnatmetric gnatpp gnatcheck I_BIN = $(prefix)/bin I_INC = $(prefix)/include/asis I_LIB = $(prefix)/lib/asis I_GPR = $(prefix)/lib/gnat I_DOC = $(prefix)/share/doc/asis I_GPS = $(prefix)/share/gps/plug-ins G_DOC = $(prefix)/share/doc/gnat install: install-lib install-asistant install-lib: $(RMDIR) $(I_INC) $(RMDIR) $(I_LIB) $(MKDIR) $(I_BIN) $(MKDIR) $(I_INC) $(MKDIR) $(I_LIB) $(MKDIR) $(I_GPR) $(MKDIR) $(I_GPS) $(MKDIR) $(I_DOC)/html $(MKDIR) $(I_DOC)/info $(MKDIR) $(I_DOC)/pdf $(INSTALL_FILES) lib/*.ali $(I_LIB) $(CHMOD) a-w $(I_LIB)/*.ali $(INSTALL_FILES) lib/libasis$(arext) $(I_LIB) $(CHMOD) a-w $(I_LIB)/libasis$(arext) ifneq ($(ATTRIB),) cd $(I_LIB) && $(ATTRIB) +r '*.ali' cd $(I_LIB) && $(ATTRIB) +r 'libasis$(arext)' endif $(INSTALL_FILES) gnat/*.ads gnat/*.adb $(I_INC) $(INSTALL_FILES) asis/*.ads asis/*.adb $(I_INC) $(INSTALL_FILES) asis/asis.gpr $(I_GPR) $(INSTALL_FILES) documentation/gps_index.xml $(I_GPS)/asis.xml -$(INSTALL_FILES) documentation/asis_*.html $(I_DOC)/html/ -$(INSTALL_FILES) documentation/asis_*.pdf $(I_DOC)/pdf/ -$(INSTALL_FILES) documentation/asis_*.info $(I_DOC)/info/ lib/libasis$(arext): force cd gnat && $(GNATMAKE) xsnamest && ./xsnamest \ && mv snames.ns snames.ads && mv snames.nb snames.adb $(GNATMAKE) -Pasis_bld -XBLD=$(BLD) -XOPSYS=$(OPSYS) install-tools: $(tools:%=install-%) echo $< gnat%: $(GNATMAKE) "-Ptools/$@/$@" "-XBLD=$(BLD)" "-XOPSYS=$(OPSYS)" tools: $(tools) asistant: $(GNATMAKE) "-Ptools/$@/$@" "-XBLD=$(BLD)" "-XOPSYS=$(OPSYS)" install-asistant: $(MKDIR) $(I_BIN) $(INSTALL_FILES) tools/asistant/asistant$(exe_ext) $(I_BIN) install-gnat%: gnat% $(MKDIR) $(I_BIN) $(INSTALL_FILES) tools/gnat$*/gnat$*$(exe_ext) $(I_BIN) install-gnatcheck-doc: $(MKDIR) $(G_DOC)/html $(MKDIR) $(G_DOC)/info $(MKDIR) $(G_DOC)/pdf $(MKDIR) $(G_DOC)/txt $(INSTALL_FILES) documentation/gnatcheck_rm.pdf $(G_DOC)/pdf/ $(INSTALL_FILES) documentation/gnatcheck_rm*.html $(G_DOC)/html/ $(INSTALL_FILES) documentation/gnatcheck_rm.info $(G_DOC)/info/ $(INSTALL_FILES) documentation/gnatcheck_rm.txt $(G_DOC)/txt/ atre: gnat make -Ptools/$@/$@ clean-gnat%: gnat clean -Ptools/gnat$*/gnat$* clean: clean-gnatstub clean-gnatelim clean-gnatpp clean-gnatmetric clean-gnatcheck gnat clean -Pasis_bld force: asis-2010.orig/Makefile.stub0000644000175000017500000000300311574704441015613 0ustar lbrentalbrenta#host system host := $(shell gcc -dumpmachine) # Where Asis library should be installed # Default is into current GNAT directory INSTALL_DIR = $(dir $(shell which gnatls)).. prefix=$(INSTALL_DIR) # Asis specific directories GNAT_DIR=../gnat ASIS_DIR=../asis # GCC backend specific flags CFLAGS= -O2 -g CC=gcc # System commands CHMOD = chmod LN = ln -s ATTRIB = CP = cp -p INSTALL_FILES = cp -p MKDIR = mkdir -p exe_ext = arext = .a soext = .so # object extension objext = .o RM = rm -f RMDIR = rm -rf AR = ar AR_FLAGS = rc RANLIB = ranlib RANLIB_TEST = [ -f /usr/bin/ranlib -o -f /bin/ranlib ] GNATMAKE = gnatmake GNATMAKE_FLAGS = # External Variable to pass to project file OPSYS=default_Unix ifeq "$(findstring mingw32, $(host))" "mingw32" CP = cp -lf MKDIR = mkdir -p exe_ext= .exe ATTRIB = attrib endif ifeq "$(findstring openvms, $(host))" "openvms" prefix=/gnu exe_ext = .exe objext = .obj arext = .olb soext = .exe objext = .obj AR = lib AR_FLAGS = /create GNATMAKE_FLAGS = -nognatlib endif ifeq "$(findstring powerpc-ibm-aix, $(host))" "powerpc-ibm-aix" CFLAGS = -O2 -g -mminimal-toc OPSYS=powerpc_aix endif ifeq "$(findstring hppa1.1-hp-hpux, $(host))" "hppa1.1-hp-hpux" CFLAGS = -O2 -g -mdisable-indexing OPSYS=pa_hpux endif ifeq "$(findstring i386-elf-lynxos, $(host))" "i386-elf-lynxos" MKDIR = mkdir -p -f endif # GNAT specific flags ADA_FLAGS_FOR_TOOLS= -gnaty -gnatwu -gnatwe ADA_FLAGS_FOR_ASISLIB= -gnatg -gnatwu -gnatwe # GNATMAKE specific flags GMFLAGS= asis-2010.orig/Makefile.vms0000755000175000017500000000002211574704441015444 0ustar lbrentalbrentainclude Makefile. asis-2010.orig/README0000644000175000017500000002270711574704441014073 0ustar lbrentalbrentaThis file describes the structure and the contents of the ASIS-for-GNAT distribution and explains how to install ASIS-for-GNAT. ASIS-for-GNAT Installation Guide ================================= Contents 1. Structure of the ASIS-for-GNAT Distribution 2. Coordination between ASIS-for-GNAT and GNAT Versions 3. Building and installing ASIS-for-GNAT 4. ASIS application examples 5. Related information =========================================================================== 1. Structure of the ASIS-for-GNAT Distribution ------------------------------------------- ASIS-for-GNAT is distributed as a set of text files in ASCII format with UNIX-style line breaks. It includes all the sources of the ASIS-for-GNAT components. The ASIS-for-GNAT distribution is packaged as a UNIX tape archive file (or as a Windows zip archive) named asis-[version#]-src.tgz, (or asis-[version#]-src.zip) where [version#] is the number of the GNAT version for which ASIS-for-GNAT is distributed, for example asis-6_0_2-src.zip. When you extract the content of this archive, you obtain the following directory structure: asis-[version#]-src <-- the top of the ASIS source distribution hierarchy /asis <-- the sources of the ASIS implementation components /gnat <-- the sources of the GNAT implementation components needed by components of the asis-[version#]-src/asis subdirectory /lib <-- the directory to place the ASIS library into /obj <-- the directory to be used for object and ALI files when installing ASIS. Originally it contains only the Makefile and the file install_asis.adb containing the source of a dummy Ada unit. /documentation <-- the directory containing the ASIS-for-GNAT documentation /tools <-- ASIS-based tools /asistant <-- an interactive interpreter of ASIS queries and ASIS tree browser /gnatcheck <-- a tool which checks its argument sources against a given set of code style rules /gnatelim <-- a tool which analyzes a full Ada program and detects subprograms which are declared, but which are never called in this program /gnatmetric <-- a tool which counts various metrics for its argument sources /gnatpp <-- a pretty-printing tool /gnatstub <-- a tool which can create an "empty", but compilable body for an library unit declaration. /tool_utils <-- an ASIS Utility Library, it contains various resources that can be useful for ASIS application development, some of these resources are used for the ASIS tools listed above /tutorial <-- Hands-On ASIS tutorials /templates <-- A set of Ada source components which may be used for fast development of simple ASIS-based tools or which can be reused in the code of ASIS applications 2. Coordination between ASIS-for-GNAT and GNAT Versions ---------------------------------------------------- The implementation of ASIS is always based on some persistent data structure produced by the underlying Ada compiler. ASIS-for-GNAT uses the tree output files produced by GNAT, and it incorporates some compiler components to work with these tree files. Each distribution of ASIS-for-GNAT corresponds to a specific version of GNAT. The version number is a part of the name of the archive file of the ASIS-for-GNAT distribution, as well as the name of the top catalog of the directory structure you will get when you unpack the archive. To use a given distribution of ASIS-for-GNAT, you must have the proper version of GNAT installed on your system. Make sure that when you update ASIS-for-GNAT, you also update GNAT accordingly, and vice versa. Note, that sometimes for the same version number for the compiler there may exist several releases having this version number (this is the case for wavefront compiler versions). The differences between such releases usually are completely transparent for the most of the compiler users, but they may affect ASIS and ASIS applications. To check that your GNAT/ASIS configuration is consistent, do the following: - Get the version number and the build date for the GNAT compiler installed in your environment. To do this, run the gnatls tool with -v option >gnatls -v The first line of the output produced in stdout will start with: GNATLS (]>) e.g. GNATLS Pro 6.0.2 (20070620-41) - Get the version and the build date of the GNAT compiler which components are used as a part of the ASIS implementation. Look into the source file asis-[version#]-src/gnat/gnatvsn.ads and locate the value of the string constant Gnat_Static_Version_String. It has the following structure () - compare and parts of these two strings. If the version numbers in the parts and dates are exactly the same, your configuration is 100% consistent. But we do not require the compiler and ASIS versions to be exactly the same. The important thing is that they are close enough in respect of the structure of the compiler tree. We do not formalize this notions of "closeness" of the compiler and ASIS versions, but the important thing is that if your ASIS application raises Program_Error with the exception message "Inconsistent versions of GNAT and ASIS", this means that your GNAT/ASIS configuration is inconsistent. 3. Building and installing ASIS-for-GNAT ------------------------------------- The simplest, most reliable, and recommended way to build ASIS-for-GNAT is to use the project files included in the ASIS distribution. After unpacking the ASIS-for-GNAT archive, go to the resulting asis-[version#]-src directory. Before actually building ASIS and the ASIS tools with those project files, go to the gnat/ subdirectory, build and run the program that generates the source components needed by ASIS from the source templates, and then rename them as Ada sources: cd gnat/ gnatmake xsnamest.adb ./xsnamest snames.ns snames.ads snames.nb snames.adb cd .. where is a file renaming command in your system. Then go back to the ASIS root directory and do: gnat make -Pasis_bld This compiles all the ASIS implementation sources, placing the objects and ALI files in asis-[version#]-src/obj, and creating the ASIS library in asis-[version#]-src/lib. When this is done, you can build the ASIS tools executables. To build an ASIS tool, go into the corresponding tool sources directory tools/ and do: gnat make -P This creates the executable for in the tools/ directory. If you want to build ASIS and install it as a library to be used with GNAT, go to the root ASIS directory and run: make all install prefix= This will create the required Ada sources from the templates present in the gnat subdirectory, build and install the ASIS library in the specified location. is the root directory of your GNAT installation (this is the recomended way to install ASIS). Then, in order to be able to build your own ASIS tools with the project files, just add: with "asis"; to a project file used by your ASIS application. If you run in the root directory of the ASIS source distribution asis-[version#]-src: make install-asistant prefix= this installs the ASIS interactive interpreter asistant (see the ASIS User's guide for more details). 4. ASIS application examples ------------------------- The ASIS-for-GNAT does not contain any special directory with ASIS application examples. Instead, you may consider the directories with ASIS tools included in the distribution as examples of real-life ASIS applications. Note that the corresponding tool project files can be used as templates for creating project files for your own ASIS application. A good starting point as a full-size ASIS application example is the gnatstub tool. The solutions provided for the ASIS tutorial (asis-[version#]-src/tutorial) can be viewed as simple (introductory) ASIS application examples. The directory asis-[version#]-src/tutorial/using_templates/metrics contains a simple solution for the metric tool development problem (the full-size solution is given in asis-[version#]-src/tools/gnatmetric), the directory asis-[version#]-src/tutorial/using_templates/style_checker provides a simple solution for the style checking tool problem (the full-size solution is given in asis-[version#]-src/tools/gnatcheck). 5. Related information ------------------- For more information about ASIS-for-GNAT see the following documents: - The ASIS-for-GNAT User's Guide explains how to build tools with ASIS-for-GNAT and describes how to create and maintain an ASIS Context to be used with ASIS-for-GNAT, as well as other efficiency issues. It also contains a general introduction to ASIS 95. - The ASIS-for-GNAT Reference Manual describes in full the implementation choices taken on all ASIS implementation-specific issues, and lists the current implementation limitations. - New features added to the ASIS implementation for GNAT and problems which have been detected and fixed are described in the files "features" and "known-problems" respectively. These files are part of the GNAT distribution. asis-2010.orig/asis/0000755000175000017500000000000011574704442014143 5ustar lbrentalbrentaasis-2010.orig/asis/a4g-a_alloc.ads0000644000175000017500000001041011574704441016672 0ustar lbrentalbrenta------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- A 4 G . A _ A L L O C -- -- -- -- S p e c -- -- -- -- Version : 1.00 -- -- -- -- Copyright (c) 1995-1999, Free Software Foundation, Inc. -- -- -- -- ASIS-for-GNAT 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 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 59 Temple Place -- -- - Suite 330, Boston, MA 02111-1307, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by Ada Core Technologies Inc -- -- (http://www.gnat.com). -- -- -- ------------------------------------------------------------------------------ package A4G.A_Alloc is -- This package contains definitions for initial sizes and growth increments -- for the various dynamic arrays used for principle ASIS Context -- Model data strcutures. The indicated initial size is allocated for the -- start of each file, and the increment factor is a percentage used -- to increase the table size when it needs expanding -- (e.g. a value of 100 = 100% increase = double) -- This package is the ASIS implementation's analog of the GNAT Alloc package Alloc_ASIS_Units_Initial : constant := 1_000; -- Initial allocation for unit tables Alloc_ASIS_Units_Increment : constant := 150; -- Incremental allocation factor for unit tables Alloc_Contexts_Initial : constant := 20; -- Initial allocation for Context table (A4G.Contt) Alloc_Contexts_Increment : constant := 150; -- Incremental allocation factor for Context table (Contt) Alloc_ASIS_Trees_Initial : constant := 1_000; -- Initial allocation for tree tables Alloc_ASIS_Trees_Increment : constant := 150; -- Incremental allocation factor for tree tables end A4G.A_Alloc; asis-2010.orig/asis/a4g-a_debug.adb0000644000175000017500000002642311574704441016660 0ustar lbrentalbrenta------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- A 4 G . A _ D E B U G -- -- -- -- B o d y -- -- -- -- Copyright (c) 1995-2005, Free Software Foundation, Inc. -- -- -- -- ASIS-for-GNAT 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 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 59 Temple Place -- -- - Suite 330, Boston, MA 02111-1307, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by Ada Core Technologies Inc -- -- (http://www.gnat.com). -- -- -- ------------------------------------------------------------------------------ package body A4G.A_Debug is --------------------------------- -- Summary of Debug Flag Usage -- --------------------------------- -- da Generate messages when working with normalized associations -- db -- dc Generate messages from Context Table during finalization -- dd Dynamic allocation of tables messages generated -- de -- df -- dg -- dh -- di Turns off including the Element location into its Debug_Image -- dj -- dk -- dl Generate debug output when converting node lists into element lists -- dm -- dn Generate messages for list allocation -- do Generate messages when opening a Context -- dp -- dq -- dr -- ds All the debug output related to the semantic queries -- dt Generate messages when a tree file is read in -- du -- dv Generate messages when checking the validity of ASIS abstractions -- dw -- dx Generate debug messages from inside Asis.Text routines -- dy -- dz -- d1 Generate the debug output for tree fragments being traversed -- d2 -- d3 -- d4 -- d5 -- d6 -- d7 -- d8 -- d9 ---------------------------------------- -- Documentation for ASIS Debug Flags -- ---------------------------------------- -- da When a list of normalized ASIS association elements is created -- or a normalized association is further decomposed, messages -- representing some "control points" of this process are generated. -- -- db -- dc When ASIS implementation is finalized (by calling to -- A4G.Finalize), the content of the main -- Context Table and its subtables is outputted -- dd Dynamic allocation of tables messages generated. Each time a -- table is reallocated, a line is output indicating the expansion. -- de -- df -- dg -- dh In GNAT this flag generates a table at the end of a compilation -- showing how the hash table chains built by the Namet package are -- loaded. This is useful in ensuring that the hashing algorithm -- (in Namet.Hash) is working effectively with typical sets of -- program identifiers. In ASIS the corresponding feature is not -- implemented yet. The idea is to see if the hashing algorithm -- is working effectively with the typical set of normalized -- unit names -- di Turns off including the Element location into its Debug_Image, -- this is helpful when Asis.Text queries do not work properly -- because of structural queries misfunction. -- dj -- dk -- dl Generate debug output when converting node lists into element -- lists. For every tree node traversing during the list conversion -- some information about the node is outputted -- dm -- dn Generate messages for list allocation. Each time a list header is -- allocated, a line of output is generated. -- do Generate messages when opening a Context in -- "use pre-created trees" mode -- dp -- dq -- dr -- ds Various debug messages related to the semantic queries -- implemented for now are generated -- dt Generate messages when a tree file is read in during processing -- ASIS queries -- du -- dv Generate messages when checking the validity of ASIS Elements, -- Compilation_Units, Contexts. The idea is to show, why a given -- ASIS abstraction is considered as being invalid -- dw -- dx Generate debug messages from inside the routines involved in the -- implementation of Asis.Text -- dy -- dz -- d1 Generate the debug output for tree fragments being traversed -- when processing ASIS queries (usially - the subtrees rooted by -- argument's pr result's node -- -- d2 -- d3 -- d4 -- d5 -- d6 -- d7 -- d8 -- d9 -------------------- -- Set_Debug_Flag -- -------------------- procedure Set_Debug_Flag (C : Character; Val : Boolean := True) is subtype Dig is Character range '1' .. '9'; subtype Let is Character range 'a' .. 'z'; begin if C in Dig then case Dig (C) is when '1' => Debug_Flag_1 := Val; when '2' => Debug_Flag_2 := Val; when '3' => Debug_Flag_3 := Val; when '4' => Debug_Flag_4 := Val; when '5' => Debug_Flag_5 := Val; when '6' => Debug_Flag_6 := Val; when '7' => Debug_Flag_7 := Val; when '8' => Debug_Flag_8 := Val; when '9' => Debug_Flag_9 := Val; end case; else case Let (C) is when 'a' => Debug_Flag_A := Val; when 'b' => Debug_Flag_B := Val; when 'c' => Debug_Flag_C := Val; when 'd' => Debug_Flag_D := Val; when 'e' => Debug_Flag_E := Val; when 'f' => Debug_Flag_F := Val; when 'g' => Debug_Flag_G := Val; when 'h' => Debug_Flag_H := Val; when 'i' => Debug_Flag_I := Val; when 'j' => Debug_Flag_J := Val; when 'k' => Debug_Flag_K := Val; when 'l' => Debug_Flag_L := Val; when 'm' => Debug_Flag_M := Val; when 'n' => Debug_Flag_N := Val; when 'o' => Debug_Flag_O := Val; when 'p' => Debug_Flag_P := Val; when 'q' => Debug_Flag_Q := Val; when 'r' => Debug_Flag_R := Val; when 's' => Debug_Flag_S := Val; when 't' => Debug_Flag_T := Val; when 'u' => Debug_Flag_U := Val; when 'v' => Debug_Flag_V := Val; when 'w' => Debug_Flag_W := Val; when 'x' => Debug_Flag_X := Val; when 'y' => Debug_Flag_Y := Val; when 'z' => Debug_Flag_Z := Val; end case; end if; end Set_Debug_Flag; ------------- -- Set_Off -- ------------- procedure Set_Off is begin Debug_Flag_1 := False; Debug_Flag_2 := False; Debug_Flag_3 := False; Debug_Flag_4 := False; Debug_Flag_5 := False; Debug_Flag_6 := False; Debug_Flag_7 := False; Debug_Flag_8 := False; Debug_Flag_9 := False; Debug_Flag_A := False; Debug_Flag_B := False; Debug_Flag_C := False; Debug_Flag_D := False; Debug_Flag_E := False; Debug_Flag_F := False; Debug_Flag_G := False; Debug_Flag_H := False; Debug_Flag_I := False; Debug_Flag_J := False; Debug_Flag_K := False; Debug_Flag_L := False; Debug_Flag_M := False; Debug_Flag_N := False; Debug_Flag_O := False; Debug_Flag_P := False; Debug_Flag_Q := False; Debug_Flag_R := False; Debug_Flag_S := False; Debug_Flag_T := False; Debug_Flag_U := False; Debug_Flag_V := False; Debug_Flag_W := False; Debug_Flag_X := False; Debug_Flag_Y := False; Debug_Flag_Z := False; Debug_Mode := False; Debug_Lib_Model := False; -- TEMPORARY SOLUTION, SHOULD BE DROPPED!!! end Set_Off; ------------ -- Set_On -- ------------ procedure Set_On is begin Debug_Flag_1 := True; Debug_Flag_2 := True; Debug_Flag_3 := True; Debug_Flag_4 := True; Debug_Flag_5 := True; Debug_Flag_6 := True; Debug_Flag_7 := True; Debug_Flag_8 := True; Debug_Flag_9 := True; Debug_Flag_A := True; Debug_Flag_B := True; Debug_Flag_C := True; Debug_Flag_D := True; Debug_Flag_E := True; Debug_Flag_F := True; Debug_Flag_G := True; Debug_Flag_H := True; Debug_Flag_I := True; Debug_Flag_J := True; Debug_Flag_K := True; Debug_Flag_L := True; Debug_Flag_M := True; Debug_Flag_N := True; Debug_Flag_O := True; Debug_Flag_P := True; Debug_Flag_Q := True; Debug_Flag_R := True; Debug_Flag_S := True; Debug_Flag_T := True; Debug_Flag_U := True; Debug_Flag_V := True; Debug_Flag_W := True; Debug_Flag_X := True; Debug_Flag_Y := True; Debug_Flag_Z := True; Debug_Mode := True; -- TEMPORARY SOLUTION, SHOULD BE DROPPED!!! Debug_Lib_Model := True; -- TEMPORARY SOLUTION, SHOULD BE DROPPED!!! end Set_On; end A4G.A_Debug; asis-2010.orig/asis/a4g-a_debug.ads0000644000175000017500000001415011574704441016673 0ustar lbrentalbrenta------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- A 4 G . A _ D E B U G -- -- -- -- S p e c -- -- -- -- Copyright (c) 1995-1999, Free Software Foundation, Inc. -- -- -- -- ASIS-for-GNAT 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 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 59 Temple Place -- -- - Suite 330, Boston, MA 02111-1307, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by Ada Core Technologies Inc -- -- (http://www.gnat.com). -- -- -- ------------------------------------------------------------------------------ package A4G.A_Debug is -- This package contains global flags used to control the inclusion -- of debugging code in various phases of the ASIS-for-GNAT. It is -- an almost complete analog of the GNAT Debug package ------------------------- -- Dynamic Debug Flags -- ------------------------- -- Thirty six flags that can be used to active various specialized -- debugging output information. The flags are preset to False, which -- corresponds to the given output being suppressed. The individual -- flags can be turned on using the undocumented switch /dxxx where -- xxx is a string of letters for flags to be turned on. Documentation -- on the current usage of these flags is contained in the body of Debug -- rather than the spec, so that we don't have to recompile the world -- when a new debug flag is added Debug_Flag_A : Boolean := False; Debug_Flag_B : Boolean := False; Debug_Flag_C : Boolean := False; Debug_Flag_D : Boolean := False; Debug_Flag_E : Boolean := False; Debug_Flag_F : Boolean := False; Debug_Flag_G : Boolean := False; Debug_Flag_H : Boolean := False; Debug_Flag_I : Boolean := False; Debug_Flag_J : Boolean := False; Debug_Flag_K : Boolean := False; Debug_Flag_L : Boolean := False; Debug_Flag_M : Boolean := False; Debug_Flag_N : Boolean := False; Debug_Flag_O : Boolean := False; Debug_Flag_P : Boolean := False; Debug_Flag_Q : Boolean := False; Debug_Flag_R : Boolean := False; Debug_Flag_S : Boolean := False; Debug_Flag_T : Boolean := False; Debug_Flag_U : Boolean := False; Debug_Flag_V : Boolean := False; Debug_Flag_W : Boolean := False; Debug_Flag_X : Boolean := False; Debug_Flag_Y : Boolean := False; Debug_Flag_Z : Boolean := False; Debug_Flag_1 : Boolean := False; Debug_Flag_2 : Boolean := False; Debug_Flag_3 : Boolean := False; Debug_Flag_4 : Boolean := False; Debug_Flag_5 : Boolean := False; Debug_Flag_6 : Boolean := False; Debug_Flag_7 : Boolean := False; Debug_Flag_8 : Boolean := False; Debug_Flag_9 : Boolean := False; procedure Set_Debug_Flag (C : Character; Val : Boolean := True); -- Where C is 0-9 or a-z, sets the corresponding debug flag to the -- given value. In the checks off version of debug, the call to -- Set_Debug_Flag is always a null operation. procedure Set_Off; -- Sets all the debug flags OFF (except Debug_Lib_Model for now), -- is to be called by Asis_Environment.Finalize procedure Set_On; -- TEMPORARY SOLUTION!!! -- Sets all the debug flags ON. ------------------------ -- TEMPORARY SOLUTION -- ------------------------ Debug_Mode : Boolean := False; -- flag indicatING if the debugging information should be outputed -- by the routines from the A4G.A_Output package Debug_Lib_Model : Boolean := False; -- flag forcing the debug output of the tables implementing the -- ASIS Context Model to be performed when finalizing ASIS Environment -- Currently should be sent by hands. The debug output is produced only -- if Debug_Mode is set ON. end A4G.A_Debug; asis-2010.orig/asis/a4g-a_elists.adb0000644000175000017500000003471611574704441017101 0ustar lbrentalbrenta------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- A 4 G . A _ E L I S T S -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- -- -- -- ASIS-for-GNAT 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 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 51 Franklin -- -- Street, Fifth Floor, Boston, MA 02110-1301, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by AdaCore -- -- (http://www.adaccore.com). -- -- -- ------------------------------------------------------------------------------ -- This is the modification of the GNAT Elists package. See spec for the -- description of the modifications. with A4G.A_Debug; use A4G.A_Debug; with Output; use Output; package body A4G.A_Elists is ---------------------- -- Add_To_Elmt_List -- ---------------------- procedure Add_To_Elmt_List (Unit : Unit_Id; List : in out Elist_Id) is begin if No (List) then List := New_Elmt_List; Append_Elmt (Unit, List); elsif not In_Elmt_List (Unit, List) then Append_Elmt (Unit, List); end if; end Add_To_Elmt_List; ----------------- -- Append_Elmt -- ----------------- procedure Append_Elmt (Unit : Unit_Id; To : Elist_Id) is L : constant Elmt_Id := Elists.Table (To).Last; begin Elmts.Increment_Last; Elmts.Table (Elmts.Last).Unit := Unit; Elmts.Table (Elmts.Last).Next := Union_Id (To); if L = No_Elmt then Elists.Table (To).First := Elmts.Last; else Elmts.Table (L).Next := Union_Id (Elmts.Last); end if; Elists.Table (To).Last := Elmts.Last; if Debug_Flag_N then Write_Str ("Append new element Elmt_Id = "); Write_Int (Int (Elmts.Last)); Write_Str (" to list Elist_Id = "); Write_Int (Int (To)); Write_Str (" referencing Unit_Id = "); Write_Int (Int (Unit)); Write_Eol; end if; end Append_Elmt; ------------------ -- Prepend_Elmt -- ------------------ procedure Prepend_Elmt (Unit : Unit_Id; To : Elist_Id) is F : constant Elmt_Id := Elists.Table (To).First; begin Elmts.Increment_Last; Elmts.Table (Elmts.Last).Unit := Unit; if F = No_Elmt then Elists.Table (To).Last := Elmts.Last; Elmts.Table (Elmts.Last).Next := Union_Id (To); else Elmts.Table (Elmts.Last).Next := Union_Id (F); end if; Elists.Table (To).First := Elmts.Last; end Prepend_Elmt; ----------------------- -- Insert_Elmt_After -- ----------------------- procedure Insert_Elmt_After (Unit : Unit_Id; Elmt : Elmt_Id) is N : constant Union_Id := Elmts.Table (Elmt).Next; begin pragma Assert (Elmt /= No_Elmt); Elmts.Increment_Last; Elmts.Table (Elmts.Last).Unit := Unit; Elmts.Table (Elmts.Last).Next := N; Elmts.Table (Elmt).Next := Union_Id (Elmts.Last); if N in Elist_Range then Elists.Table (Elist_Id (N)).Last := Elmts.Last; end if; end Insert_Elmt_After; ------------- -- Belongs -- ------------- function Belongs (List1 : Elist_Id; List2 : Elist_Id) return Boolean is Curr_Elmt : Elmt_Id; begin if No (List1) or else Is_Empty_Elmt_List (List1) then return True; end if; Curr_Elmt := First_Elmt (List1); while Present (Curr_Elmt) loop if not In_Elmt_List (Unit (Curr_Elmt), List2) then return False; end if; Curr_Elmt := Next_Elmt (Curr_Elmt); end loop; return True; end Belongs; ---------------- -- First_Elmt -- ---------------- function First_Elmt (List : Elist_Id) return Elmt_Id is begin pragma Assert (List > Elist_Low_Bound); return Elists.Table (List).First; end First_Elmt; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Elists.Init; Elmts.Init; end Initialize; ------------------ -- In_Elmt_List -- ------------------ function In_Elmt_List (U : Unit_Id; List : Elist_Id) return Boolean is Curr_Elmt : Elmt_Id; begin if No (List) or else Is_Empty_Elmt_List (List) then return False; end if; Curr_Elmt := First_Elmt (List); while Present (Curr_Elmt) loop if U = Unit (Curr_Elmt) then return True; end if; Curr_Elmt := Next_Elmt (Curr_Elmt); end loop; return False; end In_Elmt_List; --------------- -- Intersect -- --------------- function Intersect (List1 : Elist_Id; List2 : Elist_Id) return Boolean is Curr_Elmt : Elmt_Id; begin if No (List1) or else No (List2) or else Is_Empty_Elmt_List (List1) or else Is_Empty_Elmt_List (List2) then return False; else Curr_Elmt := First_Elmt (List1); while Present (Curr_Elmt) loop if In_Elmt_List (Unit (Curr_Elmt), List2) then return True; end if; Curr_Elmt := Next_Elmt (Curr_Elmt); end loop; return False; end if; end Intersect; ------------------------ -- Is_Empty_Elmt_List -- ------------------------ function Is_Empty_Elmt_List (List : Elist_Id) return Boolean is begin return Elists.Table (List).First = No_Elmt; end Is_Empty_Elmt_List; ------------------- -- Last_Elist_Id -- ------------------- function Last_Elist_Id return Elist_Id is begin return Elists.Last; end Last_Elist_Id; --------------- -- Last_Elmt -- --------------- function Last_Elmt (List : Elist_Id) return Elmt_Id is begin return Elists.Table (List).Last; end Last_Elmt; ------------------ -- Last_Elmt_Id -- ------------------ function Last_Elmt_Id return Elmt_Id is begin return Elmts.Last; end Last_Elmt_Id; ----------------- -- List_Length -- ----------------- function List_Length (List : Elist_Id) return Natural is Result : Natural := 0; Elem : Elmt_Id; begin Elem := First_Elmt (List); while Present (Elem) loop Result := Result + 1; Elem := Next_Elmt (Elem); end loop; return Result; end List_Length; --------------- -- Move_List -- --------------- procedure Move_List (List_From : Elist_Id; List_To : in out Elist_Id) is begin if No (List_To) then List_To := New_Elmt_List; end if; if No (List_From) or else Is_Empty_Elmt_List (List_From) then return; end if; -- if we are here, we have to move elements... if Is_Empty_Elmt_List (List_To) then Elists.Table (List_To).Last := Elists.Table (List_From).Last; Elmts.Table (Elists.Table (List_From).Last).Next := Union_Id (List_To); else Elmts.Table (Elists.Table (List_From).Last).Next := Elmts.Table (Elists.Table (List_To).First).Next; end if; Elists.Table (List_To).First := Elists.Table (List_From).First; Elists.Table (List_From).First := No_Elmt; Elists.Table (List_From).Last := No_Elmt; end Move_List; ------------------- -- New_Elmt_List -- ------------------- function New_Elmt_List return Elist_Id is begin Elists.Increment_Last; Elists.Table (Elists.Last).First := No_Elmt; Elists.Table (Elists.Last).Last := No_Elmt; if Debug_Flag_N then Write_Str ("Allocate new element list, returned ID = "); Write_Int (Int (Elists.Last)); Write_Eol; end if; return Elists.Last; end New_Elmt_List; --------------- -- Next_Elmt -- --------------- function Next_Elmt (Elmt : Elmt_Id) return Elmt_Id is N : constant Union_Id := Elmts.Table (Elmt).Next; begin if N in Elist_Range then return No_Elmt; else return Elmt_Id (N); end if; end Next_Elmt; -------- -- No -- -------- function No (List : Elist_Id) return Boolean is begin return List = No_Elist; end No; function No (Elmt : Elmt_Id) return Boolean is begin return Elmt = No_Elmt; end No; ----------- -- Unit -- ----------- function Unit (Elmt : Elmt_Id) return Unit_Id is begin if Elmt = No_Elmt then return Nil_Unit; else return Elmts.Table (Elmt).Unit; end if; end Unit; ---------------- -- Num_Elists -- ---------------- function Num_Elists return Nat is begin return Int (Elmts.Last) - Int (Elmts.First) + 1; end Num_Elists; ------------- -- Present -- ------------- function Present (List : Elist_Id) return Boolean is begin return List /= No_Elist; end Present; function Present (Elmt : Elmt_Id) return Boolean is begin return Elmt /= No_Elmt; end Present; ---------------- -- Print_List -- ---------------- procedure Print_List (List : Elist_Id) is Curr_Elmt : Elmt_Id; Counter : Int := 1; begin if No (List) then if Debug_Flag_N then Write_Str (" There is no list here"); Write_Eol; end if; return; end if; if Is_Empty_Elmt_List (List) then if Debug_Flag_N then Write_Str (" The list is empty"); Write_Eol; end if; return; end if; if Debug_Flag_N then Write_Str ("List contains the following Ids:"); Write_Eol; end if; Curr_Elmt := First_Elmt (List); while Present (Curr_Elmt) loop if Debug_Flag_N then Write_Str (" Element number "); Write_Int (Counter); Write_Str (" is "); Write_Int (Int (Unit (Curr_Elmt))); Write_Eol; end if; Curr_Elmt := Next_Elmt (Curr_Elmt); Counter := Counter + 1; end loop; end Print_List; ----------------- -- Remove_Elmt -- ----------------- procedure Remove_Elmt (List : Elist_Id; Elmt : Elmt_Id) is Nxt : Elmt_Id; Prv : Elmt_Id; begin Nxt := Elists.Table (List).First; -- Case of removing only element in the list if Elmts.Table (Nxt).Next in Elist_Range then pragma Assert (Nxt = Elmt); Elists.Table (List).First := No_Elmt; Elists.Table (List).Last := No_Elmt; -- Case of removing the first element in the list elsif Nxt = Elmt then Elists.Table (List).First := Elmt_Id (Elmts.Table (Nxt).Next); -- Case of removing second or later element in the list else loop Prv := Nxt; Nxt := Elmt_Id (Elmts.Table (Prv).Next); exit when Nxt = Elmt or else Elmts.Table (Nxt).Next in Elist_Range; end loop; pragma Assert (Nxt = Elmt); Elmts.Table (Prv).Next := Elmts.Table (Nxt).Next; if Elmts.Table (Prv).Next in Elist_Range then Elists.Table (List).Last := Prv; end if; end if; end Remove_Elmt; ---------------------- -- Remove_Last_Elmt -- ---------------------- procedure Remove_Last_Elmt (List : Elist_Id) is Nxt : Elmt_Id; Prv : Elmt_Id; begin Nxt := Elists.Table (List).First; -- Case of removing only element in the list if Elmts.Table (Nxt).Next in Elist_Range then Elists.Table (List).First := No_Elmt; Elists.Table (List).Last := No_Elmt; -- Case of at least two elements in list else loop Prv := Nxt; Nxt := Elmt_Id (Elmts.Table (Prv).Next); exit when Elmts.Table (Nxt).Next in Elist_Range; end loop; Elmts.Table (Prv).Next := Elmts.Table (Nxt).Next; Elists.Table (List).Last := Prv; end if; end Remove_Last_Elmt; ------------------ -- Replace_Elmt -- ------------------ procedure Replace_Elmt (Elmt : Elmt_Id; New_Unit : Unit_Id) is begin Elmts.Table (Elmt).Unit := New_Unit; end Replace_Elmt; end A4G.A_Elists; asis-2010.orig/asis/a4g-a_elists.ads0000644000175000017500000003401711574704441017114 0ustar lbrentalbrenta------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- A 4 G . A _ E L I S T S -- -- -- -- S p e c -- -- -- -- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- -- -- -- ASIS-for-GNAT 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 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 51 Franklin -- -- Street, Fifth Floor, Boston, MA 02110-1301, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by AdaCore -- -- (http://www.adaccore.com). -- -- -- ------------------------------------------------------------------------------ -- This package is a modification of the GNAT Elists package, which -- provides facilities for manipulating lists of AST nodes (see the GNAT -- package Atree for format and implementation of tree nodes). -- -- The following modifications of the GNAT Elists package (revision 1.13-spec -- and 1.19 body) are made here: -- -- 1. List type: for multiple Context processing, ASIS needs a list type to -- represent unit lists specific for each Context. To make it possible to -- simulate the element list type by the Saved_Table type provided by the -- GNAT Table package, the instantiations of the GNAT Table which -- implements element lists in the ASIS lists package are moved from -- the body into the spec. -- -- 2. List element type: ASIS needs lists of ASIS Compilation Units to be -- processed as a part of the ASIS Context implementation. Therefore the -- GNAT Node_Id type is systematically replaced by the ASIS Unit_Id type, -- and the Node function is renamed into the Unit function -- -- 3. Removing non-needed subprograms - the following subprograms defined in -- the GNAT Elists package are of no need for ASIS lists. They are removed -- from the ASIS list package: -- procedure Lock -- procedure Tree_Read -- procedure Tree_Write -- function Elists_Address -- function Elmts_Address -- -- 4. Adding subprograms for ASIS needs - they are grouped in the end of the -- package spec after the corresponding comment separator -- -- 5. Removing Inline pragmas: in the current version of the ASIS lists -- package all the Inline pragnas are removed -- -- 6. Adjusting documentation: some minor and natural adjustments in the -- documentation has been done with Table; with Alloc; with Types; use Types; with A4G.A_Types; use A4G.A_Types; package A4G.A_Elists is -- An element list is represented by a header that is allocated in the -- Elist header table. This header contains pointers to the first and -- last elements in the list, or to No_Elmt if the list is empty. ----------------------------------------------------- -- Subprograms coming from the GNAT Elists package -- ----------------------------------------------------- procedure Initialize; -- Initialize allocation of element list tables. Called at the start of -- compiling each new main source file. Note that Initialize must not be -- called if Tree_Read is used. function Last_Elist_Id return Elist_Id; -- Returns Id of last allocated element list header function Num_Elists return Nat; -- Number of currently allocated element lists function Last_Elmt_Id return Elmt_Id; -- Returns Id of last allocated list element function Unit (Elmt : Elmt_Id) return Unit_Id; -- Returns the value of a given list element. Returns Empty if Elmt -- is set to No_Elmt. function New_Elmt_List return Elist_Id; -- Creates a new empty element list. Typically this is used to initialize -- a field in some other node which points to an element list where the -- list is then subsequently filled in using Append calls. function First_Elmt (List : Elist_Id) return Elmt_Id; -- Obtains the first element of the given element list or, if the -- list has no items, then No_Elmt is returned. function Last_Elmt (List : Elist_Id) return Elmt_Id; -- Obtains the last element of the given element list or, if the -- list has no items, then No_Elmt is returned. function Next_Elmt (Elmt : Elmt_Id) return Elmt_Id; -- This function returns the next element on an element list. The argument -- must be a list element other than No_Elmt. Returns No_Elmt if the given -- element is the last element of the list. function Is_Empty_Elmt_List (List : Elist_Id) return Boolean; -- This function determines if a given tree id references an element list -- that contains no items. procedure Append_Elmt (Unit : Unit_Id; To : Elist_Id); -- Appends Unit at the end of To, allocating a new element. procedure Prepend_Elmt (Unit : Unit_Id; To : Elist_Id); -- Appends Unit at the beginning of To, allocating a new element. procedure Insert_Elmt_After (Unit : Unit_Id; Elmt : Elmt_Id); -- Add a new element (Unit) right after the pre-existing element Elmt -- It is invalid to call this subprogram with Elmt = No_Elmt. procedure Replace_Elmt (Elmt : Elmt_Id; New_Unit : Unit_Id); -- Causes the given element of the list to refer to New_Unit, the node -- which was previously referred to by Elmt is effectively removed from -- the list and replaced by New_Unit. procedure Remove_Elmt (List : Elist_Id; Elmt : Elmt_Id); -- Removes Elmt from the given list. The node itself is not affected, -- but the space used by the list element may be (but is not required -- to be) freed for reuse in a subsequent Append_Elmt call. procedure Remove_Last_Elmt (List : Elist_Id); -- Removes the last element of the given list. The node itself is not -- affected, but the space used by the list element may be (but is not -- required to be) freed for reuse in a subsequent Append_Elmt call. function No (List : Elist_Id) return Boolean; -- Tests given Id for equality with No_Elist. This allows notations like -- "if No (Statements)" as opposed to "if Statements = No_Elist". function Present (List : Elist_Id) return Boolean; -- Tests given Id for inequality with No_Elist. This allows notations like -- "if Present (Statements)" as opposed to "if Statements /= No_Elist". function No (Elmt : Elmt_Id) return Boolean; -- Tests given Id for equality with No_Elmt. This allows notations like -- "if No (Operation)" as opposed to "if Operation = No_Elmt". function Present (Elmt : Elmt_Id) return Boolean; -- Tests given Id for inequality with No_Elmt. This allows notations like -- "if Present (Operation)" as opposed to "if Operation /= No_Elmt". -------------------------------------- -- Subprograms added for ASIS needs -- -------------------------------------- procedure Add_To_Elmt_List (Unit : Unit_Id; List : in out Elist_Id); -- If List is equial to No_Lists, creates the new (empty) list, assigns -- it to List and appens Unit to this list. Otherwise, checks, if Unit -- already is in List, and if the check fails, appends Unit to List. -- -- This procedure is intended to be used during creating the dependency -- lists for a Unit. function In_Elmt_List (U : Unit_Id; List : Elist_Id) return Boolean; -- Checks if Unit is included in the given List. Returns False for -- No_List and for empty list. procedure Print_List (List : Elist_Id); -- Currently this procedure only produces the debug output for List function List_Length (List : Elist_Id) return Natural; -- Returns the number of items in the given list. It is an error to call -- this function with No_Elist. function Intersect (List1 : Elist_Id; List2 : Elist_Id) return Boolean; -- Checks if List1 and List2 have a common data element (that is, if -- one of them is No_List or empty element list, False is returned). function Belongs (List1 : Elist_Id; List2 : Elist_Id) return Boolean; -- Checks if all the elements of List1 belongs to List2. If List1 is -- equial to No_List, returns True procedure Move_List (List_From : Elist_Id; List_To : in out Elist_Id); -- Moves (prepends) the content of List_From to List_To. If List_To is -- equial to No_Elist, it is created. For now, this procedure does not -- check if the elements from List_From are already in List_To, therefore -- as a result of a call to this procedure, List_To can contain -- duplicated elements -- -- If before the call List_From was equal to No_List, it will be No_List -- after the call. In any other case List_From will be an empty list after -- the call ------------------------------------- -- Implementation of Element Lists -- ------------------------------------- -- Element lists are composed of three types of entities. The element -- list header, which references the first and last elements of the -- list, the elements themselves which are singly linked and also -- reference the nodes on the list, and finally the nodes themselves. -- The following diagram shows how an element list is represented: -- +----------------------------------------------------+ -- | +------------------------------------------+ | -- | | | | -- V | V | -- +-----|--+ +-------+ +-------+ +-------+ | -- | Elmt | | 1st | | 2nd | | Last | | -- | List |--->| Elmt |--->| Elmt ---...-->| Elmt ---+ -- | Header | | | | | | | | | | -- +--------+ +---|---+ +---|---+ +---|---+ -- | | | -- V V V -- +-------+ +-------+ +-------+ -- | | | | | | -- | Unit1 | | Unit2 | | Unit3 | -- | | | | | | -- +-------+ +-------+ +-------+ -- The list header is an entry in the Elists table. The values used for -- the type Elist_Id are subscripts into this table. The First_Elmt field -- (Lfield1) points to the first element on the list, or to No_Elmt in the -- case of an empty list. Similarly the Last_Elmt field (Lfield2) points to -- the last element on the list or to No_Elmt in the case of an empty list. -- The elements themselves are entries in the Elmts table. The Next field -- of each entry points to the next element, or to the Elist header if this -- is the last item in the list. The Unit field points to the node which -- is referenced by the corresponding list entry. -------------------------- -- Element List Tables -- -------------------------- type Elist_Header is record First : Elmt_Id; Last : Elmt_Id; end record; package Elists is new Table.Table ( Table_Component_Type => Elist_Header, Table_Index_Type => Elist_Id, Table_Low_Bound => First_Elist_Id, Table_Initial => Alloc.Elists_Initial, Table_Increment => Alloc.Elists_Increment, Table_Name => "Elists"); type Elmt_Item is record Unit : Unit_Id; Next : Union_Id; end record; package Elmts is new Table.Table ( Table_Component_Type => Elmt_Item, Table_Index_Type => Elmt_Id, Table_Low_Bound => First_Elmt_Id, Table_Initial => Alloc.Elmts_Initial, Table_Increment => Alloc.Elmts_Increment, Table_Name => "Elmts"); type Saved_Lists is record Saved_Elmts : Elmts.Saved_Table; Saved_Elists : Elists.Saved_Table; end record; end A4G.A_Elists; asis-2010.orig/asis/a4g-a_opt.adb0000644000175000017500000002253511574704441016374 0ustar lbrentalbrenta------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- -- -- A 4 G . A _ O P T -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- ASIS-for-GNAT 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 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 51 Franklin -- -- Street, Fifth Floor, Boston, MA 02110-1301, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by AdaCore -- -- (http://www.adacore.com). -- -- -- ------------------------------------------------------------------------------ with Asis.Errors; use Asis.Errors; with A4G.A_Types; use A4G.A_Types; with A4G.A_Osint; use A4G.A_Osint; with A4G.A_Output; use A4G.A_Output; with A4G.A_Debug; use A4G.A_Debug; with A4G.Vcheck; use A4G.Vcheck; with GNAT.OS_Lib; use GNAT.OS_Lib; package body A4G.A_Opt is ------------------------------------- -- Process_Finalization_Parameters -- ------------------------------------- procedure Process_Finalization_Parameters (Parameters : String) is Final_Parameters : Argument_List_Access; procedure Process_One_Parameter (Param : String); -- incapsulates processing of a separate parameter --------------------------- -- Process_One_Parameter -- --------------------------- procedure Process_One_Parameter (Param : String) is Parameter : constant String (1 .. Param'Length) := Param; begin ASIS_Warning (Message => "Asis.Implementation.Finalize: " & "unknown parameter - " & Parameter, Error => Parameter_Error); end Process_One_Parameter; begin -- Process_Finalization_Parameters Final_Parameters := Parameter_String_To_List (Parameters); for I in Final_Parameters'Range loop Process_One_Parameter (Final_Parameters (I).all); end loop; Free_Argument_List (Final_Parameters); end Process_Finalization_Parameters; --------------------------------------- -- Process_Initialization_Parameters -- --------------------------------------- procedure Process_Initialization_Parameters (Parameters : String) is Init_Parameters : Argument_List_Access; procedure Process_One_Parameter (Param : String); -- incapsulates processing of a separate parameter --------------------------- -- Process_One_Parameter -- --------------------------- procedure Process_One_Parameter (Param : String) is Parameter : constant String (1 .. Param'Length) := Param; Unknown_Parameter : Boolean := False; subtype Dig is Character range '1' .. '9'; subtype Let is Character range 'a' .. 'z'; procedure Process_Parameter; procedure Process_Option; -- Process_Option works if Param starts from '-', and -- Process_Parameter works otherwise procedure Process_Parameter is begin -- no parameter is currently available as an ASIS initialization -- parameter Raise_ASIS_Failed (Diagnosis => "Asis.Implementation.Initialize: " & "unknown parameter - " & Parameter, Stat => Parameter_Error, Internal_Bug => False); end Process_Parameter; procedure Process_Option is begin case Parameter (2) is when 'a' => if Parameter = "-asis05" then ASIS_2005_Mode := True; elsif Parameter = "-asis95" then ASIS_2005_Mode := False; else Unknown_Parameter := True; end if; when 'd' => if Parameter'Length = 3 and then (Parameter (3) in Dig or else Parameter (3) in Let) then Set_Debug_Flag (Parameter (3)); elsif Parameter = "-dall" then A4G.A_Debug.Set_On; else Unknown_Parameter := True; end if; when 'k' => if Parameter = "-k" then Keep_Going := True; else Unknown_Parameter := True; end if; when 'n' => if Parameter = "-nbb" then Generate_Bug_Box := False; Keep_Going := True; else Unknown_Parameter := True; end if; when 's' => if Parameter = "-sv" then Strong_Version_Check := True; else Unknown_Parameter := True; end if; when 'w' => if Parameter = "-ws" then ASIS_Warning_Mode := Suppress; elsif Parameter = "-we" then ASIS_Warning_Mode := Treat_As_Error; else Unknown_Parameter := True; end if; when others => Unknown_Parameter := True; end case; if Unknown_Parameter then Raise_ASIS_Failed (Diagnosis => "Asis.Implementation.Initialize: " & "unknown option - " & Parameter, Stat => Parameter_Error, Internal_Bug => False); end if; end Process_Option; begin -- Process_One_Parameter if Parameter (1) = '-' then if Parameter'Length >= 2 then Process_Option; else Raise_ASIS_Failed (Diagnosis => "Asis.Implementation.Initialize: " & "Option is missing after ""-""", Stat => Parameter_Error, Internal_Bug => False); end if; else Process_Parameter; end if; end Process_One_Parameter; begin -- Process_Initialization_Parameters Init_Parameters := Parameter_String_To_List (Parameters); for I in Init_Parameters'Range loop Process_One_Parameter (Init_Parameters (I).all); end loop; Free_Argument_List (Init_Parameters); end Process_Initialization_Parameters; ------------- -- Set_Off -- ------------- procedure Set_Off is begin Is_Initialized := False; ASIS_Warning_Mode := Normal; Strong_Version_Check := False; Generate_Bug_Box := True; Keep_Going := False; ASIS_2005_Mode := False; end Set_Off; end A4G.A_Opt; asis-2010.orig/asis/a4g-a_opt.ads0000644000175000017500000002001111574704441016400 0ustar lbrentalbrenta------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- A 4 G . A _ O P T -- -- -- -- S p e c -- -- -- -- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- -- -- -- ASIS-for-GNAT 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 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 51 Franklin -- -- Street, Fifth Floor, Boston, MA 02110-1301, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by AdaCore -- -- (http://www.adacore.com). -- -- -- ------------------------------------------------------------------------------ -- This package contains global switches set by the -- Asis_Environment.Initialize routine from the Parameters siting and -- referenced throughout the ASIS-for-GNAT -- -- This package may be considered as an ASIS analog of the GNAT Opt -- package package A4G.A_Opt is Is_Initialized : Boolean := False; -- flag indicating if the environment has already been initialized. Was_Initialized_At_Least_Once : Boolean := False; -- flag indicating if the environment was initialized at least -- once during the current launch of an ASIS application type ASIS_Warning_Mode_Type is (Suppress, Normal, Treat_As_Error); ASIS_Warning_Mode : ASIS_Warning_Mode_Type := Normal; -- Controls treatment of warning messages. If set to Suppress, warning -- messages are not generated at all. In Normal mode, they are generated -- but do not count as errors. In Treat_As_Error mode, a warning is -- treated as an error: ASIS_Failed is raised and the warning message is -- sent to an ASIS Diagnosis string. Strong_Version_Check : Boolean := False; -- Strong version check means that version strings read from the tree and -- stored in Gnatvsn are compared. Weak check means comparing ASIS version -- numbers. See BA23-002 Generate_Bug_Box : Boolean := True; -- Flag indicating if the ASIS bug box should be generated into Stderr -- when an ASIS implementation bug is detected. Keep_Going : Boolean := False; -- Flag indicating if the exit to OS should NOT be generated in case if -- ASIS internal implementation error. Set ON by Initialize '-k' parameter. ASIS_2005_Mode : Boolean := False; -- Temporary ASIS 2005 mode. If this switch is ON, ASIS does not reject -- trees created with '-gnat05' option, and implemented ASIS 2005 features -- does not blow up when called. -- This flag should be removed when ASIS 2005 revision is complete procedure Process_Initialization_Parameters (Parameters : String); -- Processes a Parameters string passed to the -- Asis.Implementation.Initialize query: check parameters and makes the -- corresponding settings for ASIS global switches and flags. procedure Process_Finalization_Parameters (Parameters : String); -- Processes a Parameters string passed to the -- Asis.Implementation.Finalize query. procedure Set_Off; -- Sets Is_Initialized flag OFF and then sets all the global switches -- except Was_Initialized_At_Least_Once in the initial (default) position. -- Is to be called by Asis_Environment.Finalize -- the type declarations below should probably be moved into A_Types??? type Context_Mode is -- different ways to define an ASIS Context: (One_Tree, -- a Context is made up by only one tree file N_Trees, -- a Context is made up by N tree files Partition, -- a partition Context All_Trees); -- all the tree files in tree search path are considered as making up a -- given Context type Tree_Mode is -- how ASIS deals with tree files (On_The_Fly, -- trees are created on the fly, created trees are reused as long as a -- Context remains opened Pre_Created, -- only those trees which have been created before a Context is opened -- are used Mixed, -- mixed approach - if ASIS cannot find a needed tree, it tries to -- create it on the fly Incremental, -- Similar to Mixed, but these mode goes beyond the ASIS standard and -- allows to change the environment when the Context remains open: -- - when the Context is opened, all the existing trees are processed; -- - if ASIS can not find a needed tree, it tries to create it on the -- fly, and it refreshes the information in the Context unit table -- using the data from this newly created tree; -- - any access to a unit or to an element checks that a tree to be -- accessed is consistent with the sources -- ???? This documentation definitely needs revising??? GNSA -- Any tree is created on the fly by calling GNSA. It is not written -- in a tree file and then read back by ASIS, but it is left in the -- same data structures where it has been created, and after that ASIS -- works on the same data structures. ); type Source_Mode is -- how ASIS takes into account source files when checking the consistency (All_Sources, -- sources of all the units from a given Context (except the predefined -- Standard package) should be around, and they should be the same as -- the sources from which tree files making up the Context were created Existing_Sources, -- If for a given unit from the Context the corresponding source file -- exists, it should be the same as those used to create tree files -- making up the Context No_Sources); -- Existing source files are not taken into account when checking the -- consistency of tree files end A4G.A_Opt; asis-2010.orig/asis/a4g-a_osint.adb0000644000175000017500000001211611574704441016720 0ustar lbrentalbrenta------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- A 4 G . A _ O S I N T -- -- -- -- B o d y -- -- -- -- Copyright (c) 1995-1999, Free Software Foundation, Inc. -- -- -- -- ASIS-for-GNAT 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 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 59 Temple Place -- -- - Suite 330, Boston, MA 02111-1307, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by Ada Core Technologies Inc -- -- (http://www.gnat.com). -- -- -- ------------------------------------------------------------------------------ with Unchecked_Deallocation; package body A4G.A_Osint is ----------------------- -- Local subprograms -- ----------------------- procedure Free_String is new Unchecked_Deallocation (String, String_Access); procedure Free_List is new Unchecked_Deallocation (Argument_List, Argument_List_Access); ------------------------ -- Free_Argument_List -- ------------------------ procedure Free_Argument_List (List : in out Argument_List_Access) is begin if List = null then return; end if; for J in List'Range loop Free_String (List (J)); end loop; Free_List (List); end Free_Argument_List; ------------------------------ -- Get_Max_File_Name_Length -- ------------------------------ function Get_Max_File_Name_Length return Int is function Get_Maximum_File_Name_Length return Int; pragma Import (C, Get_Maximum_File_Name_Length, "__gnat_get_maximum_file_name_length"); -- This function does what we want, but it returns -1 when there -- is no restriction on the file name length -- -- The implementation has been "stolen" from the body of GNAT -- Osint.Initialize begin if Get_Maximum_File_Name_Length = -1 then return Int'Last; else return Get_Maximum_File_Name_Length; end if; end Get_Max_File_Name_Length; ------------------------------ -- Normalize_Directory_Name -- ------------------------------ function Normalize_Directory_Name (Directory : String) return String is begin -- For now this just insures that the string is terminated with -- the directory separator character. Add more later? if Directory (Directory'Last) = Directory_Separator then return Directory; elsif Directory'Length = 0 then -- now we do not need this, but it is no harm to keep it return '.' & Directory_Separator; else return Directory & Directory_Separator; end if; end Normalize_Directory_Name; end A4G.A_Osint; asis-2010.orig/asis/a4g-a_osint.ads0000644000175000017500000001022211574704441016735 0ustar lbrentalbrenta------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- A 4 G . A _ O S I N T -- -- -- -- S p e c -- -- -- -- Copyright (c) 1995-1999, Free Software Foundation, Inc. -- -- -- -- ASIS-for-GNAT 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 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 59 Temple Place -- -- - Suite 330, Boston, MA 02111-1307, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by Ada Core Technologies Inc -- -- (http://www.gnat.com). -- -- -- ------------------------------------------------------------------------------ -- The original idea of this package was to be an ASIS analog of the GNAT -- Osint package and to contain the low-level routines needed by different -- components of the ASIS implementation. But its current version contains a -- very few routines, so probably we should merge this package with some -- other ASIS implementation utility package. with GNAT.OS_Lib; use GNAT.OS_Lib; with Types; use Types; package A4G.A_Osint is function Normalize_Directory_Name (Directory : String) return String; -- Verify and normalize a directory name. If directory name is invalid, -- this will return an empty string (not implemented for now - all the -- checks should be made by a caller). Otherwise it will insure a -- trailing directory separator and make other normalizations. function Get_Max_File_Name_Length return Int; -- yields the maximum file name length for system. Returns Int'Last, -- if the system does not limit the maximum file name length. procedure Free_Argument_List (List : in out Argument_List_Access); -- if List is not null, frees the memory occupied by its content end A4G.A_Osint; asis-2010.orig/asis/a4g-a_output.adb0000644000175000017500000004340111574704441017125 0ustar lbrentalbrenta------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- A 4 G . A _ O U T P U T -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- ASIS-for-GNAT 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 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 51 Franklin -- -- Street, Fifth Floor, Boston, MA 02110-1301, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by AdaCore -- -- (http://www.adacore.com). -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; use Ada.Exceptions; with Ada.Strings.Fixed; use Ada.Strings.Fixed; with Asis.Text; use Asis.Text; with Asis.Elements; use Asis.Elements; with A4G.A_Debug; use A4G.A_Debug; with A4G.A_Types; use A4G.A_Types; with A4G.Int_Knds; use A4G.Int_Knds; with A4G.Contt; use A4G.Contt; with A4G.Contt.UT; use A4G.Contt.UT; with A4G.Contt.TT; use A4G.Contt.TT; with A4G.A_Opt; use A4G.A_Opt; with A4G.Vcheck; use A4G.Vcheck; with Asis.Set_Get; use Asis.Set_Get; with Atree; use Atree; with Namet; use Namet; with Output; use Output; with Sinfo; use Sinfo; with Sinput; use Sinput; package body A4G.A_Output is LT : String renames A4G.A_Types.ASIS_Line_Terminator; --------- -- Add -- --------- procedure Add (Phrase : String) is begin if Debug_Buffer_Len = Max_Debug_Buffer_Len then return; end if; for I in Phrase'Range loop Debug_Buffer_Len := Debug_Buffer_Len + 1; Debug_Buffer (Debug_Buffer_Len) := Phrase (I); if Debug_Buffer_Len = Max_Debug_Buffer_Len then exit; end if; end loop; end Add; ------------------ -- ASIS_Warning -- ------------------ procedure ASIS_Warning (Message : String; Error : Asis.Errors.Error_Kinds := Not_An_Error) is begin case ASIS_Warning_Mode is when Suppress => null; when Normal => Set_Standard_Error; Write_Str ("ASIS warning: "); Write_Eol; Write_Str (Message); Write_Eol; Set_Standard_Output; when Treat_As_Error => -- ??? Raise_ASIS_Failed should be revised to use like that Raise_ASIS_Failed ( Argument => Nil_Element, Diagnosis => Message, Stat => Error); end case; end ASIS_Warning; -------------------------------------- -- Debug_String (Compilation Unit) -- -------------------------------------- -- SHOULD BE REVISED USING Debug_Buffer!!! function Debug_String (CUnit : Compilation_Unit) return String is LT : String renames A4G.A_Types.ASIS_Line_Terminator; U : Unit_Id; C : Context_Id; begin U := Get_Unit_Id (CUnit); C := Encl_Cont_Id (CUnit); if No (U) then return "This is a Nil Compilation Unit"; else Reset_Context (C); return LT & "Unit Id: " & Unit_Id'Image (U) & LT & " Unit name: " & Unit_Name (CUnit) & LT & " Kind: " & Asis.Unit_Kinds'Image (Kind (C, U)) & LT & " Class: " & Asis.Unit_Classes'Image (Class (C, U)) & LT & " Origin: " & Asis.Unit_Origins'Image (Origin (C, U)) & LT & " Enclosing Context Id: " & Context_Id'Image (C) & LT & " Is consistent: " & Boolean'Image (Is_Consistent (C, U)) & LT & "-------------------------------------------------"; end if; end Debug_String; procedure Debug_String (CUnit : Compilation_Unit; No_Abort : Boolean := False) is LT : String renames A4G.A_Types.ASIS_Line_Terminator; U : Unit_Id; C : Context_Id; begin Debug_Buffer_Len := 0; U := Get_Unit_Id (CUnit); C := Encl_Cont_Id (CUnit); if No (U) then Add ("This is a Nil Compilation Unit"); else Reset_Context (C); Add (LT); Add ("Unit Id: " & Unit_Id'Image (U) & LT); Add (" Unit name: " & Unit_Name (CUnit) & LT); Add (" Kind: " & Asis.Unit_Kinds'Image (Kind (C, U)) & LT); Add (" Class: " & Asis.Unit_Classes'Image (Class (C, U)) & LT); Add (" Origin: " & Asis.Unit_Origins'Image (Origin (C, U)) & LT); Add (" Enclosing Context Id: " & Context_Id'Image (C) & LT); Add (" Is consistent: " & Boolean'Image (Is_Consistent (C, U)) & LT); Add ("-------------------------------------------------"); end if; exception when Ex : others => if No_Abort then Add (LT & "Can not complete the unit debug image because of" & LT); Add (Exception_Information (Ex)); else raise; end if; end Debug_String; ----------------------------- -- Debug_String (Context) -- ----------------------------- -- SHOULD BE REVISED USING Debug_Buffer!!! function Debug_String (Cont : Context) return String is LT : String renames A4G.A_Types.ASIS_Line_Terminator; C : constant Context_Id := Get_Cont_Id (Cont); Debug_String_Prefix : constant String := "Context Id: " & Context_Id'Image (C) & LT; begin if C = Non_Associated then return Debug_String_Prefix & " This Context has never been associated"; elsif not Is_Associated (C) and then not Is_Opened (C) then return Debug_String_Prefix & " This Context is dissociated at the moment"; elsif not Is_Opened (C) then -- here Is_Associated (C) return Debug_String_Prefix & " This Context has associations," & LT & " but it is closed at the moment"; else -- here Is_Associated (C) and Is_Opened (C) return Debug_String_Prefix & " This Context is opened at the moment" & LT & " All tree files: " & Tree_Id'Image (Last_Tree (C) - First_Tree_Id + 1) & LT & " All units: " & Unit_Id'Image (Last_Unit - First_Unit_Id + 1) & LT & " Existing specs : " & Natural'Image (Lib_Unit_Decls (C)) & LT & " Existing bodies: " & Natural'Image (Comp_Unit_Bodies (C)) & LT & " Nonexistent units:" & Natural'Image (Natural (Last_Unit - First_Unit_Id + 1) - (Lib_Unit_Decls (C) + Comp_Unit_Bodies (C))) & LT & "================="; end if; end Debug_String; ----------------------------- -- Debug_String (Element) -- ----------------------------- procedure Debug_String (E : Element; No_Abort : Boolean := False) is E_Kind : constant Internal_Element_Kinds := Int_Kind (E); E_Kind_Image : constant String := Internal_Element_Kinds'Image (E_Kind); E_Unit : constant Asis.Compilation_Unit := Encl_Unit (E); E_Unit_Class : constant Unit_Classes := Class (E_Unit); N : constant Node_Id := Node (E); R_N : constant Node_Id := R_Node (E); N_F_1 : constant Node_Id := Node_Field_1 (E); N_F_2 : constant Node_Id := Node_Field_2 (E); C : constant Context_Id := Encl_Cont_Id (E); T : constant Tree_Id := Encl_Tree (E); begin Debug_Buffer_Len := 0; if Is_Nil (E) then Add ("This is a Nil Element"); else Add (E_Kind_Image); Add (LT & "located in "); Add (Unit_Name (E_Unit)); if E_Unit_Class = A_Separate_Body then Add (" (subunit, Unit_Id ="); elsif E_Unit_Class = A_Public_Declaration or else E_Unit_Class = A_Private_Declaration then Add (" (spec, Unit_Id ="); else Add (" (body, Unit_Id ="); end if; Add (Unit_Id'Image (Encl_Unit_Id (E))); Add (", Context_Id ="); Add (Context_Id'Image (C)); Add (")" & LT); if not (Debug_Flag_I) then Add ("text position :"); if not Is_Text_Available (E) then -- Creating the source location from the element node if Sloc (N) <= No_Location then Add (" not available"); Add (LT); else Add (" "); declare use Ada.Strings; P : Source_Ptr; Sindex : Source_File_Index; Instance_Depth : Natural := 0; procedure Enter_Sloc; -- For the current value of P, adds to the debug string -- the string of the form file_name:line_number. Also -- computes Sindex as the Id of the sourse file of P. procedure Enter_Sloc is F_Name : File_Name_Type; begin Sindex := Get_Source_File_Index (P); F_Name := File_Name (Sindex); Get_Name_String (F_Name); Add (Name_Buffer (1 .. Name_Len) & ":"); Add (Trim (Get_Physical_Line_Number (P)'Img, Both)); Add (":"); Add (Trim (Get_Column_Number (P)'Img, Both)); end Enter_Sloc; begin P := Sloc (N); Enter_Sloc; P := Instantiation (Sindex); while P /= No_Location loop Add ("["); Instance_Depth := Instance_Depth + 1; Enter_Sloc; P := Instantiation (Sindex); end loop; for J in 1 .. Instance_Depth loop Add ("]"); end loop; Add (LT); end; end if; else declare Arg_Span : Span; FL : String_Ptr; LL : String_Ptr; FC : String_Ptr; LC : String_Ptr; begin -- this operation is potentially dangerous - it may -- change the tree (In fact, it should not, if we -- take into account the typical conditions when -- this routine is called Arg_Span := Element_Span (E); FL := new String'(Line_Number'Image (Arg_Span.First_Line)); LL := new String'(Line_Number'Image (Arg_Span.Last_Line)); FC := new String'(Character_Position'Image (Arg_Span.First_Column)); LC := new String'(Character_Position'Image (Arg_Span.Last_Column)); Add (FL.all); Add (" :"); Add (FC.all); Add (" -"); Add (LL.all); Add (" :"); Add (LC.all); Add (LT); end; end if; end if; Add (" Nodes:" & LT); Add (" Node :" & Node_Id'Image (N)); Add (" - " & Node_Kind'Image (Nkind (N)) & LT); Add (" R_Node :" & Node_Id'Image (R_N)); Add (" - " & Node_Kind'Image (Nkind (R_N)) & LT); Add (" Node_Field_1 :" & Node_Id'Image (N_F_1)); Add (" - " & Node_Kind'Image (Nkind (N_F_1)) & LT); Add (" Node_Field_2 :" & Node_Id'Image (N_F_2)); Add (" - " & Node_Kind'Image (Nkind (N_F_2)) & LT); Add (" Rel_Sloc :"); Add (Source_Ptr'Image (Rel_Sloc (E)) & LT); if Special_Case (E) /= Not_A_Special_Case then Add (" Special Case : "); Add (Special_Cases'Image (Special_Case (E)) & LT); end if; if Special_Case (E) = Stand_Char_Literal or else Character_Code (E) /= 0 then Add (" Character_Code :"); Add (Char_Code'Image (Character_Code (E)) & LT); end if; case Normalization_Case (E) is when Is_Normalized => Add (" Normalized" & LT); when Is_Normalized_Defaulted => Add (" Normalized (with default value)" & LT); when Is_Normalized_Defaulted_For_Box => Add (" Normalized (with default value computed for box)" & LT); when Is_Not_Normalized => null; end case; if Parenth_Count (E) > 0 then Add (" Parenth_Count :"); Add (Nat'Image (Parenth_Count (E)) & LT); end if; if Is_From_Implicit (E) then Add (" Is implicit" & LT); end if; if Is_From_Inherited (E) then Add (" Is inherited" & LT); end if; if Is_From_Instance (E) then Add (" Is from instance" & LT); end if; Add (" obtained from the tree "); if Present (T) then Get_Name_String (C, T); Add (A_Name_Buffer (1 .. A_Name_Len)); Add (" (Tree_Id =" & Tree_Id'Image (T) & ")"); else Add (" "); end if; end if; exception when Ex : others => if No_Abort then Add (LT & "Can not complete the unit debug image because of" & LT); Add (Exception_Information (Ex)); else raise; end if; end Debug_String; ---------------- -- Write_Node -- ---------------- procedure Write_Node (N : Node_Id; Prefix : String := "") is begin Write_Str (Prefix); Write_Str ("Node_Id = "); Write_Int (Int (N)); Write_Eol; Write_Str (Prefix); Write_Str ("Nkind = "); Write_Str (Node_Kind'Image (Nkind (N))); Write_Eol; Write_Str (Prefix); Write_Str ("Rewrite_Sub value : "); Write_Str (Boolean'Image (Is_Rewrite_Substitution (N))); Write_Eol; Write_Str (Prefix); Write_Str ("Rewrite_Ins value : "); Write_Str (Boolean'Image (Is_Rewrite_Insertion (N))); Write_Eol; Write_Str (Prefix); Write_Str ("Comes_From_Source value : "); Write_Str (Boolean'Image (Comes_From_Source (N))); Write_Eol; if Original_Node (N) = N then Write_Str (Prefix); Write_Str (" Node is unchanged"); Write_Eol; elsif Original_Node (N) = Empty then Write_Str (Prefix); Write_Str (" Node has been inserted"); Write_Eol; else Write_Str (Prefix); Write_Str (" Node has been rewritten"); Write_Eol; Write_Node (N => Original_Node (N), Prefix => Write_Node.Prefix & " Original node -> "); end if; Write_Eol; end Write_Node; end A4G.A_Output; asis-2010.orig/asis/a4g-a_output.ads0000644000175000017500000001346011574704441017150 0ustar lbrentalbrenta------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- A 4 G . A _ O U T P U T -- -- -- -- S p e c -- -- -- -- $Revision: 15311 $ -- -- -- Copyright (c) 1995-2002, Free Software Foundation, Inc. -- -- -- -- ASIS-for-GNAT 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 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 59 Temple Place -- -- - Suite 330, Boston, MA 02111-1307, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by Ada Core Technologies Inc -- -- (http://www.gnat.com). -- -- -- ------------------------------------------------------------------------------ -- This package contains the utility routines used for providing ASIS -- warnings, debug images for ASIS types and internal debugging information. with Asis; use Asis; with Asis.Errors; use Asis.Errors; with Types; use Types; package A4G.A_Output is Max_Debug_Buffer_Len : Natural := 8 * 1024; Debug_Buffer : String (1 .. Max_Debug_Buffer_Len); Debug_Buffer_Len : Natural range 0 .. Max_Debug_Buffer_Len; -- buffer to form debug image strings procedure Add (Phrase : String); -- Adds Phrase to Debug_Buffer and resets Debug_Buffer_Len procedure ASIS_Warning (Message : String; Error : Asis.Errors.Error_Kinds := Not_An_Error); -- Produces a warning message (the text of the message is the string -- passed as an actual for the Message parameter. The effect of calling -- this procedure depends on which ASIS warning mode was set when ASIS was -- initialized. In case of Suppress nothing happens, in case of Normal -- Message is sent to Stderr, and in case of Treat_As_Error the warning -- is converted into raising ASIS_Failed, Message is sent to ASIS diagnosis -- and the value of the Error parameter is set to the ASIS Error Status function Debug_String (CUnit : Compilation_Unit) return String; -- Produces the string containing debug information about CUnit function Debug_String (Cont : Context) return String; -- Produces the string containing debug information about Cont procedure Debug_String (CUnit : Compilation_Unit; No_Abort : Boolean := False); -- Produces the string containing debug information about CUnit -- Forms in Debug_Buffer the string containing debug information about -- the argument unit. If No_Abort is set ON, then any exception raised -- inside this procedure is suppressed and the message about suppressed -- exception is added to the result string. This is needed to avoid -- circularity during reporting of ASIS implementation bug. procedure Debug_String (E : Element; No_Abort : Boolean := False); -- Forms in Debug_Buffer the string containing debug information about E -- If No_Abort is set ON, then any exception raised inside this procedure -- is suppressed and the message about suppressed exception is added to -- the result string. This is needed to avoid circularity during reporting -- of ASIS implementation bug. procedure Write_Node (N : Node_Id; Prefix : String := ""); -- outputs the tree node attributes without using any facilities -- from the GNAT Treepr package. The string passed as an actual for -- Prefix is outputted in the beginning of every string end A4G.A_Output; asis-2010.orig/asis/a4g-a_sem.adb0000644000175000017500000020606211574704441016355 0ustar lbrentalbrenta------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- A 4 G . A _ S E M -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- -- -- -- ASIS-for-GNAT 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 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 51 Franklin -- -- Street, Fifth Floor, Boston, MA 02110-1301, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by AdaCore -- -- (http://www.adacore.com). -- -- -- ------------------------------------------------------------------------------ with Asis.Elements; use Asis.Elements; with Asis.Extensions; use Asis.Extensions; with Asis.Iterator; use Asis.Iterator; with Asis.Set_Get; use Asis.Set_Get; with A4G.A_Types; use A4G.A_Types; with A4G.Contt.TT; use A4G.Contt.TT; use A4G.Contt; with A4G.Contt.UT; use A4G.Contt.UT; with A4G.Int_Knds; use A4G.Int_Knds; with A4G.Mapping; use A4G.Mapping; with Atree; use Atree; with Namet; use Namet; with Nlists; use Nlists; with Sem_Aux; use Sem_Aux; with Sinfo; use Sinfo; with Sinput; use Sinput; with Snames; use Snames; package body A4G.A_Sem is ---------------------- -- Local subprogram -- ---------------------- function Is_Importing_Pragma (N : Node_Id; For_Name : Name_Id) return Boolean; -- Checks if N is a node representing Import or Interface pragma that -- is applied to the name For_Name ------------------------------ -- Char_Defined_In_Standard -- ------------------------------ function Char_Defined_In_Standard (N : Node_Id) return Boolean is N_Etype : Node_Id; begin N_Etype := Etype (N); if No (N_Etype) then -- It may happen for array literal rewritten into a string literal, -- so some additional digging is needed N_Etype := Parent (N); if Nkind (N_Etype) = N_String_Literal then N_Etype := Etype (N_Etype); if Ekind (N_Etype) = E_String_Literal_Subtype then N_Etype := Component_Type (N_Etype); end if; else N_Etype := Empty; end if; end if; return Present (N_Etype) and then Sloc (N_Etype) <= Standard_Location; end Char_Defined_In_Standard; ------------------------ -- Corr_Decl_For_Stub -- ------------------------ function Corr_Decl_For_Stub (Stub_Node : Node_Id) return Node_Id is Result_Node : Node_Id := Empty; Stub_Entity_Node : Node_Id; Scope_Node : Node_Id; Search_Node : Node_Id; Search_Node_Kind : Node_Kind; List_To_Search : List_Id; Search_In_Package : Boolean; Decl_Found : Boolean := False; Priv_Decl_Passed : Boolean := False; Body_Passed : Boolean := False; procedure Search_In_List; -- looks for a possible subprogram declaration node for which -- the given stub is a completion, using global settings for -- List_To_Search and Search_Node function Is_Spec_For_Stub (Search_Node : Node_Id; Stub_Node : Node_Id; Stub_Entity_Node : Node_Id) return Boolean; -- check if the current Search_Node is a corresponding definition -- for a given stub. We cannot directly use the Corresponding_Body -- field here, because in case when subunits are around, this field -- will point to a proper body of a subunit, but not to a stub -- This function is called only for those nodes for which -- Corresponding_Body field makes sense function Is_Spec_For_Stub (Search_Node : Node_Id; Stub_Node : Node_Id; Stub_Entity_Node : Node_Id) return Boolean is Corr_Body_Node : constant Node_Id := Corresponding_Body (Search_Node); N : Node_Id; begin if Corr_Body_Node = Stub_Entity_Node then return True; else -- we have to check if we are in the proper body of a subunit N := Parent (Corr_Body_Node); if Nkind (N) = N_Procedure_Specification or else Nkind (N) = N_Function_Specification then N := Parent (N); end if; N := Parent (N); -- now, in case of subunit's parent body, we should be in -- N_Subunit node if Nkind (N) = N_Subunit then return Corresponding_Stub (N) = Stub_Node; else return False; end if; end if; end Is_Spec_For_Stub; procedure Search_In_List is begin while Present (Search_Node) loop Search_Node_Kind := Nkind (Search_Node); if (Search_Node_Kind = N_Subprogram_Declaration or else Search_Node_Kind = N_Generic_Subprogram_Declaration or else Search_Node_Kind = N_Package_Declaration or else Search_Node_Kind = N_Generic_Package_Declaration or else Search_Node_Kind = N_Single_Task_Declaration or else Search_Node_Kind = N_Task_Type_Declaration or else Search_Node_Kind = N_Single_Protected_Declaration or else Search_Node_Kind = N_Protected_Type_Declaration) and then Is_Spec_For_Stub (Search_Node, Stub_Node, Stub_Entity_Node) -- ???Corresponding_Body (Search_Node) = Stub_Entity_Node then -- the corresponding declaration for the stub is found Result_Node := Search_Node; Decl_Found := True; return; elsif Search_Node = Stub_Node then -- no need to search any mode, no declaration exists, -- the stub itself works as a declaration Decl_Found := True; return; end if; Search_Node := Next_Non_Pragma (Search_Node); end loop; end Search_In_List; begin -- Corr_Decl_For_Stub -- first, setting Stub_Entity_Node: if Nkind (Stub_Node) = N_Subprogram_Body_Stub then Stub_Entity_Node := Defining_Unit_Name (Specification (Stub_Node)); else Stub_Entity_Node := Defining_Identifier (Stub_Node); end if; -- then, defining the scope node and list to search in: Scope_Node := Scope (Stub_Entity_Node); if No (Scope_Node) then -- Unfortunately, this is the case for stubs of generic units -- with no (non-generic) parameters Scope_Node := Stub_Entity_Node; while not (Nkind (Scope_Node) = N_Package_Body or else Nkind (Scope_Node) = N_Subprogram_Body) loop Scope_Node := Parent (Scope_Node); end loop; if Nkind (Scope_Node) = N_Package_Body then Scope_Node := Corresponding_Spec (Scope_Node); else Scope_Node := Defining_Unit_Name (Specification (Scope_Node)); end if; end if; if Ekind (Scope_Node) = E_Generic_Package or else Ekind (Scope_Node) = E_Package then Search_In_Package := True; Scope_Node := Parent (Scope_Node); if Nkind (Scope_Node) = N_Defining_Program_Unit_Name then -- we are in a child library package Scope_Node := Parent (Scope_Node); end if; -- now we are in the package spec List_To_Search := Visible_Declarations (Scope_Node); if No (List_To_Search) then List_To_Search := Private_Declarations (Scope_Node); Priv_Decl_Passed := True; if No (List_To_Search) then List_To_Search := List_Containing (Stub_Node); -- what else could it be? Body_Passed := True; end if; end if; else Search_In_Package := False; List_To_Search := List_Containing (Stub_Node); -- The following code was here for many years, but it seems that the -- only effect of this conditional processing is failures in case -- if we have a stub following the corresponding declaration in the -- body of library generic subprogram. We keep it commented out just -- in case. -- -- The situation of the stub for generic subprogram having -- -- (non-generic) parameters makes a special case: -- if Ekind (Scope_Node) in Generic_Unit_Kind -- and then -- Corresponding_Stub (Parent (Parent (Parent (Corresponding_Body -- (Parent (Parent (Scope_Node))))))) = -- Stub_Node -- then -- return Parent (Parent (Scope_Node)); -- else -- Search_In_Package := False; -- List_To_Search := List_Containing (Stub_Node); -- end if; end if; Search_Node := First_Non_Pragma (List_To_Search); Search_In_List; -- now, if we are in a package, and if we have not found the result -- (or passed the stub node), we have to continue: if Search_In_Package and then not Decl_Found then -- where should we continue the search? if not Priv_Decl_Passed then List_To_Search := Private_Declarations (Scope_Node); Priv_Decl_Passed := True; if No (List_To_Search) then List_To_Search := List_Containing (Stub_Node); Body_Passed := True; end if; elsif not Body_Passed then List_To_Search := List_Containing (Stub_Node); Body_Passed := True; end if; Search_Node := First_Non_Pragma (List_To_Search); Search_In_List; if not Decl_Found then -- if we are here, we have to search the package body, -- where the stub itself is List_To_Search := List_Containing (Stub_Node); Search_Node := First_Non_Pragma (List_To_Search); Search_In_List; end if; end if; return Result_Node; end Corr_Decl_For_Stub; ------------------------- -- Defined_In_Standard -- ------------------------- function Defined_In_Standard (N : Node_Id) return Boolean is N_Entity : Node_Id := Empty; N_Etype : Node_Id := Empty; Result : Boolean := False; begin if Nkind (N) in N_Has_Entity then N_Entity := Entity (N); elsif Nkind (N) in Sinfo.N_Entity then N_Entity := N; end if; if Present (N_Entity) then N_Etype := Etype (N_Entity); end if; Result := Present (N_Entity) and then Present (N_Etype) and then Sloc (N_Entity) <= Standard_Location and then Sloc (N_Etype) <= Standard_Location; return Result; end Defined_In_Standard; -------------------------------- -- Explicit_Parent_Subprogram -- -------------------------------- function Explicit_Parent_Subprogram (E : Entity_Id) return Entity_Id is Result : Entity_Id := Empty; E_Ekind : constant Entity_Kind := Ekind (E); Parent_Type : Entity_Id; Tmp_Res : Entity_Id; begin -- The problem here is that we can not just traverse the Alias chain, -- because in case if the parent subprogram is declared by the -- subprogram renaming and the renamed entity is an intrinsic -- subprogram, the Alias field of the derived subprogram will -- point not to the parent renaming declaration, but to this -- intrinsic subprogram (see F407-016). if Is_Intrinsic_Subprogram (E) and then Present (Alias (E)) and then Defined_In_Standard (Alias (E)) then -- Here we may have a renaming declaration, and the renamed entity -- is a predefined operation. So we have to traverse the derivation -- chain and to try to locate the explicit renaming that is the cause -- of the existing of this derived subprogram. Parent_Type := Etype (E); Parent_Type := Etype (Parent_Type); Parent_Type := Parent (Parent_Type); Parent_Type := Defining_Identifier (Parent_Type); -- Here we should have Parent_Type pointing to the entity of the -- parent type Tmp_Res := Next_Entity (Parent_Type); while Present (Tmp_Res) loop if Ekind (Tmp_Res) = E_Ekind and then Is_Intrinsic_Subprogram (Tmp_Res) and then Chars (Tmp_Res) = Chars (E) and then Alias (Tmp_Res) = Alias (E) then Result := Tmp_Res; exit; end if; Tmp_Res := Next_Entity (Tmp_Res); end loop; if Present (Result) and then not Comes_From_Source (Result) then Result := Explicit_Parent_Subprogram (Result); end if; else Result := Alias (E); while Present (Alias (Result)) and then not Comes_From_Source (Result) loop Result := Alias (Result); end loop; end if; return Result; end Explicit_Parent_Subprogram; -------------------------- -- Get_Actual_Type_Name -- -------------------------- function Get_Actual_Type_Name (Type_Mark_Node : Node_Id) return Node_Id is Result : Node_Id := Type_Mark_Node; Tmp_Node : Node_Id; begin if Is_From_Instance (Type_Mark_Node) then Tmp_Node := Entity (Type_Mark_Node); if Present (Tmp_Node) and then Ekind (Tmp_Node) in Einfo.Type_Kind then Tmp_Node := Parent (Tmp_Node); end if; if Nkind (Tmp_Node) = N_Subtype_Declaration and then not Is_Rewrite_Substitution (Tmp_Node) and then not Comes_From_Source (Tmp_Node) then Result := Sinfo.Subtype_Indication (Tmp_Node); -- In case of nested instantiations, we have to traverse -- the chain of subtype declarations created by the compiler -- for actual types while Is_From_Instance (Result) and then Nkind (Parent (Entity (Result))) = N_Subtype_Declaration and then not Comes_From_Source (Parent (Entity (Result))) loop Result := Parent (Entity (Result)); if Is_Rewrite_Substitution (Result) then -- The case when the actual type is a derived type. Here -- the chain of subtypes leads to the artificial internal -- type created by the compiler, but not to the actual type -- (8924-006) Result := Sinfo.Defining_Identifier (Result); while Present (Homonym (Result)) loop Result := Homonym (Result); end loop; exit; end if; Result := Sinfo.Subtype_Indication (Result); end loop; end if; end if; return Result; end Get_Actual_Type_Name; ---------------------------- -- Get_Corr_Called_Entity -- ---------------------------- function Get_Corr_Called_Entity (Call : Asis.Element) return Asis.Declaration is Arg_Node : Node_Id; Arg_Node_Kind : Node_Kind; Result_Node : Node_Id; Result_Unit : Compilation_Unit; Special_Case : Special_Cases := Not_A_Special_Case; Result_Kind : Internal_Element_Kinds := Not_An_Element; Inherited : Boolean := False; Res_Node_Field_1 : Node_Id := Empty; Tmp_Node : Node_Id; Result_El : Asis.Element; begin -- The general implementation approach is: -- -- 1. First, we try to define Result_Node as pointing to the tree -- node on which the resulting ASIS Element should be based. -- During this step Arg_Node is also set (and probably adjusted) -- -- 2. If the result looks like representing an Ada implicit construct -- (for now the main and the only check is -- Comes_From_Source (Result_Node)), at the second step we -- form the representation of the implicit inherited user-defined -- subprogram by setting Result_Node pointing to the explicit -- declaration of the subprogram being inherited, and -- Res_Node_Field_1 pointing to the defining identifier node -- corresponding to the given implicit subprogram. Note, that -- at the moment implicit predefined operations are not -- implemented. -- -- 3. On the last step we compute additional attributes of the -- resulting Element. ------------------------------------------------------------------ -- 1. Defining Result_Node (and adjusting Arg_Node, if needed) -- ------------------------------------------------------------------ Arg_Node := R_Node (Call); Arg_Node_Kind := Nkind (Arg_Node); Tmp_Node := Node (Call); -- Rewritten node should know everything. But if in case of a function -- call this node is the result of compile-time optimization, -- we have to work with original node only: if Arg_Node_Kind = N_String_Literal or else Arg_Node_Kind = N_Integer_Literal or else Arg_Node_Kind = N_Real_Literal or else Arg_Node_Kind = N_Character_Literal or else Arg_Node_Kind = N_Raise_Constraint_Error or else Arg_Node_Kind = N_Raise_Program_Error or else Arg_Node_Kind = N_Conditional_Expression or else Arg_Node_Kind = N_Explicit_Dereference or else Arg_Node_Kind = N_Type_Conversion or else Arg_Node_Kind = N_Unchecked_Type_Conversion or else Arg_Node_Kind = N_Identifier or else (Arg_Node_Kind in N_Op and then (Nkind (Tmp_Node) = N_Function_Call or else (Nkind (Tmp_Node) in N_Op and then Present (Entity (Tmp_Node)) and then (Pass_Generic_Actual (Parent (Parent ((Entity (Tmp_Node))))))))) then Arg_Node := Node (Call); Arg_Node_Kind := Nkind (Arg_Node); end if; case Arg_Node_Kind is when N_Attribute_Reference => return Nil_Element; -- call to a procedure-attribute or to a function-attribute -- but in case when a representation clause was applied -- to define stream IOU attributes, we can return something -- more interesting, then Nil_Element, see the corresponding -- Aladdin's message when N_Entry_Call_Statement | N_Procedure_Call_Statement | N_Function_Call => -- here we have to filter out the case when Nil_Element -- should be returned for a call through access-to-function: if Nkind (Sinfo.Name (Arg_Node)) = N_Explicit_Dereference then return Nil_Element; end if; if Arg_Node_Kind = N_Entry_Call_Statement then Arg_Node := Sinfo.Name (Arg_Node); -- Arg_Node points to the name of the called entry if Nkind (Arg_Node) = N_Indexed_Component then -- this is the case for a call to an entry from an -- entry family Arg_Node := Prefix (Arg_Node); end if; Result_Node := Entity (Selector_Name (Arg_Node)); else -- here we have Arg_Node_Kind equal to -- N_Procedure_Call_Statement or to N_Function_Call, and this -- is the right place to check if this is a dispatching call. -- We do not want to use Asis.Extensions.Is_Dispatching_Call -- query here to avoid introducing dependency on -- Asis.Extensions if Present (Controlling_Argument (Arg_Node)) then return Nil_Element; end if; Arg_Node := Sinfo.Name (Arg_Node); if Nkind (Arg_Node) = N_Selected_Component then -- this is the case for calls to protected subprograms Result_Node := Entity (Selector_Name (Arg_Node)); else Result_Node := Entity (Arg_Node); end if; end if; if No (Result_Node) and then Arg_Node_Kind = N_Function_Call and then Is_From_Unknown_Pragma (R_Node (Call)) then return Nil_Element; end if; when N_Op => -- all the predefined operations (??) Result_Node := Entity (Arg_Node); when others => pragma Assert (False); null; end case; if Present (Result_Node) and then not Comes_From_Source (Result_Node) and then Nkind (Parent (Result_Node)) = N_Defining_Program_Unit_Name then -- Case of a child subprogram for that an explicit separate spec is -- not given. Result_Node points to the defining identifier from -- the subprogram spec artificially created by the compiler. We -- reset it to point to the proper defining identifier from the -- explicitely given body Result_Node := Parent (Parent (Parent (Result_Node))); pragma Assert (Nkind (Result_Node) = N_Subprogram_Declaration); Result_Node := Corresponding_Body (Result_Node); end if; pragma Assert (Present (Result_Node)); -- it is possible, that for a subprogram defined by a stub, the -- subprogram body declaration from the corresponding subunit is -- returned. In this case we have to go to the corresponding -- stub (the subprogram body which is the proper body from a -- subunit can never be returned as a corresponding called entity) Set_Stub_For_Subunit_If_Any (Result_Node); if Is_Generic_Instance (Result_Node) then Result_Node := Get_Instance_Name (Result_Node); end if; Tmp_Node := Original_Node (Parent (Parent (Result_Node))); while Nkind (Tmp_Node) = N_Subprogram_Renaming_Declaration and then not (Comes_From_Source (Tmp_Node)) and then not Pass_Generic_Actual (Tmp_Node) loop -- Result_Node is a defining name from the artificial renaming -- declarations created by the compiler in the for wrapper -- package for expanded subprogram instantiation. We -- have to go to expanded subprogram spec which is renamed. -- -- We have to do this in a loop in case of nested instantiations Result_Node := Sinfo.Name (Tmp_Node); if Nkind (Result_Node) = N_Selected_Component then Result_Node := Selector_Name (Result_Node); end if; Result_Node := Entity (Result_Node); Tmp_Node := Parent (Parent (Result_Node)); end loop; -- F703-020: operations of an actual type provided for the formal -- derived type (we are in the expanded generic) if not Comes_From_Source (Result_Node) and then Present (Alias (Result_Node)) and then not (Is_Intrinsic_Subprogram (Result_Node)) and then Pass_Generic_Actual (Parent (Result_Node)) then -- This means that we have an operation of an actual that corresponds -- to the generic formal derived type. In the tree, these operations -- are "(re)defined" for the artificial subtype declaration used to -- pass the actual type into expanded template. We go one step up -- the aliases chain to get to the proper declaration of the type -- operation Result_Node := Alias (Result_Node); end if; -- the code below is very similar to what we have in -- A4G.Expr_Sem.Identifier_Name_Definition (this name may be changed)! -- In future we'll probably have to re-study this again (???) -- first, defining the Enclosing Unit and doing the consistency check ----------------------------------------------------------- -- 2. Defining Association_Etype as the type "producing" -- -- a given implicit construct (if needed) -- ----------------------------------------------------------- -- We have to turn off for a while the full processing of the -- implicit elements (Hope to fix this soon). if (not Comes_From_Source (Result_Node) or else Is_Artificial_Protected_Op_Item_Spec (Result_Node)) and then not Pass_Generic_Actual (Parent (Parent (Result_Node))) then if Present (Alias (Result_Node)) and then Nkind (Original_Node (Parent (Result_Node))) in N_Formal_Type_Declaration .. N_Private_Extension_Declaration then -- ???Is this the right test for implicit inherited user-defined -- subprogram??? Inherited := True; Res_Node_Field_1 := Result_Node; while Present (Alias (Result_Node)) and then not Comes_From_Source (Result_Node) loop Result_Node := Alias (Result_Node); end loop; elsif Is_Generic_Instance (Result_Node) then Special_Case := Expanded_Subprogram_Instantiation; elsif Is_Artificial_Protected_Op_Item_Spec (Result_Node) then Result_Node := Corresponding_Body (Parent (Parent (Result_Node))); elsif Ekind (Result_Node) = E_Function and then not Comes_From_Source (Result_Node) and then Chars (Result_Node) = Name_Op_Ne and then Present (Corresponding_Equality (Result_Node)) then Special_Case := Is_From_Imp_Neq_Declaration; else return Nil_Element; -- ???!!! this turns off all the predefined operations!!! end if; end if; -- Now, checking if we have a call to an entry/procedure/function of -- derived task/protected type Tmp_Node := Arg_Node; if Nkind (Tmp_Node) = N_Selected_Component then Tmp_Node := Prefix (Tmp_Node); Tmp_Node := Etype (Tmp_Node); if Ekind (Tmp_Node) in Concurrent_Kind then while not Comes_From_Source (Original_Node (Parent (Tmp_Node))) loop Tmp_Node := Etype (Tmp_Node); end loop; Tmp_Node := Parent (Tmp_Node); if Nkind (Tmp_Node) = N_Full_Type_Declaration and then Nkind (Sinfo.Type_Definition (Tmp_Node)) = N_Derived_Type_Definition then Inherited := True; Res_Node_Field_1 := Tmp_Node; end if; end if; end if; if Present (Res_Node_Field_1) then Result_Unit := Enclosing_Unit (Encl_Cont_Id (Call), Res_Node_Field_1); else Result_Unit := Enclosing_Unit (Encl_Cont_Id (Call), Result_Node); end if; -- ??? should be changed when full processing of implicit elements -- will be ready -- And now - from a defining name to a declaration itself -- (this also may need adjustment for the full implementation -- of the implicit stuff) if Inherited then -- For inherited subprograms we have to set the result kind manually -- to get subprogram declarations in case of inheriting from -- subprogram ransoming (8728-023) if Ekind (Result_Node) = E_Function or else Ekind (Result_Node) = E_Operator then Result_Kind := A_Function_Declaration; elsif Ekind (Result_Node) = E_Procedure then if Null_Present (Parent (Result_Node)) then Result_Kind := A_Null_Procedure_Declaration; else Result_Kind := A_Procedure_Declaration; end if; end if; end if; if Special_Case not in Predefined then if Nkind (Result_Node) in N_Entity and then Ekind (Result_Node) = E_Enumeration_Literal then -- This happens if an enumeration literal is used as an actual for -- a formal function, and if we process the corresponding function -- call in the instantiation. See EBB11-004 Result_Kind := An_Enumeration_Literal_Specification; else Result_Node := Parent (Result_Node); if Nkind (Result_Node) = N_Defining_Program_Unit_Name then Result_Node := Parent (Result_Node); end if; if Nkind (Result_Node) = N_Procedure_Specification or else Nkind (Result_Node) = N_Function_Specification then Result_Node := Parent (Result_Node); end if; end if; elsif Special_Case in Predefined then Result_Kind := A_Function_Declaration; end if; Result_El := Node_To_Element_New (Node => Result_Node, Node_Field_1 => Res_Node_Field_1, Internal_Kind => Result_Kind, Spec_Case => Special_Case, Inherited => Inherited, In_Unit => Result_Unit); -- Fix for C125-002: Is_Part_Of_Instance of the result is defined on -- the base of Result_Node which points to the explicit subprogram. -- That is, if we define the type derived from some other type declared -- inside the instance, we will get all its inherited subprograms -- being Is_Part_Of_Instance even if the derived type is not declared -- inside any instance. And the other way around. if Present (Res_Node_Field_1) then if Is_From_Instance (Res_Node_Field_1) then Set_From_Instance (Result_El, True); else Set_From_Instance (Result_El, False); end if; end if; return Result_El; end Get_Corr_Called_Entity; ---------------------- -- Get_Derived_Type -- ---------------------- function Get_Derived_Type (Type_Entity : Entity_Id; Inherited_Subpr : Entity_Id) return Entity_Id is Result : Entity_Id := Type_Entity; Derived_Type : Entity_Id; Next_Derived_Type : Entity_Id; begin Derived_Type := Original_Node (Parent (Inherited_Subpr)); Next_Derived_Type := Derived_Type; if Nkind (Next_Derived_Type) = N_Full_Type_Declaration then Next_Derived_Type := Sinfo.Type_Definition (Next_Derived_Type); elsif Nkind (Next_Derived_Type) = N_Formal_Type_Declaration then Next_Derived_Type := Sinfo.Formal_Type_Definition (Next_Derived_Type); end if; if Nkind (Next_Derived_Type) = N_Formal_Derived_Type_Definition then Next_Derived_Type := Sinfo.Subtype_Mark (Next_Derived_Type); else Next_Derived_Type := Sinfo.Subtype_Indication (Next_Derived_Type); end if; Derived_Type := Defining_Identifier (Derived_Type); if Nkind (Next_Derived_Type) = N_Subtype_Indication then Next_Derived_Type := Sinfo.Subtype_Mark (Next_Derived_Type); end if; Next_Derived_Type := Entity (Next_Derived_Type); loop if Next_Derived_Type = Type_Entity then Result := Derived_Type; exit; elsif Is_Derived_Type (Next_Derived_Type) then Next_Derived_Type := Original_Node (Parent (Next_Derived_Type)); if Nkind (Next_Derived_Type) = N_Full_Type_Declaration then Next_Derived_Type := Sinfo.Type_Definition (Next_Derived_Type); end if; Next_Derived_Type := Sinfo.Subtype_Indication (Next_Derived_Type); if Nkind (Next_Derived_Type) = N_Subtype_Indication then Next_Derived_Type := Sinfo.Subtype_Mark (Next_Derived_Type); end if; Next_Derived_Type := Entity (Next_Derived_Type); else exit; end if; end loop; return Result; end Get_Derived_Type; -------------------------- -- Get_Importing_Pragma -- -------------------------- function Get_Importing_Pragma (E : Entity_Id) return Node_Id is Result : Node_Id := Empty; Tmp_Node : Node_Id; Pragma_Node : Node_Id; Arg_Chars : constant Name_Id := Chars (E); begin -- First, check if we have the corresponding pragma in the list of -- representation items applied to the argument node: Pragma_Node := First_Rep_Item (E); while Present (Pragma_Node) loop if Is_Importing_Pragma (Pragma_Node, Arg_Chars) then Result := Pragma_Node; exit; else Pragma_Node := Next_Rep_Item (Pragma_Node); end if; end loop; if No (Result) then -- That means that Import or Interface pragma is applied to an -- overloaded entities Pragma_Node := Next (Parent (Parent (E))); while Present (Pragma_Node) loop if Is_Importing_Pragma (Pragma_Node, Arg_Chars) then Result := Pragma_Node; exit; else Next (Pragma_Node); end if; end loop; end if; if No (Result) then Tmp_Node := Parent (Parent (Parent (E))); if Nkind (Tmp_Node) = N_Package_Specification and then List_Containing (Parent (Parent (E))) = Visible_Declarations (Tmp_Node) then -- this is a somewhat exotic case - a subprogram declaration in -- the visible part of a package spec, and the cotrresponding -- pragma is in the corresponding private part. Pragma_Node := First (Private_Declarations (Tmp_Node)); while Present (Pragma_Node) loop if Is_Importing_Pragma (Pragma_Node, Arg_Chars) then Result := Pragma_Node; exit; else Next (Pragma_Node); end if; end loop; end if; end if; pragma Assert (Present (Result)); return Result; end Get_Importing_Pragma; ----------------------- -- Get_Instance_Name -- ----------------------- function Get_Instance_Name (Int_Name : Node_Id) return Node_Id is Result_Node : Node_Id := Empty; Decl_Node : Node_Id; begin Decl_Node := Parent (Int_Name); if Nkind (Decl_Node) = N_Defining_Program_Unit_Name then Decl_Node := Parent (Decl_Node); end if; Decl_Node := Parent (Decl_Node); if Nkind (Decl_Node) = N_Subprogram_Declaration then Decl_Node := Parent (Parent (Decl_Node)); end if; if (not Is_List_Member (Decl_Node) and then not Is_Rewrite_Substitution (Decl_Node)) or else (Is_List_Member (Decl_Node) and then Nkind (Original_Node (Decl_Node)) = N_Formal_Package_Declaration) then -- The first condition corresponds to the case when a library -- package is instantiated at library level - no artificial package -- is created in this case. -- The second condition corresponds to the defining name from -- a formal package declaration (it is also classified as -- Is_Generic_Instance) return Int_Name; end if; -- now Decl_Node points to the declaration of an artificial package -- created by the compiler for the instantiation if Is_Rewrite_Substitution (Decl_Node) then Decl_Node := Original_Node (Decl_Node); if Is_Rewrite_Substitution (Decl_Node) then -- The node can be rewritten twice in case when a library-level -- instantiation is a supporter of a main unit, and the expanded -- body of this instantiation is required according to Lib (h), -- see 9418-015, 9416-A01 and 9426-A13 Decl_Node := Original_Node (Decl_Node); end if; if Nkind (Original_Node (Decl_Node)) = N_Formal_Package_Declaration then Result_Node := Defining_Identifier (Original_Node (Decl_Node)); else Result_Node := Defining_Unit_Name (Original_Node (Decl_Node)); end if; else Decl_Node := Next_Non_Pragma (Decl_Node); while Present (Decl_Node) loop if Nkind (Decl_Node) in N_Generic_Instantiation then Result_Node := Defining_Unit_Name (Decl_Node); exit; else Decl_Node := Next_Non_Pragma (Decl_Node); end if; end loop; end if; pragma Assert (Present (Result_Node)); return Result_Node; end Get_Instance_Name; ------------------ -- Is_Anonymous -- ------------------ function Is_Anonymous (E : Entity_Kind) return Boolean is Result : Boolean := False; begin case E is when E_Anonymous_Access_Subprogram_Type | E_Anonymous_Access_Protected_Subprogram_Type | E_Anonymous_Access_Type => Result := True; when others => null; end case; return Result; end Is_Anonymous; ------------------- -- Is_Applied_To -- ------------------- function Is_Applied_To (Pragma_Node : Node_Id; Entity_Node : Entity_Id) return Boolean is Result : Boolean := False; Pragma_Arg : Node_Id := Empty; Entity_Decl : Node_Id; begin case Pragma_Name (Pragma_Node) is -- Cases when the second pragma argument indicates the entity -- the pragma is applied to: when Name_Component_Alignment | Name_Convention | Name_Export | Name_External | Name_Import | Name_Interface => Pragma_Arg := First (Pragma_Argument_Associations (Pragma_Node)); Pragma_Arg := Sinfo.Expression (Next (Pragma_Arg)); if Entity (Pragma_Arg) = Entity_Node or else Chars (Pragma_Arg) = Chars (Entity_Node) then Result := True; end if; -- Cases when a pragma may have several arguments, and any of then -- may indicate the entyty the pragma is applied to when Name_Inline | Name_Inline_Always | Name_No_Return | Name_Unmodified | Name_Unreferenced | Name_Unreferenced_Objects => Pragma_Arg := First (Pragma_Argument_Associations (Pragma_Node)); while Present (Pragma_Arg) loop Pragma_Arg := Sinfo.Expression (Pragma_Arg); if Entity (Pragma_Arg) = Entity_Node or else Chars (Pragma_Arg) = Chars (Entity_Node) then Result := True; exit; end if; Pragma_Arg := Next (Parent (Pragma_Arg)); end loop; -- Cases when only the first argument of a pragma may indicate the -- entyty the pragma is applied to when -- GNAT-specific pragmas first Name_Common_Object | Name_Complex_Representation | Name_CPP_Class | Name_CPP_Constructor | Name_Export_Exception | Name_Export_Function | Name_Export_Object | Name_Export_Procedure | Name_Export_Valued_Procedure | Name_Favor_Top_Level | Name_Finalize_Storage_Only | Name_Implemented_By_Entry | Name_Import_Exception | Name_Import_Function | Name_Import_Object | Name_Import_Procedure | Name_Import_Valued_Procedure | Name_Inline_Generic | Name_Interface_Name | Name_Keep_Names | Name_Linker_Alias | Name_Linker_Constructor | Name_Linker_Destructor | Name_Linker_Section | Name_Machine_Attribute | Name_No_Strict_Aliasing | Name_Persistent_BSS | Name_Psect_Object | Name_Pure_Function | Name_Shared | Name_Stream_Convert | Name_Suppress_Initialization | Name_Task_Storage | Name_Universal_Aliasing | Name_Weak_External | -- Standard Ada 2005 pragmas Name_Asynchronous | Name_Atomic | Name_Atomic_Components | Name_Attach_Handler | Name_Controlled | Name_Discard_Names | Name_Interrupt_Handler | Name_Pack | Name_Preelaborable_Initialization | Name_Unchecked_Union | Name_Volatile | Name_Volatile_Components => Pragma_Arg := First (Pragma_Argument_Associations (Pragma_Node)); Pragma_Arg := Sinfo.Expression (Pragma_Arg); if Entity (Pragma_Arg) = Entity_Node or else Chars (Pragma_Arg) = Chars (Entity_Node) then Result := True; end if; -- Cases when a specific processing is needed when Name_Float_Representation => Pragma_Arg := First (Pragma_Argument_Associations (Pragma_Node)); if Present (Next (Pragma_Arg)) then Pragma_Arg := Next (Pragma_Arg); end if; Pragma_Arg := Sinfo.Expression (Pragma_Arg); if Entity (Pragma_Arg) = Entity_Node or else Chars (Pragma_Arg) = Chars (Entity_Node) then Result := True; end if; when Name_Obsolescent => if Is_Obsolescent (Entity_Node) then -- This pragma may or may not contain the reference to the -- entity it is applied to. The pargma may or may not contain -- arguments if Present (Pragma_Argument_Associations (Pragma_Node)) and then List_Length (Pragma_Argument_Associations (Pragma_Node)) >= 2 then Pragma_Arg := First (Pragma_Argument_Associations (Pragma_Node)); Pragma_Arg := Sinfo.Expression (Pragma_Arg); end if; if No (Pragma_Arg) or else Chars (Pragma_Arg) = Chars (Entity_Node) then -- here we have to check if the pragma immediatelly follows -- the declaration that defines Entity_Node, or the pragma -- is the first declarative element in the package spec and -- Entity_Node defines this package. Pragma_Arg is used as -- temporary node below Pragma_Arg := Prev (Pragma_Node); if Present (Pragma_Arg) then -- Go to the declaration that declares Entity_Node Entity_Decl := Parent (Entity_Node); while Present (Entity_Decl) and then not Is_List_Member (Entity_Decl) loop Entity_Decl := Parent (Entity_Decl); end loop; Result := Entity_Decl = Pragma_Arg; else -- With the current implementation of the ASIS -- Corresponding_Pragmas query this code never works! -- Check if the pragma Obsolescent is the program unit -- pragma: Pragma_Arg := Parent (Pragma_Node); if Nkind (Pragma_Arg) = N_Package_Specification then if Nkind (Parent (Pragma_Arg)) = N_Package_Declaration then -- To filter out the case of generic packages Pragma_Arg := Defining_Unit_Name (Pragma_Arg); if Nkind (Pragma_Arg) = N_Defining_Program_Unit_Name then Pragma_Arg := Defining_Identifier (Pragma_Arg); end if; Result := Pragma_Arg = Entity_Node; end if; end if; end if; else -- With the current implementation of the ASIS -- Corresponding_Pragmas query this code never works! -- Case when a pragma may be applied to an enumeration -- literal. if Ekind (Entity_Node) = E_Enumeration_Literal then Entity_Decl := Parent (Parent (Entity_Node)); Result := Next (Entity_Decl) = Pragma_Node; end if; end if; end if; -- All the other pragmas cannot be a part of the result when others => null; end case; return Result; end Is_Applied_To; ------------------------------------------ -- Is_Artificial_Protected_Op_Item_Spec -- ------------------------------------------ function Is_Artificial_Protected_Op_Item_Spec (E : Entity_Id) return Boolean is Arg : Entity_Id := E; Result : Boolean := False; begin if Nkind (Arg) = N_Defining_Identifier then -- No need to consider defining expanded names if Ekind (Arg) in Formal_Kind then Arg := Parent (Parent (Arg)); if Nkind (Arg) in N_Subprogram_Specification then Arg := Defining_Unit_Name (Arg); end if; end if; if Nkind (Arg) in N_Entity and then (Ekind (Arg) in Formal_Kind or else Ekind (Arg) in Subprogram_Kind) and then not Comes_From_Source (Parent (Arg)) and then Nkind (Parent (Parent (Parent (Arg)))) = N_Protected_Body then Result := True; end if; end if; return Result; end Is_Artificial_Protected_Op_Item_Spec; ------------------------- -- Is_Derived_Rep_Item -- ------------------------- function Is_Derived_Rep_Item (Type_Entity : Entity_Id; Rep_Item : Node_Id) return Boolean is Result : Boolean := True; Type_Ard : Node_Id := Empty; begin case Nkind (Rep_Item) is when N_Attribute_Definition_Clause => if Entity (Sinfo.Name (Rep_Item)) = Type_Entity then Result := False; end if; when N_Pragma => Type_Ard := Sinfo.Expression (First (Pragma_Argument_Associations (Rep_Item))); if Entity (Type_Ard) = Type_Entity then Result := False; end if; when N_Enumeration_Representation_Clause | N_Record_Representation_Clause => if Entity (Sinfo.Identifier (Rep_Item)) = Type_Entity then Result := False; end if; when others => null; pragma Assert (False); end case; return Result; end Is_Derived_Rep_Item; ---------------------- -- Is_From_Instance -- ---------------------- function Is_From_Instance (Node : Node_Id) return Boolean is begin return (Sloc (Node) > Standard_Location and then Instantiation (Get_Source_File_Index (Sloc (Node))) /= No_Location) or else (Present (Parent (Node)) and then Nkind (Parent (Node)) = N_Package_Specification and then Is_From_Instance ((Parent (Node)))); end Is_From_Instance; --------------------------------- -- Is_From_Rewritten_Aggregate -- --------------------------------- function Is_From_Rewritten_Aggregate (Node : Node_Id) return Boolean is Result : Boolean := False; Next_Aggr : Node_Id; begin if Nkind (Node) = N_Component_Association then Next_Aggr := Parent (Node); while Nkind (Next_Aggr) = N_Aggregate or else Nkind (Next_Aggr) = N_Extension_Aggregate loop if Is_Rewrite_Substitution (Next_Aggr) then Result := True; exit; end if; Next_Aggr := Parent (Next_Aggr); end loop; end if; return Result; end Is_From_Rewritten_Aggregate; ---------------------------- -- Is_From_Unknown_Pragma -- ---------------------------- function Is_From_Unknown_Pragma (Node : Node_Id) return Boolean is Result : Boolean := False; Tmp : Node_Id := Parent (Node); N : Name_Id; begin while Nkind (Tmp) /= N_Compilation_Unit loop case Nkind (Tmp) is when N_Pragma => N := Pragma_Name (Tmp); -- See Snames.Get_Pragma_Id if not ( N in First_Pragma_Name .. Last_Pragma_Name or else N = Name_AST_Entry or else N = Name_Interface or else N = Name_Priority or else N = Name_Storage_Size or else N = Name_Storage_Unit) then Result := True; end if; exit; when N_Statement_Other_Than_Procedure_Call | N_Procedure_Call_Statement | N_Representation_Clause | N_Component_Declaration .. N_Generic_Procedure_Renaming_Declaration => exit; when others => Tmp := Parent (Tmp); end case; end loop; return Result; end Is_From_Unknown_Pragma; ----------------- -- Is_Impl_Neq -- ----------------- function Is_Impl_Neq (Def_Op : Entity_Id) return Boolean is Result : Boolean := False; begin if Nkind (Def_Op) in N_Entity and then Ekind (Def_Op) = E_Function and then not Comes_From_Source (Def_Op) and then Chars (Def_Op) = Name_Op_Ne and then Present (Corresponding_Equality (Def_Op)) then Result := True; end if; return Result; end Is_Impl_Neq; ------------------------- -- Is_Importing_Pragma -- ------------------------- function Is_Importing_Pragma (N : Node_Id; For_Name : Name_Id) return Boolean is Result : Boolean := False; Tmp : Node_Id; begin if Nkind (N) = N_Pragma and then (Pragma_Name (N) = Name_Import or else Pragma_Name (N) = Name_Interface) then Tmp := First (Pragma_Argument_Associations (N)); Tmp := Sinfo.Expression (Next (Tmp)); Result := Chars (Tmp) = For_Name; end if; return Result; end Is_Importing_Pragma; ------------------------------------ -- Is_Name_Of_Expanded_Subprogram -- ------------------------------------- function Is_Name_Of_Expanded_Subprogram (Node : Node_Id) return Boolean is Result : Boolean := False; begin if Nkind (Node) = N_Defining_Identifier and then Is_Generic_Instance (Node) and then Ekind (Node) in E_Function .. E_Procedure then Result := True; end if; return Result; end Is_Name_Of_Expanded_Subprogram; ------------------- -- Is_Predefined -- ------------------- function Is_Predefined (Def_Op : Node_Id) return Boolean is Result : Boolean := False; Tmp : Entity_Id; begin if Ekind (Def_Op) in E_Function .. E_Operator and then not Comes_From_Source (Def_Op) and then not Is_Impl_Neq (Def_Op) then if Sloc (Def_Op) <= Standard_Location or else No (Alias (Def_Op)) or else No (Parent (Def_Op)) then Result := True; elsif Present (Alias (Def_Op)) then Tmp := Alias (Def_Op); while Present (Alias (Tmp)) loop Tmp := Alias (Tmp); end loop; if not Comes_From_Source (Tmp) and then No (Parent (Tmp)) then Result := True; end if; end if; end if; return Result; end Is_Predefined; ------------------------- -- Pass_Generic_Actual -- ------------------------- function Pass_Generic_Actual (N : Node_Id) return Boolean is Arg_Node : constant Node_Id := Original_Node (N); Result : Boolean := False; begin -- See the discussion in F424-031 and F427-008 case Nkind (Arg_Node) is when N_Subtype_Declaration => Result := not Comes_From_Source (Arg_Node) and then not Is_Internal_Name (Chars (Defining_Identifier (Arg_Node))) and then Is_From_Instance (Defining_Identifier (Arg_Node)); when N_Subprogram_Renaming_Declaration => Result := Present (Corresponding_Formal_Spec (Arg_Node)); when N_Object_Renaming_Declaration | N_Object_Declaration => Result := Present (Corresponding_Generic_Association (Arg_Node)) or else (not Comes_From_Source (Arg_Node) and then Is_From_Instance (Defining_Identifier (Arg_Node))); when N_Formal_Object_Declaration => -- Here we should correctly process the situation in the expanded -- spec that corresponds to a formal package. In case if the -- given generic formal parameter of the formal package is not -- specified in the formal package declaration, the corresponding -- parameter is presented in the expanded spec as a formal -- parameter, but not as a renaming Result := Is_From_Instance (Arg_Node) and then Comes_From_Source (Arg_Node) and then not Comes_From_Source (Defining_Identifier (Arg_Node)); when others => null; end case; return Result; end Pass_Generic_Actual; --------------------------------- -- Part_Of_Pass_Generic_Actual -- --------------------------------- function Part_Of_Pass_Generic_Actual (N : Node_Id) return Boolean is Result : Boolean := Pass_Generic_Actual (N); Tmp_N : Node_Id := Parent (N); begin if not Result then while Present (Tmp_N) loop if Pass_Generic_Actual (Tmp_N) then Result := True; exit; else case Nkind (Tmp_N) is -- The idea is to stop tree traversing as soon as possible when N_Statement_Other_Than_Procedure_Call | N_Renaming_Declaration | N_Later_Decl_Item | N_Component_Declaration .. N_Private_Type_Declaration | N_Formal_Subprogram_Declaration => exit; when others => null; end case; end if; Tmp_N := Parent (Tmp_N); end loop; end if; return Result; end Part_Of_Pass_Generic_Actual; -------------------------------------------- -- Represents_Class_Wide_Type_In_Instance -- -------------------------------------------- function Represents_Class_Wide_Type_In_Instance (N : Node_Id) return Boolean is Result : Boolean := False; begin if Nkind (N) = N_Identifier and then Present (Associated_Node (N)) and then Ekind (Associated_Node (N)) in E_Class_Wide_Type .. E_Class_Wide_Subtype then Result := True; end if; return Result; end Represents_Class_Wide_Type_In_Instance; -------------------------------------- -- Represents_Base_Type_In_Instance -- -------------------------------------- function Represents_Base_Type_In_Instance (N : Node_Id) return Boolean is Result : Boolean := False; begin if Nkind (N) = N_Identifier and then not Comes_From_Source (N) and then Is_Internal_Name (Chars (N)) and then Present (Associated_Node (N)) and then Ekind (Associated_Node (N)) in E_Enumeration_Type .. E_Floating_Point_Subtype then Result := True; end if; return Result; end Represents_Base_Type_In_Instance; -------------------- -- Reset_For_Body -- -------------------- procedure Reset_For_Body (El : in out Asis.Element; Body_Unit : Asis.Compilation_Unit) is Spec_CU : constant Unit_Id := Encl_Unit_Id (El); Arg_Tree : constant Tree_Id := Encl_Tree (El); Body_Tree : Tree_Id; Result_El : Asis.Element := Nil_Element; -- and the rest of the local declarations is needed for traversal Spec_El : Asis.Element; My_State : No_State := Not_Used; Control : Asis.Traverse_Control := Continue; procedure Pre_Op (Element : Asis.Element; Control : in out Traverse_Control; State : in out No_State); procedure Pre_Op (Element : Asis.Element; Control : in out Traverse_Control; State : in out No_State) is pragma Unreferenced (State); El_Kind : constant Internal_Element_Kinds := Int_Kind (Element); begin case El_Kind is when A_Task_Type_Declaration | A_Single_Task_Declaration | An_Incomplete_Type_Declaration | A_Procedure_Declaration | A_Function_Declaration | An_Entry_Declaration | A_Generic_Procedure_Declaration | A_Generic_Function_Declaration => -- here we have declarations which may have completion in the -- package body, but their subcomponents cannot have a -- completion if Is_Equal (Element, El) then Result_El := Element; Control := Terminate_Immediately; else Control := Abandon_Children; end if; when A_Protected_Type_Declaration | A_Single_Protected_Declaration | A_Package_Declaration | A_Generic_Package_Declaration => -- here we have declarations which may have completion in the -- package body, their subcomponents also can have a completion if Is_Equal (Element, El) then Result_El := Element; Control := Terminate_Immediately; end if; when A_Protected_Definition => Control := Continue; -- To look for protected entries and subprograms when others => Control := Abandon_Children; end case; end Pre_Op; procedure Find_For_Reset is new Traverse_Element (State_Information => No_State, Pre_Operation => Pre_Op, Post_Operation => No_Op); begin Reset_Tree_For_Unit (Body_Unit); Body_Tree := Get_Current_Tree; if Arg_Tree = Body_Tree then return; end if; Spec_El := Node_To_Element_New (Node => Unit (Top (Spec_CU)), Starting_Element => El); Find_For_Reset (Spec_El, Control, My_State); pragma Assert (not Is_Nil (Result_El)); El := Result_El; end Reset_For_Body; --------------------------------- -- Set_Stub_For_Subunit_If_Any -- --------------------------------- procedure Set_Stub_For_Subunit_If_Any (Def_Name : in out Node_Id) is Stub_Node : Node_Id; Decl_Node : Node_Id; Node_Context : constant Node_Id := Parent (Parent (Parent (Def_Name))); begin if not (Nkind (Def_Name) = N_Defining_Identifier and then Nkind (Node_Context) = N_Subunit and then Nkind (Proper_Body (Node_Context)) = N_Subprogram_Body and then Def_Name = Defining_Unit_Name (Specification (Proper_Body (Node_Context)))) then -- nothing to change return; else Def_Name := Defining_Unit_Name (Specification (Corresponding_Stub (Node_Context))); Stub_Node := Parent (Parent (Def_Name)); Decl_Node := Corr_Decl_For_Stub (Stub_Node); if Present (Decl_Node) then Def_Name := Defining_Unit_Name (Specification (Decl_Node)); end if; end if; end Set_Stub_For_Subunit_If_Any; --------------------- -- Unwind_Renaming -- --------------------- function Unwind_Renaming (Def_Name : Node_Id) return Node_Id is Parent_Decl : Node_Id; Result_Node : Node_Id; begin -- a recursive algorithm is probably not the most effective, -- but it is easy-to-maintain. Moreover, we do not really -- expect long renaming chains in not-crazy programs -- When the implementation of this function is stable, we probably -- should replace the recursive code by the iteration-based code Result_Node := Def_Name; Parent_Decl := Parent (Result_Node); case Nkind (Parent_Decl) is when N_Renaming_Declaration => -- unwinding once again Result_Node := Sinfo.Name (Entity (Parent_Decl)); return Unwind_Renaming (Result_Node); when N_Function_Specification | N_Procedure_Specification => -- two cases are possible: if this subprogram specification -- is the component of another (subprogram) renaming -- declaration, we should unwind again, -- otherwise we have got the result: if Nkind (Parent (Parent_Decl)) = N_Subprogram_Renaming_Declaration then -- unwinding once again -- Result_Node := Sinfo.Name (Entity (Parent (Parent_Decl))); Result_Node := Entity (Sinfo.Name (Parent (Parent_Decl))); return Unwind_Renaming (Result_Node); else if Is_Rewrite_Substitution (Parent (Parent_Decl)) and then Nkind (Original_Node (Parent (Parent_Decl))) = N_Subprogram_Renaming_Declaration then -- this means, that we have met the renaming of a -- subprogram-attribute, so return Empty; else -- all the ransoming (if any) have already been unwounded return Result_Node; end if; end if; when others => return Result_Node; end case; end Unwind_Renaming; end A4G.A_Sem; asis-2010.orig/asis/a4g-a_sem.ads0000644000175000017500000003067711574704441016405 0ustar lbrentalbrenta------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- A 4 G . A _ S E M -- -- -- -- S p e c -- -- -- -- -- -- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- -- -- -- ASIS-for-GNAT 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 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 51 Franklin -- -- Street, Fifth Floor, Boston, MA 02110-1301, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by AdaCore -- -- (http://www.adacore.com). -- -- -- ------------------------------------------------------------------------------ -- This package contains routines needed for semantic queries from -- more then one Asis package with Asis; use Asis; with Einfo; use Einfo; with Types; use Types; package A4G.A_Sem is -- All the routines defined in this package do not check their -- arguments - a caller is responsible for the proper use of these -- routines function Defined_In_Standard (N : Node_Id) return Boolean; -- checks if its argument is an identifier or an enumeration literal -- defined in the predefined Standard package function Char_Defined_In_Standard (N : Node_Id) return Boolean; -- Checks if its argument is a character literal defined in the -- predefined Standard package. Can be applied to reference nodes and -- entity nodes. function Unwind_Renaming (Def_Name : Node_Id) return Node_Id; -- Supposing that Def_Name is the node representing some defining -- occurrence of some name, this function unwinds all the renamings -- (if any) and returns the node representing the defining -- name of the entity referenced by this name. If there is no -- declaration for a given entity (this is the case, when a name -- renames a subprogram-attribute) an Empty node is returned. -- -- Note, that the node for renaming declaration may be rewritten, -- in particular, renaming of a subprogram-attribute is rewritten -- into a subprogram body procedure Set_Stub_For_Subunit_If_Any (Def_Name : in out Node_Id); -- If Def_Name is N_Defining_Identifier node which represents the -- subprogram defining identifier from the proper body of a subunit, -- it is reset to point to the corresponding N_Defining_Identifier -- node from the corresponding body stub, if this stub acts as spec, -- or to the N_Defining_Identifier node from the corresponding -- subprogram declaration. Otherwise the argument remains unchanged. function Corr_Decl_For_Stub (Stub_Node : Node_Id) return Node_Id; -- This function should be called only for N_Subprogram_Body_Stub -- nodes. If the corresponding subprogram body stub is a completion -- of some subprogram declaration, the functions returns the node -- representing this subprogram declaration, otherwise it returns -- the Empty node. function Get_Corr_Called_Entity (Call : Asis.Element) return Asis.Declaration; -- This function incapsulates the common code from -- Asis.Expressions.Corresponding_Called_Function and -- Asis.Statements.Corresponding_Called_Entity. -- It gets the Ada construction which is either a procedure (entry) -- or a function call and returns the declaration of the called -- entity. This function does not check this argument to be an -- appropriate Element for any of these ASIS queries. function Is_Anonymous (E : Entity_Kind) return Boolean; -- Check if E corresponds to an anonymous access type or subtype. function Is_Predefined (Def_Op : Node_Id) return Boolean; -- Returns True if Def_Op is N_Defining_Operator_Symbol representing -- a predefined operation. Returns False otherwise. -- ??? May be, there is something like this in GNAT??? function Is_Impl_Neq (Def_Op : Entity_Id) return Boolean; -- Checks if the argument if the entity of implicit "/=" that is defined -- for explicit user-defined "=" function Is_From_Instance (Node : Node_Id) return Boolean; -- Checks if Node is from expanded generic template function Is_From_Rewritten_Aggregate (Node : Node_Id) return Boolean; -- Checks if Node is an N_Component_Association node belonging to a -- rewritten tree structure corresponding to some aggregate. Returns False -- if Node is not of N_Component_Association kind. function Is_Name_Of_Expanded_Subprogram (Node : Node_Id) return Boolean; -- Detects if the argument is a defining name from an expanded subprogram -- instantiation, In this case the front-end creataes an artificial -- defining identifier node that is not Comes_From_Source, but that also -- does not have an instantiation chain in Sloc, so ASIS can get confused -- with this node and treat is as an implicit node if apply the usual -- tests to it. (See G312-006). function Is_From_Unknown_Pragma (Node : Node_Id) return Boolean; -- Checks if Node belongs to a subtree rooted by unknown pragma. The tree -- structures for unknown pragmas are very poorly decorated, so semantic -- queries may just blow up when applied to elements representing -- components of such pragmas. procedure Reset_For_Body (El : in out Asis.Element; Body_Unit : Asis.Compilation_Unit); -- Provided that El is a declaration from the spec of a library package -- or a library generic package, this procedure resets El to Is_Identical -- Element, but obtained from the tree contained the body for this package. -- This body is represented by the Body_Unit parameter, we use it to avoid -- call to Asis.Compilation_Units.Corresponding_Body in the implementation -- of this function. function Get_Actual_Type_Name (Type_Mark_Node : Node_Id) return Node_Id; -- This function supposes, that its argument is of N_Identifier kind. -- When applied to a reference to an implicit subtype created in -- expanded generic instantiation as a way to pass the actual type, -- this function "unwinds" this implicit subtyping and returns the -- reference to the actual type. Otherwise it returns its argument -- unchanged. -- The case when the actual type is a derived type is treated specially - -- in this case "unwinding" could bring the internal type created by the -- front-end, so we break this unwinding and return the entity (!!!) node -- of the corresponding actual type. function Get_Instance_Name (Int_Name : Node_Id) return Node_Id; -- For Int_Node which should be Is_Generic_Instance (otherwise it is an -- error to use this function) and which denotes the entity declared in -- an artificial package created by the compiler for a generic -- instantiation, it finds an entity defined in a generic instantiation function Get_Derived_Type (Type_Entity : Entity_Id; Inherited_Subpr : Entity_Id) return Entity_Id; -- This function supposes that Type_Entity is a type entity, -- and Inherited_Subpr is the defining name of implicit inherited -- subprogram. It checks if Type_Entity is an ancestor type for the -- derived type which inherits Inherited_Subpr, and if it is, returns -- the entity of the derived type, otherwise returns Type_Entity function Is_Derived_Rep_Item (Type_Entity : Entity_Id; Rep_Item : Node_Id) return Boolean; -- Supposing that Type_Entity is an entity of some type, and Rep_Item -- represents some representation item from the chain of representation -- items associated with this type, this function checks it Type_Entity -- derives this Rep_Item from some of its parent types. function Is_Artificial_Protected_Op_Item_Spec (E : Entity_Id) return Boolean; -- Checks if E represents the entity from the artificial subprogram spec -- created by the compiler for some protected_operation_item which does not -- have a separate spec in the source code. -- Note that this function check protected operation entity and antities of -- its formal parameters (At some point we should rename it as -- Is_FROM_Artificial_Protected_Op_Item_Spec) function Represents_Class_Wide_Type_In_Instance (N : Node_Id) return Boolean; -- Test function used to check if from the ASIS viewpoint the argument may -- represent the 'Class attribute reference corresponding to the actual -- class-wide type in the instantiation (see F410-011 for full details) function Represents_Base_Type_In_Instance (N : Node_Id) return Boolean; -- Test function used to check if from the ASIS viewpoint the argument may -- represent the 'Base attribute reference corresponding to the actual -- type in the instantiation. function Pass_Generic_Actual (N : Node_Id) return Boolean; -- Checks if N represents an artificial (created by the front-end) -- declaration used to pass the actual in the instantiation. The problem -- here is that for such declarations the Sloc field not always (and not -- for all of their subcomponents) points to the instantiation chain. function Part_Of_Pass_Generic_Actual (N : Node_Id) return Boolean; -- This function checks if its argument is a subcomponent of the construct -- for that Pass_Generic_Actual returns True. The only reason to have these -- two function instead of just this one is performance. function Explicit_Parent_Subprogram (E : Entity_Id) return Entity_Id; -- Provided that E points to an inherited subprogram, this function -- computes the entity of the corresponding explicitly defined parent -- subprogram. function Get_Importing_Pragma (E : Entity_Id) return Node_Id; -- Supposing that E is an Is_Imported Entity node, compute the -- corresponding Import or Interface prgama. function Is_Applied_To (Pragma_Node : Node_Id; Entity_Node : Entity_Id) return Boolean; -- Supposing that Pragma_Node denotes a pragma, and Entity_Node is an -- entity node (the caller is resposible for this), checks if the pragma -- is applied to the entity. end A4G.A_Sem; asis-2010.orig/asis/a4g-a_sinput.adb0000644000175000017500000007571011574704441017117 0ustar lbrentalbrenta------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- A 4 G . A _ S I N P U T -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- -- -- -- ASIS-for-GNAT 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 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 51 Franklin -- -- Street, Fifth Floor, Boston, MA 02110-1301, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by AdaCore -- -- (http://www.adacore.com). -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; use Ada.Characters.Handling; with System.WCh_Con; use System.WCh_Con; with Asis.Set_Get; use Asis.Set_Get; with Atree; use Atree; with Opt; use Opt; with Sinfo; use Sinfo; with Sinput; use Sinput; with Widechar; use Widechar; package body A4G.A_Sinput is use ASCII; -- Make control characters visible ----------------------- -- Local subprograms -- ----------------------- procedure Skip_Comment (P : in out Source_Ptr); -- When P is set on the first '-' of a comment, this procedure resets -- the value of P to the first character of the group of control -- characters signifying the end of line containing the comment -- initially indicated by P. -- -- This procedure should not be used for the last comment in the -- group of comments following a compilation unit in a compilation. procedure Skip_String (P : in out Source_Ptr); -- When P set on the first quoter of a string literal (it may be '"' or -- '%', this procedure resets the value of P to the first character -- after the literal. ------------------------- -- A_Get_Column_Number -- ------------------------- function A_Get_Column_Number (P : Source_Ptr) return Source_Ptr is Sindex : constant Source_File_Index := Get_Source_File_Index (P); Src : constant Source_Buffer_Ptr := Source_Text (Sindex); S : Source_Ptr; Result : Source_Ptr := 0; begin S := Line_Start (P); while S <= P loop if Is_Start_Of_Wide_Char_For_ASIS (Src, S) then Skip_Wide_For_ASIS (Src, S); else S := S + 1; end if; Result := Result + 1; end loop; return Result; end A_Get_Column_Number; ----------------------- -- Comment_Beginning -- ----------------------- function Comment_Beginning (Line_Image : Text_Buffer) return Source_Ptr is Line_Image_Start : constant Source_Ptr := Line_Image'First; Line_Image_End : constant Source_Ptr := Line_Image'Last; Scanner_Pos : Source_Ptr; String_Delimiter : Standard.Character; begin Scanner_Pos := Line_Image_Start - 1; Scan_The_Line : while Scanner_Pos < Line_Image_End loop Scanner_Pos := Scanner_Pos + 1; case Line_Image (Scanner_Pos) is when '"' | '%' => if not ((Scanner_Pos - 1) >= Line_Image_Start and then Line_Image (Scanner_Pos - 1) = ''' and then (Scanner_Pos + 1) <= Line_Image_End and then Line_Image (Scanner_Pos + 1) = ''') then -- We have to awoid considering character literals '"' -- '%' as string brackets String_Delimiter := Line_Image (Scanner_Pos); Skip_String_Literal : loop Scanner_Pos := Scanner_Pos + 1; if Line_Image (Scanner_Pos) = String_Delimiter then -- we are in a legal Ada source, therefore: if Scanner_Pos < Line_Image'Last and then Line_Image (Scanner_Pos + 1) = String_Delimiter then -- Delimiter as character inside the literal. Scanner_Pos := Scanner_Pos + 1; else -- End of the literal. exit Skip_String_Literal; end if; end if; end loop Skip_String_Literal; end if; when '-' => if (Scanner_Pos < Line_Image'Last) and then (Line_Image (Scanner_Pos + 1) = '-') then return Scanner_Pos; end if; when others => null; end case; end loop Scan_The_Line; -- There wasn't any comment if we reach this point. return No_Location; end Comment_Beginning; -------------------- -- Exp_Name_Image -- -------------------- function Exp_Name_Image (Name : Node_Id) return String is Prefix_Node : Node_Id; Selector_Node : Node_Id; begin if Nkind (Name) = N_Identifier or else Nkind (Name) = N_Defining_Identifier then -- ????? See E729-A04! return Identifier_Image (Name); end if; if Nkind (Name) = N_Defining_Program_Unit_Name then Prefix_Node := Sinfo.Name (Name); Selector_Node := Defining_Identifier (Name); else -- Nkind (Name) = N_Expanded_Name Prefix_Node := Prefix (Name); Selector_Node := Selector_Name (Name); end if; return Exp_Name_Image (Prefix_Node) & '.' & Identifier_Image (Selector_Node); -- ??? end Exp_Name_Image; ------------------- -- Get_Character -- ------------------- function Get_Character (P : Source_Ptr) return Character is Sindex : constant Source_File_Index := Get_Source_File_Index (P); Src : constant Source_Buffer_Ptr := Source_Text (Sindex); begin return Src (P); end Get_Character; ------------------ -- Get_Location -- ------------------ function Get_Location (E : Asis.Element) return Source_Ptr is begin return Sloc (Node (E)); end Get_Location; ------------------------- -- Get_Num_Literal_End -- ------------------------- function Get_Num_Literal_End (P : Source_Ptr) return Source_Ptr is Sindex : constant Source_File_Index := Get_Source_File_Index (P); Src : constant Source_Buffer_Ptr := Source_Text (Sindex); S : Source_Ptr; B_Char : Character; begin -- Src (P) is the leading digit of a numeric literal S := P + 1; loop if Is_Hexadecimal_Digit (Src (S)) or else Src (S) = '_' then S := S + 1; elsif Src (S) = '#' or else Src (S) = ':' then -- based literal: 16#E#E1 or 016#offf# -- J.2 (3): "The number sign characters (#) of a based_literal -- can be replaced by colons (:) provided that the replacement -- is done for both occurrences. But in case of a colon, we -- have to make sure that we indeed have a based literal, but not -- a decimal literal immediatelly followed by an assignment sign, -- see G119-012: -- -- SPLIT_INDEX:INTEGER RANGE 1..80:=1; if Src (S) = ':' and then Src (S + 1) = '=' then S := S - 1; exit; end if; B_Char := Src (S); -- and now - looking for trailing '#' or ':': S := S + 1; while Src (S) /= B_Char loop S := S + 1; end loop; if Src (S + 1) = 'E' or else Src (S + 1) = 'e' then -- this means something like 5#1234.1234#E2 S := S + 2; else exit; end if; elsif Src (S) = '+' or else Src (S) = '-' then -- 12E+34 or 12+34? if Src (S - 1) = 'E' or else Src (S - 1) = 'e' then -- it is the sign of the exponent S := S + 1; else S := S - 1; -- to go back in the literal exit; end if; elsif Src (S) = '.' then -- 3.14 or 3..14? if Is_Hexadecimal_Digit (Src (S + 1)) then S := S + 1; else S := S - 1; -- to go back in the literal exit; end if; else -- for sure, we already are outside the literal S := S - 1; -- to go back in the literal exit; end if; end loop; return S; end Get_Num_Literal_End; -------------------- -- Get_String_End -- -------------------- function Get_String_End (P : Source_Ptr) return Source_Ptr is Sindex : constant Source_File_Index := Get_Source_File_Index (P); Src : constant Source_Buffer_Ptr := Source_Text (Sindex); S : Source_Ptr; Quote : Character; begin -- Src (P) is the leading quotation of the non-nul string constant -- which can be either '"' OR '%' (J.2 (2)). Quote := Src (P); S := P + 1; loop if Src (S) = Quote and then Src (S + 1) = Quote then S := S + 2; elsif Src (S) /= Quote then if Is_Start_Of_Wide_Char_For_ASIS (Src, S) then Skip_Wide_For_ASIS (Src, S); else S := S + 1; end if; else -- S points to the trailing quotation of the constant exit; end if; end loop; return S; end Get_String_End; ------------------- -- Get_Wide_Word -- ------------------- function Get_Wide_Word (P_Start : Source_Ptr; P_End : Source_Ptr) return Wide_String is Sindex : constant Source_File_Index := Get_Source_File_Index (P_Start); Src : constant Source_Buffer_Ptr := Source_Text (Sindex); Result : Wide_String (1 .. Positive (P_End - P_Start + 1)); Last_Idx : Natural := 0; Next_Ch : Char_Code; S : Source_Ptr; Success : Boolean; pragma Unreferenced (Success); begin S := P_Start; while S <= P_End loop Last_Idx := Last_Idx + 1; if Is_Start_Of_Wide_Char_For_ASIS (Src, S) then Scan_Wide (Src, S, Next_Ch, Success); Result (Last_Idx) := Wide_Character'Val (Next_Ch); else Result (Last_Idx) := To_Wide_Character (Src (S)); S := S + 1; end if; end loop; return Result (1 .. Last_Idx); end Get_Wide_Word; ----------------- -- Get_Wide_Ch -- ----------------- function Get_Wide_Ch (S : Source_Ptr) return Wide_Character is Sindex : constant Source_File_Index := Get_Source_File_Index (S); Src : constant Source_Buffer_Ptr := Source_Text (Sindex); S1 : Source_Ptr := S; Ch : Char_Code; Result : Wide_Character; Success : Boolean; pragma Unreferenced (Success); begin if Is_Start_Of_Wide_Char_For_ASIS (Src, S1) then Scan_Wide (Src, S1, Ch, Success); Result := Wide_Character'Val (Ch); else Result := To_Wide_Character (Src (S1)); end if; return Result; end Get_Wide_Ch; ------------------ -- Get_Word_End -- ------------------ function Get_Word_End (P : Source_Ptr; In_Word : In_Word_Condition) return Source_Ptr is S : Source_Ptr; begin S := P; while In_Word (S + 1) loop S := S + 1; end loop; return S; end Get_Word_End; ---------------------- -- Identifier_Image -- ---------------------- function Identifier_Image (Ident : Node_Id) return String is Image_Start : Source_Ptr; Image_End : Source_Ptr; begin Image_Start := Sloc (Ident); Image_End := Get_Word_End (P => Image_Start, In_Word => In_Identifier'Access); -- See E729-A04!!! return To_String (Get_Wide_Word (Image_Start, Image_End)); end Identifier_Image; ------------------- -- In_Identifier -- ------------------- function In_Identifier (P : Source_Ptr) return Boolean is Sindex : constant Source_File_Index := Get_Source_File_Index (P); Src : constant Source_Buffer_Ptr := Source_Text (Sindex); Char : Character; Result : Boolean := True; begin Char := Src (P); if Char = ' ' or else Char = '&' or else Char = ''' or else Char = '(' or else Char = ')' or else Char = '*' or else Char = '+' or else Char = ',' or else Char = '-' or else Char = '.' or else Char = '/' or else Char = ':' or else Char = ';' or else Char = '<' or else Char = '=' or else Char = '>' or else Char = '|' or else Char = ASCII.LF or else Char = ASCII.FF or else Char = ASCII.HT or else Char = ASCII.VT or else Char = ASCII.CR then Result := False; end if; return Result; end In_Identifier; ----------------- -- Is_EOL_Char -- ----------------- function Is_EOL_Char (Ch : Character) return Boolean is Result : Boolean := False; begin Result := Ch = ASCII.CR or else Ch = ASCII.LF or else Ch = ASCII.FF or else Ch = ASCII.VT; return Result; end Is_EOL_Char; ------------------------------------ -- Is_Start_Of_Wide_Char_For_ASIS -- ------------------------------------ function Is_Start_Of_Wide_Char_For_ASIS (S : Source_Buffer_Ptr; P : Source_Ptr; C : Source_Ptr := No_Location) return Boolean is Result : Boolean := False; begin if C /= No_Location and then P > C then -- We are in comment, so we can not have bracket encoding if Wide_Character_Encoding_Method /= WCEM_Brackets then Result := Is_Start_Of_Wide_Char (S, P); end if; else Result := Is_Start_Of_Wide_Char (S, P); if not Result then Result := P <= S'Last - 2 and then S (P) = '[' and then S (P + 1) = '"' and then (S (P + 2) in '0' .. '9' or else S (P + 2) in 'a' .. 'f' or else S (P + 2) in 'A' .. 'F'); end if; end if; return Result; end Is_Start_Of_Wide_Char_For_ASIS; --------------------- -- Next_Identifier -- --------------------- function Next_Identifier (P : Source_Ptr) return Source_Ptr is Sindex : constant Source_File_Index := Get_Source_File_Index (P); Src : constant Source_Buffer_Ptr := Source_Text (Sindex); S : Source_Ptr; begin S := P + 1; while not Is_Letter (Src (S)) loop if Src (S) = '-' and then Src (S + 1) = '-' then Skip_Comment (S); else S := S + 1; end if; end loop; return S; end Next_Identifier; --------------------- -- Number_Of_Lines -- --------------------- function Number_Of_Lines (E : Asis.Element) return Integer is SFI : constant Source_File_Index := Get_Source_File_Index (Get_Location (E)); begin -- return Integer (Num_Source_Lines (SFI) + Line_Offset (SFI)); return Integer (Num_Source_Lines (SFI)); end Number_Of_Lines; -------------------- -- Operator_Image -- -------------------- function Operator_Image (Node : Node_Id) return String is S_Start : constant Source_Ptr := Sloc (Node); -- S_Start points to the leading character of a given operator symbol. Sindex : constant Source_File_Index := Get_Source_File_Index (S_Start); Src : constant Source_Buffer_Ptr := Source_Text (Sindex); S_End : Source_Ptr := S_Start; -- should be set as pointing to the last character of a given -- operator symbol. Ch : Character; begin Ch := Src (S_Start); if Ch = 'A' or else Ch = 'a' -- "abs" or "and" or else Ch = 'M' or else Ch = 'm' -- "mod" or else Ch = 'N' or else Ch = 'n' -- "not" or else Ch = 'R' or else Ch = 'r' -- "rem" or else Ch = 'X' or else Ch = 'x' -- "xor" then S_End := S_Start + 2; elsif Ch = 'O' or else Ch = 'o' then -- "or" S_End := S_Start + 1; elsif Ch = '=' -- "=" or else Ch = '+' -- "+" or else Ch = '-' -- "-" or else Ch = '&' -- "&" then S_End := S_Start; elsif Ch = '/' -- "/=" or "/"? or else Ch = '<' -- "<=" or "<"? or else Ch = '>' -- ">=" or ">"? or else Ch = '*' -- "**" or "*"? then Ch := Src (S_Start + 1); if Ch = '=' or else -- "/=", "<=" or ">=" Ch = '*' -- "**" then S_End := S_Start + 1; else S_End := S_Start; -- "<", ">", "*" or "/" end if; end if; return (1 => '"') & String (Src (S_Start .. S_End)) & (1 => '"'); end Operator_Image; ------------------------- -- Rightmost_Non_Blank -- ------------------------- function Rightmost_Non_Blank (P : Source_Ptr) return Source_Ptr is S : Source_Ptr := P; Sindex : constant Source_File_Index := Get_Source_File_Index (P); Src : constant Source_Buffer_Ptr := Source_Text (Sindex); begin loop if Src (S) = '-' and then Src (S + 1) = '-' then Skip_Comment (S); elsif Is_Graphic (Src (S)) and then Src (S) /= ' ' then exit; else S := S + 1; end if; end loop; return S; end Rightmost_Non_Blank; ------------------------------ -- Search_Beginning_Of_Word -- ------------------------------ function Search_Beginning_Of_Word (S : Source_Ptr) return Source_Ptr is SFI : constant Source_File_Index := Get_Source_File_Index (S); Src : constant Source_Buffer_Ptr := Source_Text (SFI); S_P : Source_Ptr; begin S_P := S; while S_P >= Source_First (SFI) and then (Src (S_P) in 'A' .. 'Z' or else Src (S_P) in 'a' .. 'z' or else Src (S_P) in '0' .. '9' or else Src (S_P) = '_') loop S_P := S_P - 1; end loop; return S_P + 1; end Search_Beginning_Of_Word; ------------------------ -- Search_End_Of_Word -- ------------------------ function Search_End_Of_Word (S : Source_Ptr) return Source_Ptr is S_P : Source_Ptr := S; SFI : constant Source_File_Index := Get_Source_File_Index (S); Src : constant Source_Buffer_Ptr := Source_Text (SFI); Char : Character; begin Char := Src (S_P); while not (Char = ' ' or else Char = '&' or else Char = ''' or else Char = '(' or else Char = ')' or else Char = '*' or else Char = '+' or else Char = ',' or else Char = '-' or else Char = '.' or else Char = '/' or else Char = ':' or else Char = ';' or else Char = '<' or else Char = '=' or else Char = '>' or else Char = '|' or else Char = '!' or else Char = ASCII.LF or else Char = ASCII.FF or else Char = ASCII.HT or else Char = ASCII.VT or else Char = ASCII.CR) loop S_P := S_P + 1; Char := Src (S_P); end loop; S_P := S_P - 1; return S_P; end Search_End_Of_Word; ----------------------------- -- Search_Left_Parenthesis -- ----------------------------- function Search_Left_Parenthesis (S : Source_Ptr) return Source_Ptr is S_P : Source_Ptr := S - 1; SFI : constant Source_File_Index := Get_Source_File_Index (S); Src : constant Source_Buffer_Ptr := Source_Text (SFI); begin loop case Src (S_P) is when '(' => return S_P; when CR | LF => declare TempS : Source_Ptr := Line_Start (S_P); begin while (Src (TempS) /= '-' or else Src (TempS + 1) /= '-') and then TempS < S_P loop TempS := TempS + 1; end loop; S_P := TempS - 1; end; when others => S_P := S_P - 1; end case; end loop; end Search_Left_Parenthesis; ---------------------- -- Search_Next_Word -- ---------------------- function Search_Next_Word (S : Source_Ptr) return Source_Ptr is S_P : Source_Ptr := S + 1; SFI : constant Source_File_Index := Get_Source_File_Index (S); Src : constant Source_Buffer_Ptr := Source_Text (SFI); begin loop case Src (S_P) is when ' ' | HT | CR | LF => S_P := S_P + 1; when '-' => if Src (S_P + 1) = '-' then Skip_Comment (S_P); else return S_P; end if; when others => return S_P; end case; end loop; end Search_Next_Word; ---------------------- -- Search_Prev_Word -- ---------------------- function Search_Prev_Word (S : Source_Ptr) return Source_Ptr is S_P : Source_Ptr := S - 1; SFI : constant Source_File_Index := Get_Source_File_Index (S); Src : constant Source_Buffer_Ptr := Source_Text (SFI); begin loop case Src (S_P) is when ' ' | HT => S_P := S_P - 1; when CR | LF => declare TempS : Source_Ptr := Line_Start (S_P); begin while (Src (TempS) /= '-' or else Src (TempS + 1) /= '-') and then TempS < S_P loop TempS := TempS + 1; end loop; S_P := TempS - 1; end; when others => return S_P; end case; end loop; end Search_Prev_Word; ---------------------------- -- Search_Prev_Word_Start -- ---------------------------- function Search_Prev_Word_Start (S : Source_Ptr) return Source_Ptr is begin return Search_Beginning_Of_Word (Search_Prev_Word (S)); end Search_Prev_Word_Start; ----------------------------- -- Search_Rightmost_Symbol -- ----------------------------- function Search_Rightmost_Symbol (P : Source_Ptr; Char : Character := ';') return Source_Ptr is S : Source_Ptr := P; -- the location to be returned, the search is started from P Sindex : constant Source_File_Index := Get_Source_File_Index (P); Src : constant Source_Buffer_Ptr := Source_Text (Sindex); begin while Src (S) /= Char loop if Src (S) = '-' and then Src (S + 1) = '-' then Skip_Comment (S); elsif (Src (S) = '"' or else Src (S) = '%') and then not (Src (S - 1) = ''' and then Src (S + 1) = ''') then Skip_String (S); else S := S + 1; end if; end loop; return S; end Search_Rightmost_Symbol; ----------------- -- Skip_String -- ----------------- procedure Skip_String (P : in out Source_Ptr) is Sindex : constant Source_File_Index := Get_Source_File_Index (P); Src : constant Source_Buffer_Ptr := Source_Text (Sindex); Quoter : constant Character := Src (P); begin -- we are in the beginning of a legal string literal in a legal -- Ada program. So we do not have to be careful with all -- the checks: while not (Src (P) = Quoter and then Src (P + 1) /= Quoter) loop P := P + 1; end loop; P := P + 1; end Skip_String; ------------------ -- Skip_Comment -- ------------------ procedure Skip_Comment (P : in out Source_Ptr) is Sindex : constant Source_File_Index := Get_Source_File_Index (P); Src : constant Source_Buffer_Ptr := Source_Text (Sindex); begin if Src (P) = '-' and then Src (P + 1) = '-' then P := P + 2; while not (Src (P) = VT or else Src (P) = CR or else Src (P) = LF or else Src (P) = FF) loop P := P + 1; end loop; end if; end Skip_Comment; ------------------------ -- Skip_Wide_For_ASIS -- ------------------------ procedure Skip_Wide_For_ASIS (S : Source_Buffer_Ptr; P : in out Source_Ptr) is Old_P : constant Source_Ptr := P; Old_Wide_Character_Encoding_Method : WC_Encoding_Method; begin Skip_Wide (S, P); if P = Old_P + 1 then -- We have a bracket encoding, but the encoding method is different -- from WCEM_Brackets P := P - 1; Old_Wide_Character_Encoding_Method := Wide_Character_Encoding_Method; Wide_Character_Encoding_Method := WCEM_Brackets; Skip_Wide (S, P); Wide_Character_Encoding_Method := Old_Wide_Character_Encoding_Method; end if; end Skip_Wide_For_ASIS; ------------------------------ -- Source_Locations_To_Span -- ------------------------------ function Source_Locations_To_Span (Span_Beg : Source_Ptr; Span_End : Source_Ptr) return Span is Sp : Span; begin Sp.First_Line := Line_Number (Get_Physical_Line_Number (Span_Beg)); Sp.First_Column := Character_Position (A_Get_Column_Number (Span_Beg)); Sp.Last_Line := Line_Number (Get_Physical_Line_Number (Span_End)); Sp.Last_Column := Character_Position (A_Get_Column_Number (Span_End)); return Sp; end Source_Locations_To_Span; ----------------------- -- Wide_String_Image -- ----------------------- function Wide_String_Image (Node : Node_Id) return Wide_String is S_Start : constant Source_Ptr := Sloc (Node); -- S_Start points to the leading quote of a given string literal. Sindex : constant Source_File_Index := Get_Source_File_Index (S_Start); Src : constant Source_Buffer_Ptr := Source_Text (Sindex); S_End : Source_Ptr := S_Start + 1; -- should be set as pointing to the last character of a -- string literal; empty and non-empty literals are processed -- in the same way - we simply take a literal as it is from the -- Source Buffer Quote : constant Character := Src (S_Start); -- Quoter may be '"' or '%'! begin loop if Src (S_End) = Quote and then Src (S_End + 1) = Quote then -- doubled string quote as an element of a given string S_End := S_End + 2; elsif Src (S_End) /= Quote then -- "usial" string element S_End := S_End + 1; else -- S_End points to the trailing quote of a given string exit; end if; end loop; declare Result : Wide_String (1 .. Positive (S_End - S_Start + 1)); Last_Idx : Natural := 0; Next_Ch : Char_Code; S : Source_Ptr; Success : Boolean; pragma Unreferenced (Success); begin S := S_Start; while S <= S_End loop Last_Idx := Last_Idx + 1; if Is_Start_Of_Wide_Char_For_ASIS (Src, S) then Scan_Wide (Src, S, Next_Ch, Success); Result (Last_Idx) := Wide_Character'Val (Next_Ch); else Result (Last_Idx) := To_Wide_Character (Src (S)); S := S + 1; end if; end loop; return Result (1 .. Last_Idx); end; end Wide_String_Image; end A4G.A_Sinput; asis-2010.orig/asis/a4g-a_sinput.ads0000644000175000017500000003574311574704441017142 0ustar lbrentalbrenta------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- A 4 G . S I N P U T -- -- -- -- S p e c -- -- -- -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- ASIS-for-GNAT 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 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 51 Franklin -- -- Street, Fifth Floor, Boston, MA 02110-1301, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by AdaCore -- -- (http://www.adacore.com). -- -- -- ------------------------------------------------------------------------------ -- This package adds to the GNAT Sinput package some utility routines -- used for obtaining and/or analyzing the pieces of the compilation -- unit's source code from the source buffer. -- -- Note, that up to the version 3.09, the Tree_Read procedure in the GNAT -- Sinput package contains a bug - it does not reset to the initial values -- the global variables used to implement caching for searching for -- a source file index. The ASIS implementation includes the corrected -- version of Sinput package -- -- The routines defined in this package are intended to be used in the -- implementation of the Asis.Text package and for implementing queries -- from other ASIS packages having String or Asis_String as the returned -- (sub)type. -- -- All the routines defined in this package rely on the fact that all -- the source buffers being accessed correspond to the compilable units, -- so they do not care about error finding and recovery. with Asis.Text; use Asis.Text; with Types; use Types; package A4G.A_Sinput is function A_Get_Column_Number (P : Source_Ptr) return Source_Ptr; -- This function differs from the Sinput.Get_Column_Number function in two -- aspects. First, it does not make any transformations of Tab characters -- into equivalent sequences of blanks to represent the standard 1,9,17.. -- spacing pattern, it returns the column number of the specified -- Source_Ptr value as the "distance" from the beginning of the -- corresponding line in the source text. Second, this function considers a -- content of the source buffer as a possible encoding of wide character -- string and counts the column number in wide characters that make up -- the source code. function Wide_String_Image (Node : Node_Id) return Wide_String; -- for Node of N_String_Literal, N_Defining_Operator_Symbol or -- N_Operator_Symbol kind returns the string image of the corresponding -- represented string literal, including string quoters, as it is -- required by the ASIS queries Value_Image, Name_Image and -- Defining_Name_Image. It is an error to call this function for -- a node of some other node kind. This function transformes the internal -- representation of the argument construct taking into account the -- encoding method. function Operator_Image (Node : Node_Id) return String; -- this function returns the string imege of an operator_symbol -- from infix calls to operator functions. It works on nodes of -- N_Identifier and N_Op_Xxx kind. The result includes string quotes -- as for the prefix call to operator function. function Get_Character (P : Source_Ptr) return Character; -- Returns the character pointed by P. -- This function is not "tree-swapping-safe" -- FROM S_B_Serv and from Subservises function Get_Wide_Word (P_Start : Source_Ptr; P_End : Source_Ptr) return Wide_String; -- Returns a part of the source text corresponding to the part of ints -- internal representation bounded by P_Start .. P_End. Takes into account -- the encoding of wide characters and makes the corresponding conversions. -- This function does not check, that P_Start and P_End both point into the -- same source. -- This function is not "tree-swapping-safe" function Source_Locations_To_Span (Span_Beg : Source_Ptr; Span_End : Source_Ptr) return Span; -- Transforms the pair of locations in the source buffer into an -- ASIS Span. Note, that ASIS Span counts the source positions in wide -- characters, whereas Span_Beg and Span_End are pointers to the internal -- string (but not wide string!) representation of the source text! -- This function is not "tree-swapping-safe" function Get_Location (E : Asis.Element) return Source_Ptr; -- Returns the value of the Sloc field of the (original) node -- on which E is based -- This function is "tree-swapping-safe" -- FROM Subservises function Number_Of_Lines (E : Asis.Element) return Integer; -- Returns the number of the last line in the source file accessable -- through this Element, taking into account Source_Reference pragma if -- it presents in the source file. -- -- This function is "tree-swapping-safe" -- FROM Subservises function Identifier_Image (Ident : Node_Id) return String; -- For a node, which is of N_Identifier or N_Defining_Identifier kind, -- this function returns the string image of the corresponding -- (defining) identifier -- Note, that this function does not take into account the possible -- encoding of upper half wide characters. The results of this function are -- used in internal Compilation Unit table only, so this function does not -- make any problem for proper encoding processing in Asis.Text. But anyway -- this should be revised to completely conform to the source -- representation required by the Ada standard. function Exp_Name_Image (Name : Node_Id) return String; -- For a node, which is of N_Defining_Program_Unit_Name, -- N_Defining_Identifier, N_Expanded_Name or N_Identifier kind, -- this function returns the string image of the corresponding name function Comment_Beginning (Line_Image : Text_Buffer) return Source_Ptr; -- Returns position of the first _comment_ hyphen in the argument string. -- If there is no comment, then returns No_Location. -- The string has to correspond to a legal Ada program fragment, -- otherwise a constraint error may be raised. -- -- Note, that this function can be used for detecting the comment beginning -- in the line buffer of the Standard String type, because the index range -- of Text_Buffer (and the range of Source_Ptr) includes the low bound of -- Positive. ------------------------------------------------------------------------ -- Staring from this point, some mess exists, which originates from -- -- collecting all the text processing/source buffer-processing -- -- routines from Subservices and S_B_Serv -- ------------------------------------------------------------------------ function Next_Identifier (P : Source_Ptr) return Source_Ptr; -- Returns the location of the first charaster of the identifier which -- should follow the position indicated by P. Initially this -- function was intended to find the beginning of the pragma identifier, -- so two requirements should be met for its correct use: P points to -- some separator (as defined by RM 95 2.2 (3-6), and the next lexem -- should be either comment or identifier. -- This function is not "tree-swapping-safe" -- FROM S_B_Serv function Get_String_End (P : Source_Ptr) return Source_Ptr; -- Supposing that P points to the leading quotation of the string -- literal, this function defines the location of the quotation -- ending the string constant. -- This function is not "tree-swapping-safe" -- FROM S_B_Serv function Get_Num_Literal_End (P : Source_Ptr) return Source_Ptr; -- Supposing that P points to the first character of a numeric -- literal, this function defines the location of the last character -- of the literal. -- This function is not "tree-swapping-safe" -- FROM S_B_Serv function Search_Rightmost_Symbol (P : Source_Ptr; Char : Character := ';') return Source_Ptr; -- The function returns the location of the rightmost symbol equial -- to Char for the position indicated by P (including P itself). -- Comments are skipped during the search -- This function is not "tree-swapping-safe" -- FROM S_B_Serv function Rightmost_Non_Blank (P : Source_Ptr) return Source_Ptr; -- returns the first non-blank symbol (excluding format effectors) -- following P (if P itself is a non-blank symbol, P is returned). -- Comments are skipped type In_Word_Condition is access function (P : Source_Ptr) return Boolean; -- I wish I had time to get rid of this awkward approach based on -- In_Word_Condition! :(( function Get_Word_End (P : Source_Ptr; In_Word : In_Word_Condition) return Source_Ptr; -- The function returns the location of the firs/last character of the -- lexical element which contains character pointed by P. It is supposed -- that P does not point inside comment, separator or delimiter (RM95 2.2) -- -- The first version of these function (with the second parameters of -- In_Word_Char_Condition type is used when it is enough to test only one -- character to get the answer. But if it is necessary to examine some -- characters before/after the given character, the second form should be -- used with the corresponding test function. -- -- The initial idea is to use these functions to get the start/end of -- identifiers, numeric literals and string literals. -- This function is not "tree-swapping-safe" -- FROM S_B_Serv function In_Identifier (P : Source_Ptr) return Boolean; -- Returns true if P points somewhere inside an identifier, and False -- otherwise -- This function is not "tree-swapping-safe" -- FROM S_B_Serv function Search_Prev_Word (S : Source_Ptr) return Source_Ptr; -- Returns the location of the previous word end. -- The comments are skipped. -- This function is not "tree-swapping-safe" -- FROM Subservises function Search_Beginning_Of_Word (S : Source_Ptr) return Source_Ptr; -- Returns the location of the beginning of the word to which S points. -- This function is not "tree-swapping-safe" -- FROM Subservises function Search_Prev_Word_Start (S : Source_Ptr) return Source_Ptr; -- Equivalent to Search_Beginning_Of_Word (Search_Prev_Word (S)) function Search_End_Of_Word (S : Source_Ptr) return Source_Ptr; -- Returns the location of the end of the word to which S points. -- This function is not "tree-swapping-safe" -- FROM Subservises -- It's crazy to have it along with Get_Word_End!!! function Search_Next_Word (S : Source_Ptr) return Source_Ptr; -- Returns the location of the next word beginning. The comments -- are skipped. -- This function is not "tree-swapping-safe" -- FROM Subservises function Search_Left_Parenthesis (S : Source_Ptr) return Source_Ptr; -- Returns the location of the first inclusion of left parenthesis before -- the location in source file to which S points. -- This function is not "tree-swapping-safe" -- FROM Subservises function Is_EOL_Char (Ch : Character) return Boolean; -- Checks if Ch is a character defining an end of line. According to RM05 -- 2.2(2/2), "a sequence of one or more format_effectors other than the -- character whose code position is 16#09# (CHARACTER TABULATION) signifies -- at least one end of line." function Get_Wide_Ch (S : Source_Ptr) return Wide_Character; -- Provided that S points to the first character of the internal -- representation of some character from the original source, returns -- this riginal source character, taking into account the encoding method function Is_Start_Of_Wide_Char_For_ASIS (S : Source_Buffer_Ptr; P : Source_Ptr; C : Source_Ptr := No_Location) return Boolean; -- Determines if S (P) is the start of a wide character sequence. This -- function differs from Widechar in two aspects: first, it assumes that -- the bracket encoding can not be used in a comment text, and if set, the -- actual for C should point to the beginning of the comment that in the -- source buffer, and second, in any non-comment text it assumes that a -- bracket encoding is always set ON (see the description of -gnatW option -- in GNAT UGN). procedure Skip_Wide_For_ASIS (S : Source_Buffer_Ptr; P : in out Source_Ptr); -- Similar to Widechar.Skip_Wide, but always skips bracked encoding -- sequense. Before calling this function, the caller should check thar -- Is_Start_Of_Wide_Char_For_ASIS (S, P) is True end A4G.A_Sinput; asis-2010.orig/asis/a4g-a_stand.ads0000644000175000017500000000671611574704441016727 0ustar lbrentalbrenta------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- A 4 G . A _ S T A N D -- -- -- -- S p e c -- -- -- -- $Revision: 15117 $ -- -- -- Copyright (c) 2002, Free Software Foundation, Inc. -- -- -- -- ASIS-for-GNAT 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 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 59 Temple Place -- -- - Suite 330, Boston, MA 02111-1307, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by Ada Core Technologies Inc -- -- (http://www.gnat.com). -- -- -- ------------------------------------------------------------------------------ -- We need this renaming because the GNAT Stand package and the ASIS A4G.Stand -- package conflict if mentioned in the same context clause. This renaming -- seems to be the cheapest way to correct the old bad choice of the name -- of the ASIS package (A4G.Stand) with A4G.Stand; package A4G.A_Stand renames A4G.Stand; asis-2010.orig/asis/a4g-a_types.adb0000644000175000017500000001536611574704441016742 0ustar lbrentalbrenta------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- A 4 G . A _ T Y P E S -- -- -- -- B o d y -- -- -- -- Copyright (c) 1995-2006, Free Software Foundation, Inc. -- -- -- -- ASIS-for-GNAT 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 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 51 Franklin -- -- Street, Fifth Floor, Boston, MA 02110-1301, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by AdaCore -- -- (http://www.adacore.com). -- -- -- ------------------------------------------------------------------------------ package body A4G.A_Types is --------------- -- A_OS_Time -- --------------- function A_OS_Time return ASIS_OS_Time is begin return ASIS_Clock; end A_OS_Time; --------------------------- -- Increase_ASIS_OS_Time -- --------------------------- procedure Increase_ASIS_OS_Time is begin ASIS_Clock := ASIS_Clock + 1; end Increase_ASIS_OS_Time; ----------- -- Later -- ----------- function Later (L, R : ASIS_OS_Time) return Boolean is begin return L <= R; end Later; ------------------------------ -- Parameter_String_To_List -- ------------------------------ function Parameter_String_To_List (Par_String : String) return Argument_List_Access is Max_Pars : constant Integer := Par_String'Length; New_Parv : Argument_List (1 .. Max_Pars); New_Parc : Natural := 0; Idx : Integer; Old_Idx : Integer; function Move_To_Next_Par (Ind : Integer) return Integer; -- Provided that Ind points somewhere inside Par_String, moves -- it ahead to point to the beginning of the next parameter if -- Ind points to the character considering as a parameter separator, -- otherwise returns Ind unchanged. If Ind points to a separator and -- there is no more parameters ahead, Par_String'Last + 1 is returned. -- (See the definition of the syntax of the Parameters string in the -- ASIS Reference Manual) function Move_To_Par_End (Ind : Integer) return Integer; -- Provided that Ind points to some character of a separate parameters -- being a part of Par_String, returns the index of the last charactre -- of this parameter function Move_To_Next_Par (Ind : Integer) return Integer is Result : Integer := Ind; begin while Result <= Par_String'Last and then (Par_String (Result) = ' ' or else Par_String (Result) = ASCII.HT or else Par_String (Result) = ASCII.LF or else Par_String (Result) = ASCII.CR) loop Result := Result + 1; end loop; return Result; end Move_To_Next_Par; function Move_To_Par_End (Ind : Integer) return Integer is Result : Integer := Ind; Quoted : Boolean := False; begin loop -- Am unquoted white space or EOL is the end of an argument if not Quoted and then (Par_String (Result) = ' ' or else Par_String (Result) = ASCII.HT or else Par_String (Result) = ASCII.LF or else Par_String (Result) = ASCII.CR) then exit; -- Start of quoted string elsif not Quoted and then Par_String (Result) = '"' then Quoted := True; -- End of a quoted string and end of an argument elsif Quoted and then Par_String (Result) = '"' then Result := Result + 1; exit; end if; Result := Result + 1; exit when Result > Par_String'Last; end loop; Result := Result - 1; return Result; end Move_To_Par_End; begin Idx := Move_To_Next_Par (Par_String'First); while Idx <= Par_String'Last loop Old_Idx := Idx; Idx := Move_To_Par_End (Idx); New_Parc := New_Parc + 1; New_Parv (New_Parc) := new String'(Par_String (Old_Idx .. Idx)); Idx := Move_To_Next_Par (Idx + 1); end loop; return new Argument_List'(New_Parv (1 .. New_Parc)); end Parameter_String_To_List; end A4G.A_Types; asis-2010.orig/asis/a4g-a_types.ads0000644000175000017500000004642311574704441016761 0ustar lbrentalbrenta------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- A 4 G . A _ T Y P E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- -- -- -- ASIS-for-GNAT 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 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 51 Franklin -- -- Street, Fifth Floor, Boston, MA 02110-1301, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by AdaCore -- -- (http://www.adacore.com). -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; with Ada.Characters.Handling; use Ada.Characters.Handling; with GNAT.OS_Lib; use GNAT.OS_Lib; package A4G.A_Types is -- This package is the ASIS implementation's analog of the GNAT Types -- package (except the part related to the ASIS_OS_Time type). -- It contains host independent type and constant definitions -- which is supposed to be used in more than one unit in the ASIS -- implementation. -- ------------------ -- ASIS_OS_Time -- ------------------ -- To check, that a given abstraction is valid in the sense defined by the -- ASIS standard (that is, that the enclosing Context of the given -- abstraction has not been closed after creating this abstraction), ASIS -- needs some kind of logical time (or logical time stamp). This logical -- time is increased each time when any ASIS Context is opened. It is not -- reset when ASIS is initialized, because it may lead to collisions in -- validity checks -- An ASIS abstraction is valid if its logical time stamp is equal or -- greater then the time stamp of its enclosing Context. type ASIS_OS_Time is private; Nil_ASIS_OS_Time : constant ASIS_OS_Time; Last_ASIS_OS_Time : constant ASIS_OS_Time; procedure Increase_ASIS_OS_Time; -- Increases the ASIS logical "clock" function A_OS_Time return ASIS_OS_Time; -- Gets the current value of the ASIS logical "clock" function Later (L, R : ASIS_OS_Time) return Boolean; -- Compares time stamps. ----------------------------------------- -- Types for Context and Context Table -- ----------------------------------------- Inconsistent_Incremental_Context : exception; -- raised when any inconsistency found for Incremental Tree processing -- mode Context_Low_Bound : constant := 0; Context_High_Bound : constant := 1_000_000; type Context_Id is range Context_Low_Bound .. Context_High_Bound; -- Type used to identify entries in ASIS Context table Non_Associated : constant Context_Id := Context_Low_Bound; Nil_Context_Id : constant Context_Id := Context_Low_Bound; First_Context_Id : constant Context_Id := Context_Low_Bound + 1; --------------------------------------------- -- Types for Container and Container Table -- --------------------------------------------- Container_Low_Bound : constant := 0; Container_High_Bound : constant := 100; type Container_Id is range Container_Low_Bound .. Container_High_Bound; -- Type used to identify entries in ASIS Container table Nil_Container_Id : constant Container_Id := Container_Low_Bound; First_Container_Id : constant Container_Id := Container_Low_Bound + 1; ----------------------------------------------- -- Types for Compilation_Unit and Unit Table -- ----------------------------------------------- Unit_Low_Bound : constant := 0; Unit_High_Bound : constant := 100_000; type Unit_Id is range Unit_Low_Bound .. Unit_High_Bound; -- Type used to identify entries in the ASIS Unit table Nil_Unit : constant Unit_Id := Unit_Low_Bound; No_Unit_Id : Unit_Id renames Nil_Unit; First_Unit_Id : constant Unit_Id := Unit_Low_Bound + 1; Standard_Id : constant Unit_Id := First_Unit_Id; -- The entry in the Unit table corresponding to the package Standard -- Standard goes first in any Unit table Config_Comp_Id : constant Unit_Id := Standard_Id + 1; -- The entry in the Unit table corresponding to the artificial -- A_Configuration_Compilation unit. We may have at most one such unit. -- If there is no configuration pragmas in the Context, there is no harm -- to allocate such a unit, because the only way for an ASIS client to get -- it is to get the enclosing unit for a configuration pragma. type Unit_Id_List is array (Natural range <>) of Unit_Id; Nil_Unit_Id_List : constant Unit_Id_List (1 .. 0) := (others => Nil_Unit); -------------------------- -- Types for Tree Table -- -------------------------- Tree_Low_Bound : constant := 0; Tree_High_Bound : constant := 100_000; type Tree_Id is range Tree_Low_Bound .. Tree_High_Bound; -- Type used to identify entries in ASIS Tree table Nil_Tree : constant Tree_Id := Tree_Low_Bound; No_Tree_Name : Tree_Id renames Nil_Tree; -- ??? First_Tree_Id : constant Tree_Id := Tree_Low_Bound + 1; ----------------------------------------------- -- Types for Search Directories Paths Tables -- ----------------------------------------------- No_Dir : constant := 0; First_Dir_Id : constant := 1; Last_Dir_Id : constant := 1_000; type Dir_Id is range No_Dir .. Last_Dir_Id; type Search_Dir_Kinds is ( Source, -- for source search path Object, -- for object search path Tree); -- for tree search path -- this type may be further expanded -------------------------------------------- -- Types for Internal Element Structure -- -------------------------------------------- type Special_Cases is ( -- this enumeration type is needed to distinguish some special -- cases in Element constructing and handling Not_A_Special_Case, A_Dummy_Block_Statement, -- the result of an obsolescent function -- Declarations.Body_Block_Statement Predefined_Operation, -- indicates the predefined operation for a user-defined type -- (or component thereof???). Note, that such an operation is -- defined not in the Standard package. Explicit_From_Standard, -- indicates the explicit Element obtained from the package -- Standard. "Explicit" means here any construct which is -- contained in the "source" text of Standard included in RM95 -- plus explicit constants substituting "implementation-defined" -- italic strings in this "source" Numeric_Error_Renaming, -- Indicates the artificial ASIS Element created to represent the -- obsolete renaming of Numeric_Error in the package Standard -- (see B712-005) Implicit_From_Standard, -- indicates the implicit Element obtained from the package -- Standard, that is, implicitly declared predefined operations -- and their components, and root and universal numeric type -- definitions and declarations Stand_Char_Literal, -- indicates the defining character literal declared in the -- definition of the predefined type Standard.Character -- or Standard.Wide_Character. An ASIS Element representing such -- a literal has no corresponding node in the tree, and it is -- based on the N_Defining_Identifier node for the corresponding -- type Expanded_Package_Instantiation, -- indicates A_Package_Declaration element which represents the -- package declaration which is the result of an instantiation -- of a generic package Expanded_Subprogram_Instantiation, -- indicates A_Procedure_Declaration or A_Function_Declaration -- element which represents the package declaration which is the -- result of an instantiation of a generic package Configuration_File_Pragma, -- Indicates a configuration pragma belonging not to the source of some -- Ada compilation unit, but to the configuration file (an components -- thereof) Rewritten_Named_Number, -- Indicates An_Identifier Element representing a named number in the -- situation when the corresponding tree structure is rewritten into -- N_Integer/Real_Literal node and no original tree structure is -- available (see BB10-002) Is_From_Gen_Association, -- See D722-012. -- The problem here is that in case of a formal object, the front-end -- creates the renaming declaration as a means to pass an actual -- parameter, and the parameter itself (the corresponding tree node) -- is used as a part of this renaming declaration. So we have a problem -- with Enclosing_Element. The Parent pointer from this actual points -- to the renaming declaration structure. In case if we are not in the -- expanded code, we may compare levels of instantiation and it helps, -- but in general case it is too complicated. So the solution is to -- mark the corresponding node if it comes from the generic association -- (and we can gen into this node only by means of a structural query!) -- and to use this mark in the Enclosing_Element processing. Is_From_Imp_Neq_Declaration, -- Indicates if the given element is an implicit declaration of the -- "/=" operation corresponding to the explicit redefinition of "=" or -- a subcomponent thereof -- Implicit_Inherited_Subprogram -- indicates the declaration of an implicit inherited user-defined -- subprogram or a component thereof. -- may be continued... Dummy_Base_Attribute_Designator, Dummy_Class_Attribute_Designator, Dummy_Base_Attribute_Prefix, Dummy_Class_Attribute_Prefix -- These four values are used to mark componants of the artificial -- 'Base and 'Class attribute reference that ASIS has to simulate when -- processing references to a formal type in the instantiation in case -- when a formal type is an unconstrained type, and the actual type is a -- 'Class attribute, or when an actual is a 'Base attribute and the -- front-end creates too much of artificial data structures in the tree. -- may be continued... ); type Normalization_Cases is ( -- This enumeration type represents the different possible states of -- An_Association Elements in respect to normalization of associations Is_Not_Normalized, Is_Normalized, -- normalized association created for an actual parameter which itself -- is presented at the place of the call/instantiation Is_Normalized_Defaulted, -- normalized association created for an actual parameter which itself -- is NOT presented at the place of the call/instantiation, so the -- default value should be used Is_Normalized_Defaulted_For_Box); -- normalized association created for an actual parameter which itself -- is NOT presented at the place of the instantiation and the definition -- of the formal parameter includes box as the default value, so the -- actual parameter should be found at the place of the instantiation subtype Expanded_Spec is Special_Cases range Expanded_Package_Instantiation .. Expanded_Subprogram_Instantiation; subtype Normalized_Association is Normalization_Cases range Is_Normalized .. Is_Normalized_Defaulted_For_Box; subtype Defaulted_Association is Normalization_Cases range Is_Normalized_Defaulted .. Is_Normalized_Defaulted_For_Box; subtype Predefined is Special_Cases range Predefined_Operation .. Stand_Char_Literal; -- COMMENTS -- -- *1* Handling the Parenthesized Expressions and -- One_Pair_Of_Parentheses_Away and Two_Pairs_Of_Parentheses_Away -- Special Cases. -- -- An Asis Element of A_Parenthesized_Expression could be built -- on the base of any tree node which could be used for building the -- elements of all other An_Expresion subordinate kinds. -- A_Parenthesized_Expression kind is determined by comparing (during -- the automatic Internal_Element_Kinds determination only!!!) the -- Paren_Count field of the node with zero - see Sinfo.ads, the -- documentation item for "4.4 (Primary)" RM subsection, and -- Atree.ads the documentation item related to the Paren_Count field. -- -- When a subexpression is to be selected from the element of -- A_Parenthesized_Expression kind by the -- Asis_Definition.Expression_Parenthesized function, the result will -- be built on the base of just the same node as the argument having, -- just the same value of the Paren_Count field. If the argument has -- more then one pair of parentheses, the result will also be of -- A_Parenthesized_Expression kind, and the Special_Cases values -- One_Pair_Of_Parentheses_Away and Two_Pairs_Of_Parentheses_Away -- are intended to be used to count the pairs of parentheses remained -- in the result element. All the corresponding element kind -- determination and element construction should be performed in -- "by-hand" mode, except the case when the argument parenthesized -- expression has only one pair of parentheses. -- -- GNAT cannot distinguish more than three levels of the enclosing -- pairs of parentheses for a non-parenthesized enclosed expression. -- (Paren_Count = 3 stands for any number of the enclosing parentheses -- equal or greater than 3.) So ASIS-for-GNAT implementation cannot -- do more than GNAT itself (of course, we could do some search in the -- source buffer, but we prefer to agree with GNAT team that even -- Paren_Count = 3 already is a pathological case :). -- -- See also Asis_Definition.Expression_Parenthesized (body) and -- A4G.Mapping.Node_To_Element (body) -- -- *2* Root/Universal types definitions - we do not need any special -- value for representing elements of Root_Type_Kinds, because for -- each value there may be only one Element of the corresponding kind -- in a given opened Context. -- ------------------------- -- Nil String constants-- ------------------------- Nil_Asis_String : constant String := ""; Nil_Asis_Wide_String : constant Wide_String := ""; ------------------------------------------------- -- Constants for the Diagnosis string buffer -- ------------------------------------------------- ASIS_Line_Terminator : constant String := (1 => LF); -- what about DOS-like end-of-line? Diagnosis_String_Length : constant Positive := 76 + ASIS_Line_Terminator'Length; -- We are trying to set ASIS_Line_Terminator in the Diagnosis string to -- keep text strings at most 76 characters long Max_Diagnosis_Length : constant Positive := 32 * Diagnosis_String_Length; -- The length of the buffer in which the Diagnosis string is formed, -- now it is at most 32 lines 76 character each. Should be enough for -- any practically meaningful diagnosis Asis_Wide_Line_Terminator : constant Wide_String := (1 => To_Wide_Character (LF)); -- -- the physical line terminator, is used in the Diagnosis string -- to separate the parts of the diagnosis message -- See also documentation of the Skip_Line_Terminators procedure -- in the (GNAT.)sinput.adb ASIS_Line_Terminator_Len : constant Positive := ASIS_Line_Terminator'Length; Incorrect_Setting : constant String := "Attempt to set Not_An_Error " & "status with non-nil diagnosis string"; Incorrect_Setting_Len : constant Positive := Incorrect_Setting'Length; ------------------- -- Miscellaneous -- ------------------- Internal_Implementation_Error : exception; -- Means exactly this. Is supposed to be raised in control statement -- paths which should never be reached. We need this exception mostly -- because some parts of old ASIS code (developed at the research stage of -- the ASIS project) sometimes are not structured properly. function Parameter_String_To_List (Par_String : String) return Argument_List_Access; -- Take a string that is a converted to the String type Parameters string -- of the ASIS query Initialize, Associate or Finalize (??? Should we -- process the original Wide_String Parameters string without converting -- it to String?) and parse it into an Argument_List. -- -- This function is similar to GNAT.OS_Int.Argument_String_To_List, but -- it does not treat '\' as a backquoting character. private type ASIS_OS_Time is new Long_Integer range 0 .. Long_Integer'Last; ASIS_Clock : ASIS_OS_Time := 1; -- This is the ASIS logical "clock" used to ret ASIS logical time. Nil_ASIS_OS_Time : constant ASIS_OS_Time := 0; Last_ASIS_OS_Time : constant ASIS_OS_Time := ASIS_OS_Time'Last; end A4G.A_Types; asis-2010.orig/asis/a4g-asis_tables.adb0000644000175000017500000001571311574704441017563 0ustar lbrentalbrenta------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- A 4 G . A S I S _ T A B L E S -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- -- -- -- ASIS-for-GNAT 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 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 51 Franklin -- -- Street, Fifth Floor, Boston, MA 02110-1301, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by AdaCore -- -- (http://www.adacore.com). -- -- -- ------------------------------------------------------------------------------ with Asis.Elements; use Asis.Elements; with Atree; use Atree; with Sinput; use Sinput; with Einfo; use Einfo; with Nlists; use Nlists; package body A4G.Asis_Tables is --------------------- -- Add_New_Element -- --------------------- procedure Add_New_Element (Element : Asis.Element) is Found : Boolean := False; begin for J in 1 .. Asis_Element_Table.Last loop if Is_Equal (Element, Asis_Element_Table.Table (J)) then Found := True; exit; end if; end loop; if not Found then Asis_Element_Table.Append (Element); end if; end Add_New_Element; ----------------------- -- Create_Node_Trace -- ----------------------- procedure Create_Node_Trace (N : Node_Id) is Next_Node : Node_Id; Next_Sloc : Source_Ptr; Next_Node_Rec : Node_Trace_Rec; begin Node_Trace.Init; Next_Node := N; while Present (Next_Node) loop Next_Sloc := Sloc (Next_Node); Next_Node_Rec.Kind := Nkind (Next_Node); Next_Node_Rec.Node_Line := Get_Physical_Line_Number (Next_Sloc); Next_Node_Rec.Node_Col := Get_Column_Number (Next_Sloc); Node_Trace.Append (Next_Node_Rec); Next_Node := Enclosing_Scope (Next_Node); end loop; end Create_Node_Trace; --------------------- -- Enclosing_Scope -- --------------------- function Enclosing_Scope (N : Node_Id) return Node_Id is Result : Node_Id := N; Entity_Node : Entity_Id := Empty; begin if Nkind (Result) = N_Package_Declaration then Entity_Node := Defining_Unit_Name (Sinfo.Specification (Result)); elsif Nkind (Result) = N_Package_Body then Entity_Node := Defining_Unit_Name (Result); end if; if Nkind (Entity_Node) = N_Defining_Program_Unit_Name then Entity_Node := Sinfo.Defining_Identifier (Entity_Node); end if; if Present (Entity_Node) and then Is_Generic_Instance (Entity_Node) then -- going to the corresponding instantiation if Nkind (Parent (Result)) = N_Compilation_Unit then -- We are at the top/ and we do not need a library-level -- instantiation - it is always unique in the compilation -- unit Result := Empty; else -- "local" instantiation, therefore - one or two steps down the -- declaration list to get in the instantiation node: Result := Next_Non_Pragma (Result); if Nkind (Result) = N_Package_Body then -- This is an expanded generic body Result := Next_Non_Pragma (Result); end if; end if; else -- One step up to the enclosing scope Result := Parent (Result); while not (Nkind (Result) = N_Package_Specification or else Nkind (Result) = N_Package_Body or else Nkind (Result) = N_Compilation_Unit or else Nkind (Result) = N_Subprogram_Body or else Nkind (Result) = N_Block_Statement) loop Result := Parent (Result); end loop; if Nkind (Result) = N_Package_Specification then Result := Parent (Result); elsif Nkind (Result) = N_Compilation_Unit then Result := Empty; end if; end if; return Result; end Enclosing_Scope; -------------- -- Is_Equal -- -------------- function Is_Equal (N : Node_Id; Trace_Rec : Node_Trace_Rec) return Boolean is begin return Nkind (N) = Trace_Rec.Kind and then Get_Physical_Line_Number (Sloc (N)) = Trace_Rec.Node_Line and then Get_Column_Number (Sloc (N)) = Trace_Rec.Node_Col; end Is_Equal; end A4G.Asis_Tables; asis-2010.orig/asis/a4g-asis_tables.ads0000644000175000017500000001520211574704441017575 0ustar lbrentalbrenta------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- A 4 G . A S I S _ T A B L E S -- -- -- -- S p e c -- -- -- -- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- -- -- -- ASIS-for-GNAT 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 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 51 Franklin -- -- Street, Fifth Floor, Boston, MA 02110-1301, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by AdaCore -- -- (http://www.adacore.com). -- -- -- ------------------------------------------------------------------------------ -- This package contains definitions of tables and related auxilary resources -- needed in more then one ASIS implementation package with Asis; with Sinfo; use Sinfo; with Table; with Types; use Types; package A4G.Asis_Tables is package Internal_Asis_Element_Table is new Table.Table ( Table_Component_Type => Asis.Element, Table_Index_Type => Asis.ASIS_Natural, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 100, Table_Name => "Internal Element_List"); -- This table contains ASIS Elements. It is supposed to be used only for -- creating the result Element lists in ASIS structural queries. Note that -- many ASIS queries use instantiations of Traverse_Elements to create -- result lists, so we have to make sure that ASIS structural queries -- used in the implementation of Traverse_Element use another table to -- create result lists package Asis_Element_Table is new Table.Table ( Table_Component_Type => Asis.Element, Table_Index_Type => Asis.ASIS_Natural, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 100, Table_Name => "Element_List"); -- This table contains ASIS Elements. It is supposed to be used for any -- purpose except creating the result Element lists in ASIS structural -- queries. procedure Add_New_Element (Element : Asis.Element); -- Differs from Asis_Element_Table.Append that checks if the argument -- Element already is in the table, and appends the new element only if the -- check fails. Note that the implementation is based on a simple array -- search, so it can result in performance penalties if there are too -- many elements in the table. type Node_Trace_Rec is record Kind : Node_Kind; Node_Line : Physical_Line_Number; Node_Col : Column_Number; end record; -- This record represents a Node in the node trace used to find the same -- construct in another tree package Node_Trace is new Table.Table ( Table_Component_Type => Node_Trace_Rec, Table_Index_Type => Int, Table_Low_Bound => 0, Table_Initial => 10, Table_Increment => 100, Table_Name => "Node_Trace"); -- This table is used to create the node trace needed to compare elements -- from nested instances function Is_Equal (N : Node_Id; Trace_Rec : Node_Trace_Rec) return Boolean; -- Checks if N (in the currently accessed tree corresponds to the node -- for which Trace_Rec was created procedure Create_Node_Trace (N : Node_Id); -- Creates the Node trace which is supposed to be used to find the node -- representing the same construct in another tree. The trace is also used -- to check is two nodes from different trees, each belonging to expanded -- generics both denote the same thing. This trace contains the record -- about N itself and all the enclosing constructs such as package bodies -- and package specs. For the package which is an expanded generic, the -- next element in the trace is the corresponding instantiation node. function Enclosing_Scope (N : Node_Id) return Node_Id; -- Given a node somewhere from expanded generic, returnes its enclosing -- "scope" which can be N_Package_Declaration, N_Package_Body or -- N_Generic_Declaration node. The idea is to use this function to create -- the node trace either for storing it in the Note Trace table or for -- creating the trace on the fly to compare it with the stored trace. end A4G.Asis_Tables; asis-2010.orig/asis/a4g-contt-dp.adb0000644000175000017500000014351511574704441017024 0ustar lbrentalbrenta------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- A 4 G . C O N T T . D P -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- -- -- -- ASIS-for-GNAT 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 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 51 Franklin -- -- Street, Fifth Floor, Boston, MA 02110-1301, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by AdaCore -- -- (http://www.adacore.com). -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with Asis.Set_Get; use Asis.Set_Get; with A4G.Contt.UT; use A4G.Contt.UT; with A4G.Get_Unit; use A4G.Get_Unit; with Atree; use Atree; with Nlists; use Nlists; with Namet; use Namet; with Sinfo; use Sinfo; with Lib; use Lib; package body A4G.Contt.Dp is ----------------------- -- Local Subprograms -- ----------------------- function Get_First_Stub (Body_Node : Node_Id) return Node_Id; function Get_Next_Stub (Stub_Node : Node_Id) return Node_Id; -- these two functions implement the iterator through the body stubs -- contained in the given compilation unit. The iterator should -- be started from calling Get_First_Stub for the node pointed to -- the body (that is, for the node of ..._Body kind). The Empty node -- is returned if there is no first/next body stub node procedure Set_All_Unit_Dependencies (U : Unit_Id); -- Computes the full lists of supporters and dependents of U in the current -- Context from the list of direct supporters of U and sets these lists as -- values of Supporters and Dependents lists in the Unit Table procedure Add_Unit_Supporters (U : Unit_Id; L : in out Elist_Id); -- Add all the supporters of U, excluding U itself to L. This procedure -- traverses all the transitive semantic dependencies. procedure Fix_Direct_Supporters (Unit : Unit_Id); -- This procedure adds missed direct dependencies to the unit. It is -- supposed that before the call the list of direct supporters contains -- only units extracted from the unit context clause. So, if U is a body, -- this procedure adds the spec to the list of direct supporters, if it is -- a subunit - the parent body is added, if it is a child unit - the -- parent spec is added etc. The procedure adds these supporters in a -- transitive manner - that is, in case of a subunit, it adds the parent -- body, its spec (if any), its parent (if any) etc. -- This function supposes that Current Context is correctly set before -- the call. function In_List (U : Unit_Id; L : Unit_Id_List; Up_To : Natural) return Boolean; -- Checks if U is a member of the first Up_To components of L. (If -- Up_To is 0, False is returned procedure CU_To_Unit_Id_List (CU_List : Compilation_Unit_List; Result_Unit_Id_List : in out Unit_Id_List; Result_List_Len : out Natural); -- Converts the ASIS Compilation Unit list into the list of Unit Ids and -- places this list into Result_Unit_Id_List. (Probably, we should replace -- this routine with a function...) -- For each ASIS Compilation Unit from CU_List the Result_Unit_Id_List -- contains exactly one Id for the corresponding unit. Result_List_Len is -- set to represent the index of the last Unit Id in Result_List_Len (0 -- in case if Result_List_Len is empty). This routine expects that -- Result_Unit_Id_List'Length >= CU_List'Length -------------------------------------- -- Dynamic Unit_Id list abstraction -- -------------------------------------- -- All the subprograms implementing Unit_Id list abstraction do not -- reset Context -- Is this package body the right place for defining this abstraction? -- May be, we should move it into A4G.A_Types??? type Unit_Id_List_Access is access Unit_Id_List; Tmp_Unit_Id_List_Access : Unit_Id_List_Access; procedure Free is new Ada.Unchecked_Deallocation (Unit_Id_List, Unit_Id_List_Access); function In_Unit_Id_List (U : Unit_Id; L : Unit_Id_List_Access) return Boolean; -- Checks if U is a member of L. procedure Append_Unit_To_List (U : Unit_Id; L : in out Unit_Id_List_Access); -- (Unconditionally) appends U to L. procedure Add_To_Unit_Id_List (U : Unit_Id; L : in out Unit_Id_List_Access); -- If not In_Unit_Id_List (U, L), U is appended to L (if L is null, -- new Unit_Id_List value is created) procedure Reorder_Sem_Dependencies (Units : Unit_Id_List_Access); -- This procedure takes the unit list with is supposed to be the result of -- one of the Set_All_ functions above (that is, its parameter -- is not supposed to be null and it contains only existing units). It -- reorders it in the way required by -- Asis.Compilation_Units.Relations.Semantic_Dependence_Order - that is, -- with no forward semantic dependencies. ------------------- -- Add_To_Parent -- ------------------- procedure Add_To_Parent (C : Context_Id; U : Unit_Id) is Parent_Id : Unit_Id; Unit_Kind : constant Unit_Kinds := Kind (C, U); begin if U = Standard_Id then return; end if; Reset_Context (C); -- ??? Get_Name_String (U, Norm_Ada_Name); if Not_Root then Form_Parent_Name; if Unit_Kind in A_Subunit then A_Name_Buffer (A_Name_Len) := 'b'; end if; Parent_Id := Name_Find (C); -- Parent_Id cannot be Nil_Unit here Append_Elmt (Unit => U, To => Unit_Table.Table (Parent_Id).Subunits_Or_Childs); else Append_Elmt (Unit => U, To => Unit_Table.Table (Standard_Id).Subunits_Or_Childs); end if; end Add_To_Parent; ------------------------- -- Add_Unit_Supporters -- ------------------------- procedure Add_Unit_Supporters (U : Unit_Id; L : in out Elist_Id) is Supporters : Elist_Id renames Unit_Table.Table (U).Supporters; Direct_Supporters : Elist_Id renames Unit_Table.Table (U).Direct_Supporters; Next_Support_Elmt : Elmt_Id; Next_Support_Unit : Unit_Id; begin if Is_Empty_Elmt_List (Direct_Supporters) then -- end of the recursion return; elsif not Is_Empty_Elmt_List (Supporters) then -- no need to traverse indirect dependencies Next_Support_Elmt := First_Elmt (Supporters); while Present (Next_Support_Elmt) loop Next_Support_Unit := Unit (Next_Support_Elmt); Add_To_Elmt_List (Unit => Next_Support_Unit, List => L); Next_Support_Elmt := Next_Elmt (Next_Support_Elmt); end loop; else -- And here we have to traverse the recursive dependencies: Next_Support_Elmt := First_Elmt (Direct_Supporters); while Present (Next_Support_Elmt) loop Next_Support_Unit := Unit (Next_Support_Elmt); -- The old code currently commented out caused a huge delay -- when opening one tree context (8326-002). We will keep it -- till the new code is tested for queries from -- Asis.Compilation_Units.Relations -- ???Old code start -- Here we can not be sure, that if Next_Support_Unit already -- is in the list, all its supporters also are in the list -- Add_To_Elmt_List -- (Unit => Next_Support_Unit, -- List => L); -- Add_Unit_Supporters (Next_Support_Unit, L); -- ???Old code end -- ???New code start if not In_Elmt_List (Next_Support_Unit, L) then Append_Elmt (Unit => Next_Support_Unit, To => L); Add_Unit_Supporters (Next_Support_Unit, L); end if; -- ???New code end Next_Support_Elmt := Next_Elmt (Next_Support_Elmt); end loop; end if; end Add_Unit_Supporters; ------------------------- -- Append_Subunit_Name -- ------------------------- procedure Append_Subunit_Name (Def_S_Name : Node_Id) is begin -- Here we need unqualified name, because the name -- which comes from the stub is qualified by parent body -- name Get_Unqualified_Decoded_Name_String (Chars (Def_S_Name)); A_Name_Buffer (A_Name_Len - 1) := '.'; A_Name_Buffer (A_Name_Len .. A_Name_Len + Name_Len - 1) := Name_Buffer (1 .. Name_Len); A_Name_Len := A_Name_Len + Name_Len + 1; A_Name_Buffer (A_Name_Len - 1) := '%'; A_Name_Buffer (A_Name_Len) := 'b'; end Append_Subunit_Name; ------------------------ -- CU_To_Unit_Id_List -- ------------------------ procedure CU_To_Unit_Id_List (CU_List : Compilation_Unit_List; Result_Unit_Id_List : in out Unit_Id_List; Result_List_Len : out Natural) is Next_Unit : Unit_Id; begin Result_List_Len := 0; for I in CU_List'Range loop Next_Unit := Get_Unit_Id (CU_List (I)); if not In_List (Next_Unit, Result_Unit_Id_List, Result_List_Len) then Result_List_Len := Result_List_Len + 1; Result_Unit_Id_List (Result_List_Len) := Next_Unit; end if; end loop; end CU_To_Unit_Id_List; --------------------------- -- Fix_Direct_Supporters -- --------------------------- procedure Fix_Direct_Supporters (Unit : Unit_Id) is function Next_Supporter (U : Unit_Id) return Unit_Id; -- Computes the next supporter to be added (from subunit to the parent -- body, from body to the spec, from child to the parent etc). Ends up -- with Standard and then with Nil_Unit as its parent Next_Supporter_Id : Unit_Id; function Next_Supporter (U : Unit_Id) return Unit_Id is C : constant Context_Id := Current_Context; Arg_Unit_Kind : constant Unit_Kinds := Kind (C, U); Result_Id : Unit_Id := Nil_Unit; begin case Arg_Unit_Kind is when A_Procedure | A_Function | A_Package | A_Generic_Procedure | A_Generic_Function | A_Generic_Package | A_Procedure_Instance | A_Function_Instance | A_Package_Instance | A_Procedure_Renaming | A_Function_Renaming | A_Package_Renaming | A_Generic_Procedure_Renaming | A_Generic_Function_Renaming | A_Generic_Package_Renaming => Result_Id := Get_Parent_Unit (C, U); when A_Procedure_Body | A_Function_Body => if Class (C, U) = A_Public_Declaration_And_Body then Result_Id := Get_Parent_Unit (C, U); else Result_Id := Get_Declaration (C, U); end if; when A_Package_Body => Result_Id := Get_Declaration (C, U); when A_Procedure_Body_Subunit | A_Function_Body_Subunit | A_Package_Body_Subunit | A_Task_Body_Subunit | A_Protected_Body_Subunit => Result_Id := Get_Subunit_Parent_Body (C, U); when others => pragma Assert (False); null; end case; return Result_Id; end Next_Supporter; begin Next_Supporter_Id := Next_Supporter (Unit); while Present (Next_Supporter_Id) loop Append_Elmt (Unit => Next_Supporter_Id, To => Unit_Table.Table (Unit).Direct_Supporters); Next_Supporter_Id := Next_Supporter (Next_Supporter_Id); end loop; end Fix_Direct_Supporters; -------------------- -- Get_First_Stub -- -------------------- function Get_First_Stub (Body_Node : Node_Id) return Node_Id is Decls : List_Id; Decl : Node_Id; begin Decls := Declarations (Body_Node); if No (Decls) then return Empty; else Decl := Nlists.First (Decls); while Present (Decl) loop if Nkind (Decl) in N_Body_Stub then return Decl; end if; Decl := Next (Decl); end loop; return Empty; end if; end Get_First_Stub; ------------------- -- Get_Next_Stub -- ------------------- function Get_Next_Stub (Stub_Node : Node_Id) return Node_Id is Next_Decl : Node_Id; begin Next_Decl := Next (Stub_Node); while Present (Next_Decl) loop if Nkind (Next_Decl) in N_Body_Stub then return Next_Decl; end if; Next_Decl := Next (Next_Decl); end loop; return Empty; end Get_Next_Stub; ------------- -- In_List -- ------------- function In_List (U : Unit_Id; L : Unit_Id_List; Up_To : Natural) return Boolean is Len : constant Natural := Natural'Min (Up_To, L'Length); Result : Boolean := False; begin for I in 1 .. Len loop if L (I) = U then Result := True; exit; end if; end loop; return Result; end In_List; ------------------ -- Process_Stub -- ------------------ procedure Process_Stub (C : Context_Id; U : Unit_Id; Stub : Node_Id) is Def_S_Name : Node_Id; Subunit_Id : Unit_Id; begin -- We should save (and then restore) the content of A_Name_Buffer in -- case when more then one stub is to be processed. (A_Name_Buffer -- contains the Ada name of the parent body) NB_Save; if Nkind (Stub) = N_Subprogram_Body_Stub then Def_S_Name := Defining_Unit_Name (Specification (Stub)); else Def_S_Name := Defining_Identifier (Stub); end if; Append_Subunit_Name (Def_S_Name); Subunit_Id := Name_Find (C); if No (Subunit_Id) then Subunit_Id := Allocate_Nonexistent_Unit_Entry (C); Append_Elmt (Unit => Subunit_Id, To => Unit_Table.Table (U).Subunits_Or_Childs); end if; NB_Restore; end Process_Stub; ------------------------------ -- Reorder_Sem_Dependencies -- ------------------------------ procedure Reorder_Sem_Dependencies (Units : Unit_Id_List_Access) is More_Inversion : Boolean := True; Tmp_Unit : Unit_Id; begin if Units'Length = 0 then return; end if; -- The idea is simple: for all the units in Units list we have the -- lists of all the unit's supporters already computed. If we order -- units so that the lengths of supporter lists will increase we will -- get the order in which there will be no forward semantic -- dependencies: if unit A depends on unit B, then A also depends on -- all the supporters of B, so it has the list of supporters longer -- then B has while More_Inversion loop More_Inversion := False; for J in Units'First .. Units'Last - 1 loop if List_Length (Unit_Table.Table (Units (J)).Supporters) > List_Length (Unit_Table.Table (Units (J + 1)).Supporters) then Tmp_Unit := Units (J + 1); Units (J + 1) := Units (J); Units (J) := Tmp_Unit; More_Inversion := True; end if; end loop; end loop; end Reorder_Sem_Dependencies; -------------------------- -- Set_All_Dependencies -- -------------------------- procedure Set_All_Dependencies (Use_First_New_Unit : Boolean := False) is Starting_Unit : Unit_Id; begin if Use_First_New_Unit then Starting_Unit := First_New_Unit; if No (Starting_Unit) then -- This may happen, when, for the incremental Context, we -- process the tree which is the main tree for some body unit, -- and this body unit has been already included in the Context -- (See Lib (spec, (h)) return; end if; else Starting_Unit := Config_Comp_Id + 1; -- Config_Comp_Id corresponds to last predefined unit set in the -- unit table end if; for U in Starting_Unit .. Last_Unit loop Set_All_Unit_Dependencies (U); end loop; end Set_All_Dependencies; ------------------------------- -- Set_All_Unit_Dependencies -- ------------------------------- procedure Set_All_Unit_Dependencies (U : Unit_Id) is Supporters : Elist_Id renames Unit_Table.Table (U).Supporters; Direct_Supporters : Elist_Id renames Unit_Table.Table (U).Direct_Supporters; Next_Support_Elmt : Elmt_Id; Next_Support_Unit : Unit_Id; begin Fix_Direct_Supporters (U); -- Setting all the unit supporters Next_Support_Elmt := First_Elmt (Direct_Supporters); while Present (Next_Support_Elmt) loop Next_Support_Unit := Unit (Next_Support_Elmt); -- If Next_Support_Unit already is in Supporters list, -- all its supporters also are already included in Supporters. if not In_Elmt_List (Next_Support_Unit, Supporters) then Append_Elmt (Unit => Next_Support_Unit, To => Supporters); Add_Unit_Supporters (Next_Support_Unit, Supporters); end if; Next_Support_Elmt := Next_Elmt (Next_Support_Elmt); end loop; -- And now - adding U as depended unit to the list of Dependents for -- all its supporters Next_Support_Elmt := First_Elmt (Supporters); while Present (Next_Support_Elmt) loop Next_Support_Unit := Unit (Next_Support_Elmt); Append_Elmt (Unit => U, To => Unit_Table.Table (Next_Support_Unit).Dependents); Next_Support_Elmt := Next_Elmt (Next_Support_Elmt); end loop; end Set_All_Unit_Dependencies; --------------------------- -- Set_Direct_Dependents -- --------------------------- procedure Set_Direct_Dependents (U : Unit_Id) is Next_Support_Elmt : Elmt_Id; Next_Support_Unit : Unit_Id; begin Next_Support_Elmt := First_Elmt (Unit_Table.Table (U).Direct_Supporters); while Present (Next_Support_Elmt) loop Next_Support_Unit := Unit (Next_Support_Elmt); Append_Elmt (Unit => U, To => Unit_Table.Table (Next_Support_Unit).Direct_Dependents); Next_Support_Elmt := Next_Elmt (Next_Support_Elmt); end loop; end Set_Direct_Dependents; ----------------------- -- Set_All_Ancestors -- ----------------------- procedure Set_All_Ancestors (Compilation_Units : Asis.Compilation_Unit_List; Result : in out Compilation_Unit_List_Access) is Cont : constant Context_Id := Current_Context; Arg_List : Unit_Id_List (1 .. Compilation_Units'Length) := (others => Nil_Unit); Arg_List_Len : Natural := 0; Result_List : Unit_Id_List_Access := null; Next_Ancestor_Unit : Unit_Id; begin -- For the current version, we are supposing, that we have only one -- Context opened at a time CU_To_Unit_Id_List (Compilation_Units, Arg_List, Arg_List_Len); -- Standard is an ancestor of any unit, and if we are here, -- Compilation_Units can not be Nil_Compilation_Unit_List. So we set -- it as the first element of the result list: Append_Unit_To_List (Standard_Id, Result_List); for I in 1 .. Arg_List_Len loop Next_Ancestor_Unit := Arg_List (I); if Next_Ancestor_Unit /= Standard_Id then while Kind (Cont, Next_Ancestor_Unit) in A_Subunit loop Next_Ancestor_Unit := Get_Subunit_Parent_Body (Cont, Next_Ancestor_Unit); end loop; if Class (Cont, Next_Ancestor_Unit) = A_Public_Body or else Class (Cont, Next_Ancestor_Unit) = A_Private_Body then Next_Ancestor_Unit := Get_Declaration (Cont, Next_Ancestor_Unit); end if; while Next_Ancestor_Unit /= Standard_Id loop if not In_Unit_Id_List (Next_Ancestor_Unit, Result_List) then Append_Unit_To_List (Next_Ancestor_Unit, Result_List); Next_Ancestor_Unit := Get_Parent_Unit (Cont, Next_Ancestor_Unit); else exit; end if; end loop; end if; end loop; -- And here we have to order Result_List to eliminate forward -- semantic dependencies -- Result_List can not be null - it contains at least Standard_Id Reorder_Sem_Dependencies (Result_List); Result := new Compilation_Unit_List' (Get_Comp_Unit_List (Result_List.all, Cont)); Free (Result_List); end Set_All_Ancestors; ------------------------ -- Set_All_Dependents -- ------------------------ procedure Set_All_Dependents (Compilation_Units : Asis.Compilation_Unit_List; Dependent_Units : Asis.Compilation_Unit_List; Result : in out Compilation_Unit_List_Access) is Cont : constant Context_Id := Current_Context; Arg_List : Unit_Id_List (1 .. Compilation_Units'Length) := (others => Nil_Unit); Arg_List_Len : Natural := 0; Dep_List : Unit_Id_List (1 .. Dependent_Units'Length) := (others => Nil_Unit); Dep_List_Len : Natural := 0; Result_List : Unit_Id_List_Access := null; Next_Dependent_Elmt : Elmt_Id; Next_Dependent_Unit : Unit_Id; begin -- For the current version, we are supposing, that we have only one -- Context opened at a time CU_To_Unit_Id_List (Compilation_Units, Arg_List, Arg_List_Len); CU_To_Unit_Id_List (Dependent_Units, Dep_List, Dep_List_Len); -- Now, collecting all the dependents for Compilation_Units for I in 1 .. Arg_List_Len loop Next_Dependent_Elmt := First_Elmt (Unit_Table.Table (Arg_List (I)).Dependents); while Present (Next_Dependent_Elmt) loop Next_Dependent_Unit := Unit (Next_Dependent_Elmt); if Dep_List_Len = 0 or else In_List (Next_Dependent_Unit, Dep_List, Dep_List_Len) then Add_To_Unit_Id_List (Next_Dependent_Unit, Result_List); end if; Next_Dependent_Elmt := Next_Elmt (Next_Dependent_Elmt); end loop; end loop; -- And here we have to order Result_List to eliminate forward -- semantic dependencies if Result_List /= null then Reorder_Sem_Dependencies (Result_List); Result := new Compilation_Unit_List' (Get_Comp_Unit_List (Result_List.all, Cont)); Free (Result_List); else Result := new Compilation_Unit_List (1 .. 0); end if; end Set_All_Dependents; ------------------------- -- Set_All_Descendants -- ------------------------- procedure Set_All_Descendants (Compilation_Units : Asis.Compilation_Unit_List; Result : in out Compilation_Unit_List_Access) is Cont : constant Context_Id := Current_Context; Arg_List : Unit_Id_List (1 .. Compilation_Units'Length) := (others => Nil_Unit); Arg_List_Len : Natural := 0; Result_List : Unit_Id_List_Access := null; Next_Descendant_Elmt : Elmt_Id; Next_Unit : Unit_Id; procedure Add_All_Descendants (Desc_Unit : Unit_Id; Result_List : in out Unit_Id_List_Access); -- If Desc_Unit is not in Result_List, this procedure adds it and -- (recursively) all its descendants which are not in Result_List to -- the list. procedure Add_All_Descendants (Desc_Unit : Unit_Id; Result_List : in out Unit_Id_List_Access) is Child_Elmt : Elmt_Id; Child_Unit : Unit_Id; begin if not In_Unit_Id_List (Desc_Unit, Result_List) then Append_Unit_To_List (Desc_Unit, Result_List); if Kind (Cont, Desc_Unit) = A_Package or else Kind (Cont, Desc_Unit) = A_Generic_Package or else Kind (Cont, Desc_Unit) = A_Package_Renaming or else Kind (Cont, Desc_Unit) = A_Generic_Package_Renaming then Child_Elmt := First_Elmt (Unit_Table.Table (Desc_Unit).Subunits_Or_Childs); while Present (Child_Elmt) loop Child_Unit := Unit (Child_Elmt); Add_All_Descendants (Child_Unit, Result_List); Child_Elmt := Next_Elmt (Child_Elmt); end loop; end if; end if; end Add_All_Descendants; begin -- We can not use CU_To_Unit_Id_List routine, because we have to -- filter out subunits, nonexistent units (?) and bodies for which the -- Context does not contain a spec - such units can not have -- descendants. For bodies, only the corresponding specs contain the -- lists of descendants. for I in Compilation_Units'Range loop Next_Unit := Get_Unit_Id (Compilation_Units (I)); if Kind (Cont, Next_Unit) not in A_Procedure_Body_Subunit .. A_Nonexistent_Body then if Kind (Cont, Next_Unit) in A_Library_Unit_Body then Next_Unit := Get_Declaration (Cont, Next_Unit); end if; if Present (Next_Unit) and then (not In_List (Next_Unit, Arg_List, Arg_List_Len)) then Arg_List_Len := Arg_List_Len + 1; Arg_List (Arg_List_Len) := Next_Unit; end if; end if; end loop; for J in 1 .. Arg_List_Len loop Next_Descendant_Elmt := First_Elmt (Unit_Table.Table (Arg_List (J)).Subunits_Or_Childs); while Present (Next_Descendant_Elmt) loop Next_Unit := Unit (Next_Descendant_Elmt); Add_All_Descendants (Next_Unit, Result_List); Next_Descendant_Elmt := Next_Elmt (Next_Descendant_Elmt); end loop; end loop; if Result_List /= null then Reorder_Sem_Dependencies (Result_List); Result := new Compilation_Unit_List' (Get_Comp_Unit_List (Result_List.all, Cont)); Free (Result_List); else Result := new Compilation_Unit_List (1 .. 0); end if; end Set_All_Descendants; ---------------------- -- Set_All_Families -- ---------------------- procedure Set_All_Families (Compilation_Units : Asis.Compilation_Unit_List; Result : in out Compilation_Unit_List_Access) is Cont : constant Context_Id := Current_Context; Arg_List : Unit_Id_List (1 .. Compilation_Units'Length) := (others => Nil_Unit); Arg_List_Len : Natural := 0; Result_List : Unit_Id_List_Access := null; procedure Collect_Spec_Family (Spec_Unit : Unit_Id; Result_List : in out Unit_Id_List_Access); -- If Spec_Unit is not in Result_List, this procedure adds it and -- (recursively) all members of its family which are not in Result_List -- to the list. In case of a spec, the corresponding body's family is -- also added procedure Collect_Body_Family (Body_Unit : Unit_Id; Result_List : in out Unit_Id_List_Access); -- If Body_Unit is not in Result_List, this procedure adds it and -- (recursively) all members of its family which are not in Result_List -- to the list. In case of a body, only the subunit tree rooted by this -- body may be added procedure Collect_Spec_Family (Spec_Unit : Unit_Id; Result_List : in out Unit_Id_List_Access) is Child_Elmt : Elmt_Id; Child_Unit : Unit_Id; begin if not In_Unit_Id_List (Spec_Unit, Result_List) then Append_Unit_To_List (Spec_Unit, Result_List); -- We have to add all descendants (if any) and their families if Kind (Cont, Spec_Unit) = A_Package or else Kind (Cont, Spec_Unit) = A_Generic_Package or else Kind (Cont, Spec_Unit) = A_Package_Renaming or else Kind (Cont, Spec_Unit) = A_Generic_Package_Renaming then Child_Elmt := First_Elmt (Unit_Table.Table (Spec_Unit).Subunits_Or_Childs); while Present (Child_Elmt) loop Child_Unit := Unit (Child_Elmt); if Kind (Cont, Child_Unit) in A_Procedure .. A_Generic_Package_Renaming then Collect_Spec_Family (Child_Unit, Result_List); elsif Kind (Cont, Child_Unit) in A_Procedure_Body .. A_Protected_Body_Subunit then Collect_Body_Family (Child_Unit, Result_List); end if; Child_Elmt := Next_Elmt (Child_Elmt); end loop; end if; end if; end Collect_Spec_Family; procedure Collect_Body_Family (Body_Unit : Unit_Id; Result_List : in out Unit_Id_List_Access) is Child_Elmt : Elmt_Id; Child_Unit : Unit_Id; begin if not In_Unit_Id_List (Body_Unit, Result_List) then Append_Unit_To_List (Body_Unit, Result_List); -- We have to add all descendants (if any) and their families if Kind (Cont, Body_Unit) in A_Procedure_Body .. A_Protected_Body_Subunit then Child_Elmt := First_Elmt (Unit_Table.Table (Body_Unit).Subunits_Or_Childs); while Present (Child_Elmt) loop Child_Unit := Unit (Child_Elmt); Collect_Body_Family (Child_Unit, Result_List); Child_Elmt := Next_Elmt (Child_Elmt); end loop; end if; end if; end Collect_Body_Family; begin CU_To_Unit_Id_List (Compilation_Units, Arg_List, Arg_List_Len); for J in 1 .. Arg_List_Len loop case Class (Cont, Arg_List (J)) is when A_Public_Declaration | A_Private_Declaration => Collect_Spec_Family (Arg_List (J), Result_List); when Not_A_Class => -- This should never happen, so just in case we -- raise an exception null; pragma Assert (False); when others => -- Here we can have only a body or a separate body Collect_Body_Family (Arg_List (J), Result_List); end case; end loop; -- And here we have to order Result_List to eliminate forward -- semantic dependencies if Result_List /= null then Reorder_Sem_Dependencies (Result_List); Result := new Compilation_Unit_List' (Get_Comp_Unit_List (Result_List.all, Cont)); Free (Result_List); else Result := new Compilation_Unit_List (1 .. 0); end if; end Set_All_Families; ------------------------ -- Set_All_Supporters -- ------------------------ procedure Set_All_Supporters (Compilation_Units : Asis.Compilation_Unit_List; Result : in out Compilation_Unit_List_Access) is Cont : constant Context_Id := Current_Context; Arg_List : Unit_Id_List (1 .. Compilation_Units'Length) := (others => Nil_Unit); Result_List : Unit_Id_List_Access := null; Arg_List_Len : Natural := 0; pragma Unreferenced (Arg_List_Len); procedure Collect_Supporters (U : Unit_Id); -- If U is not presented in Result, adds (recursively) all its -- supporters to Result_List procedure Collect_Supporters (U : Unit_Id) is Next_Support_Elmt : Elmt_Id; Next_Support_Unit : Unit_Id; begin if not In_Unit_Id_List (U, Result_List) then Next_Support_Elmt := First_Elmt (Unit_Table.Table (U).Supporters); while Present (Next_Support_Elmt) loop Next_Support_Unit := Unit (Next_Support_Elmt); if not In_Unit_Id_List (Next_Support_Unit, Result_List) then Collect_Supporters (Next_Support_Unit); Append_Unit_To_List (Next_Support_Unit, Result_List); end if; Next_Support_Elmt := Next_Elmt (Next_Support_Elmt); end loop; end if; end Collect_Supporters; begin -- For the current version, we are supposing, that we have only one -- Context opened at a time CU_To_Unit_Id_List (Compilation_Units, Arg_List, Arg_List_Len); -- Now, collecting all the supporters for Compilation_Units -- Standard is a supporter of any unit, and if we are here, -- Compilation_Units can not be Nil_Compilation_Unit_List. So we set -- it as the first element of the result list: Append_Unit_To_List (Standard_Id, Result_List); for J in Compilation_Units'Range loop Collect_Supporters (Get_Unit_Id (Compilation_Units (J))); end loop; -- And here we have to order Result_List to eliminate forward -- semantic dependencies -- Result_List can not be null - it contains at least Standard_Id Reorder_Sem_Dependencies (Result_List); Result := new Compilation_Unit_List' (Get_Comp_Unit_List (Result_List.all, Cont)); Free (Result_List); end Set_All_Supporters; -------------------------- -- Set_All_Needed_Units -- -------------------------- procedure Set_All_Needed_Units (Compilation_Units : Asis.Compilation_Unit_List; Result : in out Compilation_Unit_List_Access; Missed : in out Compilation_Unit_List_Access) is Cont : constant Context_Id := Current_Context; Cont_Tree_Mode : constant Tree_Mode := Tree_Processing_Mode (Cont); Arg_List : Unit_Id_List (1 .. Compilation_Units'Length) := (others => Nil_Unit); Arg_List_Len : Natural := 0; Result_List : Unit_Id_List_Access := null; Missed_List : Unit_Id_List_Access := null; procedure Set_One_Unit (U : Unit_Id); -- Provided that U is an (existing) unit which is not in the -- Result_List, this procedure adds this unit and all the units -- needed by it to result lists. procedure Add_Needed_By_Spec (Spec_Unit : Unit_Id); -- Provided that Spec_Unit denotes an (existing) spec, this procedure -- adds to the result lists units which are needed by this unit only, -- that is, excluding this unit (it is supposed to be already added at -- the moment of the call), its body and units needed by the body (if -- any, they are processed separately) procedure Add_Needed_By_Body (Body_Unit : Unit_Id); -- Provided that Body_Unit denotes an (existing) body, this procedure -- adds to the result lists units which are needed by this unit, -- excluding the unit itself (it is supposed to be already added at -- the moment of the call). That is, the spec of this unit and units -- which are needed by the spec (if any) are also needed, if they have -- not been added before ------------------------ -- Add_Needed_By_Body -- ------------------------ procedure Add_Needed_By_Body (Body_Unit : Unit_Id) is Spec_Unit : Unit_Id; Subunit_List : constant Unit_Id_List := Subunits (Cont, Body_Unit); Next_Support_Elmt : Elmt_Id; Next_Support_Unit : Unit_Id; begin -- First, check if there is a separate spec then it has to be -- processed if Class (Cont, Body_Unit) /= A_Public_Declaration_And_Body then Spec_Unit := Body_Unit; while Class (Cont, Spec_Unit) = A_Separate_Body loop Spec_Unit := Get_Subunit_Parent_Body (Cont, Spec_Unit); end loop; Spec_Unit := Get_Declaration (Cont, Spec_Unit); -- We can not get Nil or nonexistent unit here if not In_Unit_Id_List (Spec_Unit, Result_List) then Add_Needed_By_Spec (Spec_Unit); end if; end if; -- Now process body's supporters: Next_Support_Elmt := First_Elmt (Unit_Table.Table (Body_Unit).Supporters); while Present (Next_Support_Elmt) loop Next_Support_Unit := Unit (Next_Support_Elmt); if not In_Unit_Id_List (Next_Support_Unit, Result_List) then Set_One_Unit (Next_Support_Unit); end if; Next_Support_Elmt := Next_Elmt (Next_Support_Elmt); end loop; -- And, finally, subunits: for J in Subunit_List'Range loop if Kind (Cont, Subunit_List (J)) = A_Nonexistent_Body then Append_Unit_To_List (Subunit_List (J), Missed_List); elsif not In_Unit_Id_List (Subunit_List (J), Result_List) then Append_Unit_To_List (Subunit_List (J), Result_List); Add_Needed_By_Body (Subunit_List (J)); end if; end loop; end Add_Needed_By_Body; ------------------------ -- Add_Needed_By_Spec -- ------------------------ procedure Add_Needed_By_Spec (Spec_Unit : Unit_Id) is Next_Support_Elmt : Elmt_Id; Next_Support_Unit : Unit_Id; begin Next_Support_Elmt := First_Elmt (Unit_Table.Table (Spec_Unit).Supporters); while Present (Next_Support_Elmt) loop Next_Support_Unit := Unit (Next_Support_Elmt); if not In_Unit_Id_List (Next_Support_Unit, Result_List) then Set_One_Unit (Next_Support_Unit); end if; Next_Support_Elmt := Next_Elmt (Next_Support_Elmt); end loop; end Add_Needed_By_Spec; ------------------ -- Set_One_Unit -- ------------------ procedure Set_One_Unit (U : Unit_Id) is U_Body : Unit_Id; begin Append_Unit_To_List (U, Result_List); case Class (Cont, U) is when A_Public_Declaration | A_Private_Declaration => Add_Needed_By_Spec (U); if Is_Body_Required (Cont, U) then U_Body := Get_Body (Cont, U); if No (U_Body) and then (Cont_Tree_Mode = On_The_Fly or else Cont_Tree_Mode = Mixed) then -- Is it a correct thing to compile something on the fly -- Inside the query from Relations??? U_Body := Get_One_Unit (Name => To_Program_Text (Unit_Name (Get_Comp_Unit (U, Cont))), Context => Cont, Spec => False); end if; if Present (U_Body) then if Kind (Cont, U_Body) in A_Nonexistent_Declaration .. A_Nonexistent_Body then Add_To_Unit_Id_List (U_Body, Missed_List); elsif not In_Unit_Id_List (U_Body, Result_List) then Append_Unit_To_List (U_Body, Result_List); Add_Needed_By_Body (U_Body); end if; else U_Body := Get_Nonexistent_Unit (Cont); Append_Unit_To_List (U_Body, Missed_List); end if; end if; when Not_A_Class => -- This should never happen, so just in case we -- raise an exception null; pragma Assert (False); when others => Add_Needed_By_Body (U); end case; end Set_One_Unit; begin -- Set_All_Needed_Units CU_To_Unit_Id_List (Compilation_Units, Arg_List, Arg_List_Len); -- Standard is a supporter of any unit, and if we are here, -- Compilation_Units can not be Nil_Compilation_Unit_List. So we set -- it as the first element of the result list: Append_Unit_To_List (Standard_Id, Result_List); for J in 1 .. Arg_List_Len loop if not In_Unit_Id_List (Arg_List (J), Result_List) then Set_One_Unit (Arg_List (J)); end if; end loop; -- Result_List can not be null - it contains at least Standard_Id Reorder_Sem_Dependencies (Result_List); Result := new Compilation_Unit_List' (Get_Comp_Unit_List (Result_List.all, Cont)); Free (Result_List); if Missed_List /= null then Missed := new Compilation_Unit_List' (Get_Comp_Unit_List (Missed_List.all, Cont)); Free (Missed_List); else Missed := new Compilation_Unit_List (1 .. 0); end if; end Set_All_Needed_Units; ------------------ -- Set_Subunits -- ------------------ procedure Set_Subunits (C : Context_Id; U : Unit_Id; Top : Node_Id) is Body_Node : Node_Id; Stub_Node : Node_Id; begin Get_Name_String (U, Norm_Ada_Name); Body_Node := Unit (Top); if Nkind (Body_Node) = N_Subunit then Body_Node := Proper_Body (Body_Node); end if; Stub_Node := Get_First_Stub (Body_Node); if No (Stub_Node) then return; end if; while Present (Stub_Node) loop Process_Stub (C, U, Stub_Node); Stub_Node := Get_Next_Stub (Stub_Node); end loop; Unit_Table.Table (U).Subunits_Computed := True; end Set_Subunits; -------------------- -- Set_Supporters -- -------------------- procedure Set_Supporters (C : Context_Id; U : Unit_Id; Top : Node_Id) is begin Set_Withed_Units (C, U, Top); Set_Direct_Dependents (U); end Set_Supporters; ---------------------- -- Set_Withed_Units -- ---------------------- procedure Set_Withed_Units (C : Context_Id; U : Unit_Id; Top : Node_Id) is With_Clause_Node : Node_Id; Cunit_Node : Node_Id; Cunit_Number : Unit_Number_Type; Current_Supporter : Unit_Id; Tmp : Unit_Id; Include_Unit : Boolean := False; begin -- the maim control structure - cycle through the with clauses -- in the tree if No (Context_Items (Top)) then return; end if; With_Clause_Node := First_Non_Pragma (Context_Items (Top)); while Present (With_Clause_Node) loop -- here we simply get the name of the next supporting unit from -- the GNAT Units Table (defined in Lib) Cunit_Node := Library_Unit (With_Clause_Node); Cunit_Number := Get_Cunit_Unit_Number (Cunit_Node); Get_Decoded_Name_String (Unit_Name (Cunit_Number)); Set_Norm_Ada_Name_String_With_Check (Cunit_Number, Include_Unit); if Include_Unit then Current_Supporter := Name_Find (C); if A_Name_Buffer (A_Name_Len) = 'b' then A_Name_Buffer (A_Name_Len) := 's'; Tmp := Name_Find (C); if Present (Tmp) then -- OPEN PROBLEM: is this the best solution for this problem? -- -- Here we are in the potentially hard-to-report-about and -- definitely involving inconsistent unit set situation. -- The last version of U depends on subprogram body at least -- in one of the consistent trees, but the Context contains -- a spec (that is, a library_unit_declaration or a -- library_unit_renaming_declaration) for the same full -- expanded Ada name. The current working decision is -- to set this dependency as if U depends on the spec. -- -- Another (crazy!) problem: in one consistent tree -- U depends on the package P (and P does not require a -- body), and in another consistent tree U depends on -- the procedure P which is presented by its body only. -- It may be quite possible, if these trees were created -- with different search paths. Is our decision reasonable -- for this crazy situation :-[ ??!!?? Current_Supporter := Tmp; end if; end if; -- and now we store this dependency - we have to use -- Add_To_Elmt_List instead of Append_Elmt - some units -- may be mentioned several times in the context clause: if Implicit_With (With_Clause_Node) then Add_To_Elmt_List (Unit => Current_Supporter, List => Unit_Table.Table (U).Implicit_Supporters); else Add_To_Elmt_List (Unit => Current_Supporter, List => Unit_Table.Table (U).Direct_Supporters); end if; end if; With_Clause_Node := Next_Non_Pragma (With_Clause_Node); while Present (With_Clause_Node) and then Nkind (With_Clause_Node) /= N_With_Clause loop With_Clause_Node := Next_Non_Pragma (With_Clause_Node); end loop; end loop; end Set_Withed_Units; ------------------------------------------------------- -- Dynamic Unit_Id list abstraction (implementation) -- ------------------------------------------------------- ---------------------- -- In_Unit_Id_List -- ---------------------- function In_Unit_Id_List (U : Unit_Id; L : Unit_Id_List_Access) return Boolean is begin if L /= null then for I in L'Range loop if U = L (I) then return True; end if; end loop; end if; return False; end In_Unit_Id_List; -------------------------- -- Add_To_Unit_Id_List -- -------------------------- procedure Add_To_Unit_Id_List (U : Unit_Id; L : in out Unit_Id_List_Access) is begin if not In_Unit_Id_List (U, L) then Append_Unit_To_List (U, L); end if; end Add_To_Unit_Id_List; ------------------------- -- Append_Unit_To_List -- ------------------------- procedure Append_Unit_To_List (U : Unit_Id; L : in out Unit_Id_List_Access) is begin if L = null then L := new Unit_Id_List'(1 => U); else Free (Tmp_Unit_Id_List_Access); Tmp_Unit_Id_List_Access := new Unit_Id_List'(L.all & U); Free (L); L := new Unit_Id_List'(Tmp_Unit_Id_List_Access.all); end if; end Append_Unit_To_List; end A4G.Contt.Dp; asis-2010.orig/asis/a4g-contt-dp.ads0000644000175000017500000002255211574704441017042 0ustar lbrentalbrenta------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- A 4 G . C O N T T . D P -- -- -- -- S p e c -- -- -- -- Copyright (c) 1995-2006, Free Software Foundation, Inc. -- -- -- -- ASIS-for-GNAT 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 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 51 Franklin -- -- Street, Fifth Floor, Boston, MA 02110-1301, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by AdaCore -- -- (http://www.adacore.com). -- -- -- ------------------------------------------------------------------------------ -- This package defines routines for computing and setting semantic -- dependencies between ASIS Compilation Units with Asis; use Asis; with Asis.Extensions; use Asis.Extensions; package A4G.Contt.Dp is -- Context_Table.DePendencies -- All the subprograms defined in this package are supposed, that -- (1) they are called at most once (depending on the unit kind) for any -- unit stored in the Context Unit table -- (2) the caller is responsible, that these subprograms are called for -- the actuals of appropriate kinds -- OPEN PROBLEMS: -- -- 1. DOCUMENTATION!!! -- -- 2. The idea is to *compute from the tree* only direct dependencies, -- and for all the indirect dependencies, to compute them from -- the direct dependencies using their transitive nature. procedure Set_Supporters (C : Context_Id; U : Unit_Id; Top : Node_Id); -- This procedure sets the **direct** supporters for U. For now, -- the idea is to set *from the tree* only the direct dependencies, -- as being the function of the source text of a Unit (???). All -- the indirect dependencies should be set from direct ones using -- the transitive nature of the dependencies. -- -- So, for now, only Direct_Supporters, Direct_Dependants and -- Implicit_Supporters (representing only direct implicit dependencies -- imposed by implicit with clauses) are set by this procedure. -- -- OPEN PROBLEM: If we set only **direct* dependencies, may be, -- we need only ONE function to do this? do we really need -- Set_Ancestors, Set_Childs, ???? ? procedure Set_Subunits (C : Context_Id; U : Unit_Id; Top : Node_Id); -- Sets the full list of the subunit for a given body (that is, adds -- nonexistent units for missed subunits) procedure Process_Stub (C : Context_Id; U : Unit_Id; Stub : Node_Id); -- Taking the node for a body stub, this function checks if the -- corresponding subunit exists in the Context C. If it does not exist, -- a unit of A_Nonexistent_Body kind is allocated in the Context Unit -- table and appended to the list of subunits of U. -- -- This procedure supposes, that before it is called, the normalized -- name of U has been already set in A_Name_Buffer. When returning from -- this procedure, A_Name_Buffer and A_Name_Len are remained in the -- same state as before the call. procedure Append_Subunit_Name (Def_S_Name : Node_Id); -- Supposing that A_Name_Buf contains the name of the parent body, and -- Def_S_Name points to the defining identifier obtained from the body -- stub, this procedure forms in A_Name_Buffer the name of the subunit procedure Set_Withed_Units (C : Context_Id; U : Unit_Id; Top : Node_Id); -- This procedure sets the Direct_Supporters and Implicit_Supporters -- dependency lists on the base of with clauses explicicitly presented -- in unit's source and generated by the compiler respectively. procedure Set_Direct_Dependents (U : Unit_Id); -- This procedure is supposed to be called for U just after -- Set_Withed_Units has done its work. For any unit U1 included -- in the list of direct supporters for U, U is included in the list -- of direct dependers of U1. procedure Add_To_Parent (C : Context_Id; U : Unit_Id); -- Adds U to the list of children for its parent unit declaration. -- U is added to the list only it is consistent with the parent procedure Set_All_Dependencies (Use_First_New_Unit : Boolean := False); -- Sets all supportiers and all dependants for units contained in the -- argument Context. Should be called when all the units are already set. -- If Use_First_New_Unit is set ON (this may happen for Incremental -- Context only), completes the dependencies only for new units from the -- new tree (see the body of A4G.Get_Unit.Fetch_Unit_By_Ada_Name) procedure Set_All_Ancestors (Compilation_Units : Asis.Compilation_Unit_List; Result : in out Compilation_Unit_List_Access); -- This procedure takes the arguments of -- Asis.Compilation_Units.Relations.Semantic_Dependence_Order query in -- case when Relation parameter is set to Ancestors and computes the -- consistent part of the result.(???) procedure Set_All_Descendants (Compilation_Units : Asis.Compilation_Unit_List; Result : in out Compilation_Unit_List_Access); -- This procedure takes the arguments of -- Asis.Compilation_Units.Relations.Semantic_Dependence_Order query in -- case when Relation parameter is set to Descendants and computes the -- consistent part of the result.(???) procedure Set_All_Supporters (Compilation_Units : Asis.Compilation_Unit_List; Result : in out Compilation_Unit_List_Access); -- This procedure takes the arguments of -- Asis.Compilation_Units.Relations.Semantic_Dependence_Order query in -- case when Relation parameter is set to Supporters and -- computes the consistent part of the result.(???) procedure Set_All_Dependents (Compilation_Units : Asis.Compilation_Unit_List; Dependent_Units : Asis.Compilation_Unit_List; Result : in out Compilation_Unit_List_Access); -- This procedure takes the arguments of -- Asis.Compilation_Units.Relations.Semantic_Dependence_Order query in -- case when Relation parameter is set to Dependents and computes the -- consistent part of the result.(???) procedure Set_All_Families (Compilation_Units : Asis.Compilation_Unit_List; Result : in out Compilation_Unit_List_Access); -- This procedure takes the arguments of -- Asis.Compilation_Units.Relations.Semantic_Dependence_Order query in -- case when Relation parameter is set to Family and -- computes the consistent part of the result.(???) procedure Set_All_Needed_Units (Compilation_Units : Asis.Compilation_Unit_List; Result : in out Compilation_Unit_List_Access; Missed : in out Compilation_Unit_List_Access); -- This procedure takes the arguments of -- Asis.Compilation_Units.Relations.Semantic_Dependence_Order query in -- case when Relation parameter is set to Needed_Units and -- computes the consistent part of the result and missed units.(???) end A4G.Contt.Dp; asis-2010.orig/asis/a4g-contt-sd.adb0000644000175000017500000005456711574704441017037 0ustar lbrentalbrenta------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- A 4 G . C O N T T . S D -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- -- -- -- ASIS-for-GNAT 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 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 51 Franklin -- -- Street, Fifth Floor, Boston, MA 02110-1301, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by AdaCore -- -- (http://www.adacore.com). -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.OS_Lib; with Asis.Errors; use Asis.Errors; with Asis.Exceptions; use Asis.Exceptions; with A4G.A_Debug; use A4G.A_Debug; with A4G.GNAT_Int; with A4G.A_Output; use A4G.A_Output; with A4G.Contt.TT; use A4G.Contt.TT; with A4G.Contt.UT; use A4G.Contt.UT; with A4G.CU_Info2; use A4G.CU_Info2; with A4G.Defaults; use A4G.Defaults; with A4G.Vcheck; use A4G.Vcheck; with Atree; with Lib; with Output; use Output; with Sinfo; use Sinfo; package body A4G.Contt.SD is ------------------------------------ -- Local Subprograms (new stuff) -- ------------------------------------ -- Do we need some of these local subprograms as the interface -- subprograms of this package? -- Is this package the right location for these subprograms? procedure Scan_Search_Path (C : Context_Id); -- Scans the tree search path and stores the names of the tree file -- candidates in the context tree table. procedure Scan_Tree_List (C : Context_Id); -- This procedure is supposed to be called for One_tree and N_Trees -- Context processing modes, therefore the Parameters string associated -- with C should contain at least one tree name. It scans the list of tree -- file names which have been extracted from the Parameters string when -- making the association for C. For each tree file name checks if the -- file exists and stores existing files in the context tree table. In case -- if this check fails, raises ASIS_Failed if C was defined as "-C1" -- ("one tree") context, or generates Asis Warning for "-CN" Context. -- This procedure does not reset a context. procedure Read_and_Check_New (C : Context_Id; Tree : Tree_Id; Success : out Boolean); -- Tries to read in Tree and to check if this tree is compile-only. -- if both of these attempts are successful, sets Success ON and -- sets Current_Tree as Tree. If either of these actions fails, then -- depending on the Context operation mode, either raises ASIS_Failed -- and forms the Diagnosis string on behalf on Asis.Ada_Environments.Open, -- or only sets Success OFF, in both cases Current_Context and Current_Tree -- are set to nil values. procedure Process_Unit_New (U : Unit_Number_Type); -- Does the general unit processing in one-pass Context opening. If this -- unit is "new", it creates the new entry in the unit table and checks, -- if the unit in the tree is consistent with the unit source (if needed). -- If U corresponds to a "known" unit, it makes the consistency check. -- If this procedure raises ASIS_Failed, it forms the Diagnosis string -- on behalf on Asis.Ada_Environments.Open -- ???????? procedure Investigate_Unit_New (C : Context_Id; U : Unit_Id; U_N : Unit_Number_Type); -- Computes the basic unit attributes for U_N and stores them for the -- ASIS unit U in the ASIS Context C. procedure Store_Tree (Path : String); -- Stores the full name of the tree file in the Context Tree table for -- the current Context. It supposes, that when it is called, -- Namet.Name_Table contains the name of the tree file to be stored, -- but without any directory information, and Path contains the path to -- the tree search directory (followed by directory separator) where this -- file was found. --------------------------- -- Investigate_Trees_New -- --------------------------- procedure Investigate_Trees_New (C : Context_Id) is Success : Boolean := False; -- flag indicating if the next tree file has been successfully read in Current_Dir : constant Dir_Name_Str := Get_Current_Dir; begin -- here we have all the names of tree files stored in the tree table -- for C for T in First_Tree_Id .. Last_Tree (C) loop Read_and_Check_New (C, T, Success); if Success then Get_Name_String (C, T); Change_Dir (Dir_Name (A_Name_Buffer (1 .. A_Name_Len))); Register_Units; Scan_Units_New; Change_Dir (Current_Dir); end if; end loop; end Investigate_Trees_New; -------------------------- -- Investigate_Unit_New -- -------------------------- procedure Investigate_Unit_New (C : Context_Id; U : Unit_Id; U_N : Unit_Number_Type) is Top : constant Node_Id := Lib.Cunit (U_N); -- pointer to the N_Compilation_Unit node for U in the currently -- accessed tree begin Set_S_F_Name_and_Origin (C, U, Top); Check_Source_Consistency (C, U); Set_Kind_and_Class (C, U, Top); Get_Ada_Name (Top); Set_Ada_Name (U); Set_Is_Main_Unit (C, U, Is_Main (Top, Kind (C, U))); Set_Is_Body_Required (C, U, Sinfo.Body_Required (Top)); Set_Dependencies (C, U, Top); end Investigate_Unit_New; ---------------------- -- Process_Unit_New -- ---------------------- procedure Process_Unit_New (U : Unit_Number_Type) is Cont : constant Context_Id := Get_Current_Cont; Include_Unit : Boolean := False; Current_Unit : Unit_Id; begin Namet.Get_Decoded_Name_String (Lib.Unit_Name (U)); Set_Norm_Ada_Name_String_With_Check (U, Include_Unit); if not Include_Unit then return; end if; Current_Unit := Name_Find (Cont); -- all the units in the current tree are already registered, therefore -- Current_Unit should not be Nil_Unit if Already_Processed (Cont, Current_Unit) then Check_Consistency (Cont, Current_Unit, U); Append_Tree_To_Unit (Cont, Current_Unit); else Investigate_Unit_New (Cont, Current_Unit, U); end if; end Process_Unit_New; ------------------------ -- Read_and_Check_New -- ------------------------ procedure Read_and_Check_New (C : Context_Id; Tree : Tree_Id; Success : out Boolean) is Tree_File_D : File_Descriptor; begin -- Special processing for GNSA mode: if Tree_Processing_Mode (C) = GNSA then if Context_Processing_Mode (C) = One_Tree then Set_Current_Cont (C); Set_Current_Tree (Tree); Success := True; return; else -- Other possibilites are not implemented now, so pragma Assert (False); null; end if; end if; Get_Name_String (C, Tree); A_Name_Buffer (A_Name_Len + 1) := ASCII.NUL; Tree_File_D := Open_Read (A_Name_Buffer'Address, Binary); A4G.GNAT_Int.Tree_In_With_Version_Check (Tree_File_D, C, Success); Set_Current_Cont (C); Set_Current_Tree (Tree); exception when Program_Error | ASIS_Failed => Set_Current_Cont (Nil_Context_Id); Set_Current_Tree (Nil_Tree); raise; when Ex : others => -- If we are here, we are definitely having a serious problem: -- we have a tree file which is version-compartible with ASIS, -- and we can not read it because of some unknown reason. Set_Current_Cont (Nil_Context_Id); Set_Current_Tree (Nil_Tree); -- debug stuff... if Debug_Flag_O or else Debug_Lib_Model or else Debug_Mode then Write_Str ("The tree file "); Write_Str (A_Name_Buffer (1 .. A_Name_Len)); Write_Str (" was not read in and checked successfully"); Write_Eol; Write_Str (Ada.Exceptions.Exception_Name (Ex)); Write_Str (" was raised"); Write_Eol; Write_Str ("Exception message: "); Write_Str (Ada.Exceptions.Exception_Message (Ex)); Write_Eol; end if; Report_ASIS_Bug (Query_Name => "A4G.Contt.SD.Read_and_Check_New" & " (tree file " & A_Name_Buffer (1 .. A_Name_Len) & ")", Ex => Ex); end Read_and_Check_New; -------------------- -- Scan_Tree_List -- -------------------- procedure Scan_Tree_List (C : Context_Id) is Cont_Mode : constant Context_Mode := Context_Processing_Mode (C); Tree_List : Tree_File_List_Ptr renames Contexts.Table (C).Context_Tree_Files; GNSA_Tree_Name : constant String := "GNSA-created tree"; -- Can be used for -C1 COntext only. begin -- Special processing for GNSA mode: if Tree_Processing_Mode (C) = GNSA then if Context_Processing_Mode (C) = One_Tree then Name_Len := GNSA_Tree_Name'Length; Name_Buffer (1 .. Name_Len) := GNSA_Tree_Name; Store_Tree (""); return; else -- Other possibilites are not implemented now, so pragma Assert (False); null; end if; end if; for I in Tree_List'Range loop exit when Tree_List (I) = null; if not Is_Regular_File (Tree_List (I).all) then if Cont_Mode = One_Tree then Set_Error_Status (Status => Asis.Errors.Use_Error, Diagnosis => "Asis.Ada_Environments.Open:" & ASIS_Line_Terminator & "tree file " & Tree_List (I).all & " does not exist"); raise ASIS_Failed; elsif Cont_Mode = N_Trees then ASIS_Warning (Message => "Asis.Ada_Environments.Open: " & ASIS_Line_Terminator & "tree file " & Tree_List (I).all & " does not exist", Error => Use_Error); end if; else Name_Len := Tree_List (I)'Length; Name_Buffer (1 .. Name_Len) := Tree_List (I).all; Store_Tree (""); end if; end loop; end Scan_Tree_List; ---------------------- -- Scan_Search_Path -- ---------------------- procedure Scan_Search_Path (C : Context_Id) is Curr_Dir : GNAT.Directory_Operations.Dir_Type; Search_Path : constant Directory_List_Ptr := Contexts.Table (C).Tree_Path; procedure Scan_Dir (Path : String); -- scans tree files in Curr_Dir. Puts in the Name Table all -- the files having names of the form *.at?, which have not been -- scanned before. Sets the global variable Last_Tree_File equal to -- the Name_Id of the last scanned tree file. The names of the tree -- files stores in the Name Table are also stored in the ASIS tree -- table with the directory information passed as the actual for Path -- parameter procedure Read_Tree_File (Dir : in out GNAT.Directory_Operations.Dir_Type; Str : out String; Last : out Natural); -- This procedure is the modification of GNAT.Directory_Operations.Read -- which reads only tree file entries from the directory. A Tree file -- is any file having the extension '.[aA][dD][tT]' (We are -- considering upper case letters because of "semi-case-sensitiveness" -- of Windows 95/98/NT.) procedure Read_Tree_File (Dir : in out GNAT.Directory_Operations.Dir_Type; Str : out String; Last : out Natural) is function Is_Tree_File return Boolean; -- Checks if the file name stored in Str is the name of some tree -- file. This function assumes that Str'First is 1, and that -- Last > 0 function Is_Tree_File return Boolean is Result : Boolean := False; begin if Last >= 5 and then Str (Last - 3) = '.' and then (Str (Last) = 't' or else Str (Last) = 'T') and then (Str (Last - 1) = 'd' or else Str (Last - 1) = 'D') and then (Str (Last - 2) = 'a' or else Str (Last - 2) = 'A') then Result := True; end if; return Result; end Is_Tree_File; begin GNAT.Directory_Operations.Read (Dir, Str, Last); while Last > 0 loop exit when Is_Tree_File; GNAT.Directory_Operations.Read (Dir, Str, Last); end loop; end Read_Tree_File; procedure Scan_Dir (Path : String) is T_File : Name_Id; Is_First_Tree : Boolean := True; begin -- looking for the first tree file in this directory Read_Tree_File (Dir => Curr_Dir, Str => Namet.Name_Buffer, Last => Namet.Name_Len); while Namet.Name_Len > 0 loop T_File := Name_Find; if Is_First_Tree then Is_First_Tree := False; First_Tree_File := T_File; end if; if T_File > Last_Tree_File then Last_Tree_File := T_File; Store_Tree (Path); end if; Read_Tree_File (Dir => Curr_Dir, Str => Namet.Name_Buffer, Last => Namet.Name_Len); end loop; end Scan_Dir; begin -- Scan_Search_Path if Search_Path = null then GNAT.Directory_Operations.Open (Curr_Dir, "." & Directory_Separator); Scan_Dir (""); GNAT.Directory_Operations.Close (Curr_Dir); else for I in 1 .. Search_Path'Last loop GNAT.Directory_Operations.Open (Curr_Dir, Search_Path (I).all); Scan_Dir (Search_Path (I).all); GNAT.Directory_Operations.Close (Curr_Dir); end loop; end if; if Use_Default_Trees (C) then for J in First_Dir_Id .. ASIS_Tree_Search_Directories.Last loop GNAT.Directory_Operations.Open (Curr_Dir, ASIS_Tree_Search_Directories.Table (J).all); Scan_Dir (ASIS_Tree_Search_Directories.Table (J).all); GNAT.Directory_Operations.Close (Curr_Dir); end loop; end if; end Scan_Search_Path; ------------------------- -- Scan_Tree_Files_New -- ------------------------- procedure Scan_Tree_Files_New (C : Context_Id) is C_Mode : constant Context_Mode := Context_Processing_Mode (C); GNSA_Tree_Name : constant String := "GNSA-created tree"; -- Can be used for -C1 Context only begin -- Special processing for GNSA mode: if Tree_Processing_Mode (C) = GNSA then if Context_Processing_Mode (C) = One_Tree then Name_Len := GNSA_Tree_Name'Length; Name_Buffer (1 .. Name_Len) := GNSA_Tree_Name; Store_Tree (""); return; -- to avoid GNAT Name Table corruption else -- Other possibilites are not implemented now, so pragma Assert (False); null; end if; end if; -- first, initialization which is (may be?) common for all context -- modes: First_Tree_File := First_Name_Id; Last_Tree_File := First_Name_Id - 1; Namet.Initialize; -- now for different context modes we call individual scan procedures. -- all of them first put names of tree files into the GNAT Name table -- and then transfer them into Context tree table, but we cannot -- factor this out because of the differences in processing a search -- path (if any) and forming the full names of the tree files case C_Mode is when All_Trees => Scan_Search_Path (C); when One_Tree | N_Trees => Scan_Tree_List (C); -- all the tree file names have already been stored in the -- context tree table when association parameters were processed null; when Partition => Not_Implemented_Yet ("Scan_Tree_Files_New (Partition)"); end case; -- debug output:... if Debug_Flag_O or else Debug_Lib_Model or else Debug_Mode then Write_Str ("Scanning tree files for Context "); Write_Int (Int (C)); Write_Eol; if Context_Processing_Mode (C) = All_Trees then if Last_Tree_File < First_Tree_File then Write_Str (" no tree file has been found"); Write_Eol; else Write_Str (" the content of the Name Table is:"); Write_Eol; for I in First_Tree_File .. Last_Tree_File loop Get_Name_String (I); Write_Str (" "); Write_Str (Name_Buffer (1 .. Name_Len)); Write_Eol; end loop; end if; else Write_Str ("Trees already stored in the tree table:"); Write_Eol; for Tr in First_Tree_Id .. Last_Tree (C) loop Get_Name_String (C, Tr); Write_Str (" " & A_Name_Buffer (1 .. A_Name_Len)); Write_Eol; end loop; end if; end if; end Scan_Tree_Files_New; -------------------- -- Scan_Units_New -- -------------------- procedure Scan_Units_New is Main_Unit_Id : Unit_Id; Next_Unit_Id : Unit_Id; Include_Unit : Boolean := False; begin for N_Unit in Main_Unit .. Lib.Last_Unit loop if Atree.Present (Lib.Cunit (N_Unit)) then Process_Unit_New (N_Unit); end if; end loop; -- And here we collect compilation dependencies for the main unit in -- the tree: Namet.Get_Decoded_Name_String (Lib.Unit_Name (Main_Unit)); Set_Norm_Ada_Name_String_With_Check (Main_Unit, Include_Unit); if not Include_Unit then return; end if; Main_Unit_Id := Name_Find (Current_Context); for N_Unit in Main_Unit .. Lib.Last_Unit loop if Atree.Present (Lib.Cunit (N_Unit)) then Namet.Get_Decoded_Name_String (Lib.Unit_Name (N_Unit)); Set_Norm_Ada_Name_String_With_Check (N_Unit, Include_Unit); if Include_Unit then Next_Unit_Id := Name_Find (Current_Context); Add_To_Elmt_List (Unit => Next_Unit_Id, List => Unit_Table.Table (Main_Unit_Id).Compilation_Dependencies); end if; end if; end loop; Unit_Table.Table (Main_Unit_Id).Main_Tree := Current_Tree; Set_Main_Unit_Id (Main_Unit_Id); end Scan_Units_New; ---------------- -- Store_Tree -- ---------------- procedure Store_Tree (Path : String) is New_Tree : Tree_Id; -- we do not need it, but Allocate_Tree_Entry is a function... pragma Warnings (Off, New_Tree); begin if Path = "" then Set_Name_String (GNAT.OS_Lib.Normalize_Pathname (Name_Buffer (1 .. Name_Len))); else Set_Name_String (GNAT.OS_Lib.Normalize_Pathname (Path & Directory_Separator & Name_Buffer (1 .. Name_Len))); end if; New_Tree := Allocate_Tree_Entry; end Store_Tree; end A4G.Contt.SD; asis-2010.orig/asis/a4g-contt-sd.ads0000644000175000017500000001271411574704441017044 0ustar lbrentalbrenta------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- A 4 G . C O N T T . S D -- -- -- -- S p e c -- -- -- -- Copyright (C) 1995-2007, Free Software Foundation, Inc. -- -- -- -- ASIS-for-GNAT 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 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 51 Franklin -- -- Street, Fifth Floor, Boston, MA 02110-1301, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by AdaCore -- -- (http://www.adacore.com). -- -- -- ------------------------------------------------------------------------------ -- This package defines the procedures which scans the tree search paths for -- a given Context and analyses the availible tree files with Namet; use Namet; package A4G.Contt.SD is First_Tree_File : Name_Id := First_Name_Id; Last_Tree_File : Name_Id := First_Name_Id - 1; -- Indexes of the first and the last tree file candidates, which were -- found during the last scanning of the tree search path of some -- directory. Are set by Scan_Tree_Files below. These variables are -- undefinite -- SHOULD WE MOVE THESE VARIABLES IN THE BODY -- AND EVEN MORE - DO WE REALLY NEED THEM AT ALL??!! procedure Scan_Tree_Files_New (C : Context_Id); -- Stores the names of the tree files making up the Context C in the Tree -- table for C. Every tree file name is stored only once. -- In All_Trees Context mode it scans the tree search path, using the same -- approach for the tree files with the same name as GNAT does for source -- files in the source search path. In N_Trees mode it scans the Parametes -- string set when C was associated. In this case, if the name of the same -- tree file is given more then once, but in diffrent forms (for example -- ../my_dir/foo.ats and ../../my_home_dir/my_dir/foo.ats), all these -- different names of the same tree file will be stored in the tree table procedure Investigate_Trees_New (C : Context_Id); -- This procedure implements the second step of opening a Context. It uses -- the names of the tree files in the Context Tree Table. For every tree -- file, it reads it in and extracts some information about compilation -- units presented by this file. It also makes the consistency check. -- Checks which are made by this procedure depend on the context options -- which were set when C was associated. -- -- Is this package the right location for this procedure??? procedure Scan_Units_New; -- Scans the currently accessed tree which was readed in by the -- immediately preceding call to Read_and_Check_New. If a unit is "new" -- (that is, if it has not already been encountered during opening a -- Context), all the black-box information is computed and stored in the -- Context table. Otherwise (that is, if the unit is already "known") -- the consistency check is made. -- -- When this procedure raises ASIS_Failed, it forms the Diagnosis string -- on befalf on Asis.Ada_Environments.Open end A4G.Contt.SD; asis-2010.orig/asis/a4g-contt-tt.adb0000644000175000017500000007726711574704441017062 0ustar lbrentalbrenta------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- A 4 G . C O N T T . T T -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- -- -- -- ASIS-for-GNAT 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 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 51 Franklin -- -- Street, Fifth Floor, Boston, MA 02110-1301, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by AdaCore -- -- (http://www.adacore.com). -- -- -- ------------------------------------------------------------------------------ -- This package defines Tree Table, which contains the information -- about the tree output files needed for swapping the ASTs accessed -- by ASIS. This information includes such things as Asis Compilation -- Units, and their top nodes in the tree. with Asis; use Asis; with Asis.Errors; use Asis.Errors; with Asis.Set_Get; use Asis.Set_Get; with A4G.A_Debug; use A4G.A_Debug; with A4G.A_Output; use A4G.A_Output; with A4G.Asis_Tables; use A4G.Asis_Tables; with A4G.Contt.UT; use A4G.Contt.UT; with A4G.Get_Unit; use A4G.Get_Unit; with A4G.Vcheck; use A4G.Vcheck; with Atree; use Atree; with Lib; use Lib; with Namet; use Namet; with Nlists; use Nlists; with Output; use Output; with Sinfo; use Sinfo; with Sinput; use Sinput; with Tree_In; package body A4G.Contt.TT is procedure Set_Nil_Tree_Names (T : Tree_Id); -- Sets all the fields related to Source File Name Table as indicating -- empty strings procedure Set_Nil_Tree_Attributes (T : Tree_Id); -- Sets all the attributes of T as if T is an ASIS Nil_Tree function Restore_Node_From_Trace (In_Body : Boolean := False) return Node_Id; -- Taking the node trace stored in Node_Trace table, tries to find the -- construct corresponding to the beginning of the trace in the currently -- accessed tree. By default we consider that we are in the package spec, -- unless In_Body is set ON. function Find_Enclosed_Decl (Scope : Node_Id; J : Int) return Node_Id; -- Starting from Scope, looks for the nested scope which is stored -- in Node_Trace table as Node_Trase.Table (J). Node, that expanded -- generic specs are considered as ordinary scopes. ------------------------- -- Allocate_Tree_Entry -- ------------------------- function Allocate_Tree_Entry return Tree_Id is New_Last : Tree_Id; -- the Id of the new entry being allocated in the Unit Table begin Tree_Table.Increment_Last; New_Last := Tree_Table.Last; Set_Nil_Tree_Names (New_Last); Set_Nil_Tree_Attributes (New_Last); Tree_Table.Table (New_Last).Tree_Name_Chars_Index := A_Name_Chars.Last; Tree_Table.Table (New_Last).Tree_Name_Len := Short (A_Name_Len); -- Set corresponding string entry in the Name_Chars table for I in 1 .. A_Name_Len loop A_Name_Chars.Increment_Last; A_Name_Chars.Table (A_Name_Chars.Last) := A_Name_Buffer (I); end loop; A_Name_Chars.Increment_Last; A_Name_Chars.Table (A_Name_Chars.Last) := ASCII.NUL; return New_Last; end Allocate_Tree_Entry; ------------------------------------------ -- Current_Tree_Consistent_With_Sources -- ------------------------------------------ function Current_Tree_Consistent_With_Sources return Boolean is Result : Boolean := True; Source_Stamp : Time_Stamp_Type; Tree_Stamp : Time_Stamp_Type; Source : File_Name_Type; begin for J in 2 .. Last_Source_File loop -- We start from 2, because the entry 1 in the Source File Table -- is always for system.ads (see Sinput, spec). Tree_Stamp := Time_Stamp (J); Source := Full_File_Name (J); Get_Name_String (Source); Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := ASCII.NUL; if not Is_Regular_File (Name_Buffer) then -- The source file was (re)moved Result := False; exit; else Source_Stamp := TS_From_OS_Time (File_Time_Stamp (Name_Buffer)); if Source_Stamp /= Tree_Stamp then -- The source file has been changed Result := False; exit; end if; end if; end loop; return Result; end Current_Tree_Consistent_With_Sources; ------------------------ -- Find_Enclosed_Decl -- ------------------------ function Find_Enclosed_Decl (Scope : Node_Id; J : Int) return Node_Id is Result : Node_Id := Empty; List_To_Search : List_Id; Kind_To_Search : constant Node_Kind := Node_Trace.Table (J).Kind; Line_To_Search : constant Physical_Line_Number := Node_Trace.Table (J).Node_Line; Col_To_Search : constant Column_Number := Node_Trace.Table (J).Node_Col; function Check_Node (N : Node_Id) return Traverse_Result; -- Check if N is the needed node. If it is, Sets Result equial to N and -- returns Abandon. Othervise returns OK. function Find_In_List (L : List_Id) return Node_Id; -- Looks for the needed scope in a node list procedure Traverse_Scope is new Atree.Traverse_Proc (Process => Check_Node); function Check_Node (N : Node_Id) return Traverse_Result is N_Sloc : Source_Ptr; Traverse_Res : Traverse_Result := OK; begin if Nkind (N) = Kind_To_Search then N_Sloc := Sloc (N); if Get_Physical_Line_Number (N_Sloc) = Line_To_Search and then Get_Column_Number (N_Sloc) = Col_To_Search then Result := N; Traverse_Res := Abandon; end if; end if; return Traverse_Res; end Check_Node; function Find_In_List (L : List_Id) return Node_Id is Res : Node_Id := Empty; Next_Node : Node_Id; Next_Sloc : Source_Ptr; begin Next_Node := First_Non_Pragma (L); while Present (Next_Node) loop if Nkind (Next_Node) = Kind_To_Search then Next_Sloc := Sloc (Next_Node); if Get_Physical_Line_Number (Next_Sloc) = Line_To_Search and then Get_Column_Number (Next_Sloc) = Col_To_Search then Res := Next_Node; exit; end if; end if; Next_Node := Next_Non_Pragma (Next_Node); end loop; return Res; end Find_In_List; begin if Nkind (Scope) = N_Package_Instantiation then Result := Scope; while Nkind (Result) /= N_Package_Declaration loop Result := Prev_Non_Pragma (Result); end loop; return Result; end if; if Nkind (Scope) = N_Package_Body or else Nkind (Scope) = N_Subprogram_Body or else Nkind (Scope) = N_Block_Statement then List_To_Search := Sinfo.Declarations (Scope); else List_To_Search := Visible_Declarations (Scope); end if; Result := Find_In_List (List_To_Search); if No (Result) then if Nkind (Scope) = N_Package_Specification then List_To_Search := Private_Declarations (Scope); Result := Find_In_List (List_To_Search); if No (Result) and then Nkind (Parent (Scope)) = N_Generic_Package_Declaration then List_To_Search := Generic_Formal_Declarations (Parent (Scope)); Result := Find_In_List (List_To_Search); end if; elsif Nkind (Scope) = N_Block_Statement or else Nkind (Scope) = N_Subprogram_Body then -- We can have an instantiation nested in some block statement in -- tne library subprogram body. This should not happen too often, -- so we can use this performance-expensive approach here. Traverse_Scope (Scope); end if; end if; pragma Assert (Present (Result)); return Result; end Find_Enclosed_Decl; ------------------- -- Get_Tree_Name -- ------------------- function Get_Tree_Name (C : Context_Id; Id : Tree_Id) return String is begin Get_Name_String (C, Id); return A_Name_Buffer (1 .. A_Name_Len); end Get_Tree_Name; ----------------------------- -- Restore_Node_From_Trace -- ----------------------------- function Restore_Node_From_Trace (In_Body : Boolean := False) return Node_Id is Start_Node : Node_Id; Result : Node_Id := Empty; begin Start_Node := Unit (Cunit (Main_Unit)); if Nkind (Start_Node) = N_Package_Body and then not In_Body then Start_Node := Corresponding_Spec (Start_Node); while not (Nkind (Start_Node) = N_Package_Declaration or else Nkind (Start_Node) = N_Generic_Package_Declaration) loop Start_Node := Parent (Start_Node); end loop; end if; if Node_Trace.First = Node_Trace.Last then -- One-element trace means, that we have a library-level package -- instantiation Result := Start_Node; else if Nkind (Start_Node) = N_Package_Declaration or else Nkind (Start_Node) = N_Generic_Package_Declaration then Start_Node := Specification (Start_Node); end if; for J in reverse Node_Trace.First + 1 .. Node_Trace.Last - 1 loop Start_Node := Find_Enclosed_Decl (Start_Node, J); if Nkind (Start_Node) = N_Package_Declaration or else Nkind (Start_Node) = N_Generic_Package_Declaration then Start_Node := Specification (Start_Node); end if; end loop; Result := Find_Enclosed_Decl (Start_Node, Node_Trace.First); end if; pragma Assert (Present (Result)); return Result; end Restore_Node_From_Trace; --------------------- -- Get_Name_String -- --------------------- procedure Get_Name_String (C : Context_Id; Id : Tree_Id) is S : Int; L : Short; begin Reset_Context (C); -- ??? S := Tree_Table.Table (Id).Tree_Name_Chars_Index; L := Tree_Table.Table (Id).Tree_Name_Len; A_Name_Len := Natural (L); for I in 1 .. A_Name_Len loop A_Name_Buffer (I) := A_Name_Chars.Table (S + Int (I)); end loop; end Get_Name_String; ----------------- -- Print_Trees -- ----------------- procedure Print_Trees (C : Context_Id) is begin Write_Str ("Tree Table for Context number: "); Write_Int (Int (C)); Write_Eol; if C = Non_Associated then Write_Str (" Nil Context, it can never be associated "); Write_Str ("with any tree"); Write_Eol; return; end if; if Is_Opened (C) then for Tr in First_Tree_Id .. Last_Tree (C) loop Output_Tree (C, Tr); end loop; Write_Eol; else Write_Str ("This Context is closed"); Write_Eol; end if; end Print_Trees; ----------------------------- -- Set_Nil_Tree_Attributes -- ----------------------------- procedure Set_Nil_Tree_Attributes (T : Tree_Id) is begin Set_Main_Unit_Id (T, Nil_Unit); Set_Main_Top (T, Empty); Tree_Table.Table (T).Units := No_Elist; end Set_Nil_Tree_Attributes; ------------------------ -- Set_Nil_Tree_Names -- ------------------------ procedure Set_Nil_Tree_Names (T : Tree_Id) is Tr : constant Tree_Id := T; begin Tree_Table.Table (Tr).Tree_Name_Chars_Index := 0; Tree_Table.Table (Tr).Tree_Name_Len := 0; end Set_Nil_Tree_Names; --------------------------------------------------------------- -- Internal Tree Unit Attributes Access and Update Routines -- --------------------------------------------------------------- function Main_Unit_Id (T : Tree_Id) return Unit_Id is begin return Tree_Table.Table (T).Main_Unit; end Main_Unit_Id; function Main_Unit_Id return Unit_Id is begin return Tree_Table.Table (Current_Tree).Main_Unit; end Main_Unit_Id; procedure Set_Main_Unit_Id (T : Tree_Id; U : Unit_Id) is begin Tree_Table.Table (T).Main_Unit := U; end Set_Main_Unit_Id; procedure Set_Main_Top (T : Tree_Id; N : Node_Id) is begin Tree_Table.Table (T).Main_Top := N; end Set_Main_Top; procedure Set_Main_Unit_Id (U : Unit_Id) is begin Tree_Table.Table (Current_Tree).Main_Unit := U; end Set_Main_Unit_Id; procedure Set_Main_Top (N : Node_Id) is begin Tree_Table.Table (Current_Tree).Main_Top := N; end Set_Main_Top; ----------------------------------- -- Subprograms for Tree Swapping -- ----------------------------------- ------------------------- -- Append_Tree_To_Unit -- ------------------------- procedure Append_Tree_To_Unit (C : Context_Id; U : Unit_Id) is begin Reset_Context (C); Add_To_Elmt_List (Unit_Id (Current_Tree), Unit_Table.Table (U).Trees); end Append_Tree_To_Unit; ------------------- -- Reorder_Trees -- ------------------- procedure Reorder_Trees (C : Context_Id) is Main_Unit : Unit_Id; -- The unit which main tree should be moved to the first position in -- the list of trees for the unit being processed in a loop First_Tree : Tree_Id; Success : Boolean; C_Mode : constant Context_Mode := Context_Processing_Mode (C); begin for U in First_Unit_Id + 1 .. Last_Unit loop -- First_Unit_Id corresponds to Standard Success := True; Main_Unit := Nil_Unit; case Kind (C, U) is when A_Subunit => -- (1) Main_Unit := Get_Subunit_Parent_Body (C, U); while Kind (C, Main_Unit) in A_Subunit loop Main_Unit := Get_Subunit_Parent_Body (C, Main_Unit); end loop; if No (Main_Tree (C, Main_Unit)) then if C_Mode in Partition .. All_Trees then Get_Name_String (U, Ada_Name); ASIS_Warning (Message => "Asis.Ada_Environments.Open: " & "ancestor body is not compiled for subunit " & A_Name_Buffer (1 .. A_Name_Len), Error => Data_Error); end if; Success := False; end if; when A_Package | A_Generic_Package | A_Procedure | A_Function | A_Generic_Procedure | A_Generic_Function => -- (2), (3) and (5) if Is_Body_Required (C, U) or else Kind (C, U) = A_Procedure or else Kind (C, U) = A_Function or else Kind (C, U) = A_Generic_Procedure or else Kind (C, U) = A_Generic_Function then -- (2) and (5) Main_Unit := Get_Body (C, U); if No (Main_Unit) or else No (Main_Tree (C, Main_Unit)) then -- The second condition corresponds to the situation when -- the tree is created for library-level generic spec -- which requires the body if C_Mode in Partition .. All_Trees and then Origin (C, U) = An_Application_Unit then Get_Name_String (U, Ada_Name); ASIS_Warning (Message => "Asis.Ada_Environments.Open: " & "body is not compiled for " & A_Name_Buffer (1 .. A_Name_Len), Error => Data_Error); end if; Success := False; end if; else -- (3) Main_Unit := U; if No (Main_Tree (C, Main_Unit)) then -- We do not generate any warning in this case, because -- we do not know whether or not this package -- declaration has to be compiled on its own. So we only -- set Success OFF to prevent any change in the tree -- list Success := False; end if; end if; when A_Generic_Unit_Instance => -- (4) Main_Unit := U; if No (Main_Tree (C, Main_Unit)) then if C_Mode in Partition .. All_Trees and then Origin (C, U) = An_Application_Unit then Get_Name_String (U, Ada_Name); ASIS_Warning (Message => "Asis.Ada_Environments.Open: " & "library-level instance " & A_Name_Buffer (1 .. A_Name_Len) & " is not compiled", Error => Data_Error); end if; Success := False; end if; when A_Library_Unit_Body => -- There are some situations when the body is compiled because -- the corresponding spec is a supporter of the main unit of -- the compilation. See Lib (spec), (h) Main_Unit := U; if No (Main_Tree (C, Main_Unit)) then -- We do notr generate a warning here - if needed, the -- warning is generated for the corresponding spec Success := False; end if; when others => null; end case; if Success and then Present (Main_Unit) then -- Here we have to reorder the trees for U. Currently the -- simplest solution is used - we just prepend the right tree -- to the tree list, if it is not already the first tree in -- the list. So this tree may be duplicated in the list. First_Tree := Main_Tree (C, Main_Unit); if First_Tree /= Tree_Id (Unit (First_Elmt (Unit_Table.Table (U).Trees))) then Prepend_Elmt (Unit_Id (First_Tree), Unit_Table.Table (U).Trees); end if; end if; end loop; end Reorder_Trees; ---------------- -- Reset_Tree -- ---------------- procedure Reset_Tree (Context : Context_Id; Tree : Tree_Id) is Tree_File_FD : File_Descriptor; File_Closed : Boolean := False; begin -- Special processing for GNSA mode: if Tree_Processing_Mode (Current_Context) = GNSA then -- This is no more then a workaround for -GNSA C1 Context when we -- have exactly one tree (and exactly one (GNSA) Context! return; end if; if Context = Current_Context and then Tree = Current_Tree then return; end if; if Debug_Flag_T then Write_Str ("In Context "); Write_Int (Int (Context)); Write_Str (" resetting the tree "); Write_Int (Int (Tree)); Write_Eol; end if; -- the following call to Reset_Context is redundant, because the next -- call to Get_Name_String also resets Context, but this is the right -- place for Reset_Context Reset_Context (Context); Get_Name_String (Context, Tree); -- should be always successful, because Tree may correspond only to -- some tree file, which has been investigated by ASIS A_Name_Buffer (A_Name_Len + 1) := ASCII.NUL; if Debug_Flag_T then Write_Str (" ("); Write_Str (A_Name_Buffer (1 .. A_Name_Len)); Write_Str (")"); Write_Eol; end if; Tree_File_FD := Open_Read (A_Name_Buffer'Address, Binary); if Tree_File_FD = Invalid_FD then Raise_ASIS_Failed (Diagnosis => "A4G.Contt.TT.Reset_Tree: " & "Cannot open tree file: " & A_Name_Buffer (1 .. A_Name_Len) & ASIS_Line_Terminator & "ASIS external environment may have been changed", Stat => Data_Error); end if; begin Tree_In (Tree_File_FD); exception when others => Close (Tree_File_FD, File_Closed); -- We did not chech File_Closed here, because the problem in -- Tree_In seems to be more important for ASIS Raise_ASIS_Failed (Diagnosis => "A4G.Contt.TT.Reset_Tree: " & "Can not read tree file: " & A_Name_Buffer (1 .. A_Name_Len) & ASIS_Line_Terminator & "ASIS external environment may have been changed", Stat => Data_Error); end; Close (Tree_File_FD, File_Closed); if not File_Closed then Raise_ASIS_Failed (Diagnosis => "A4G.Contt.TT.Reset_Tree: " & "Can not close tree file: " & A_Name_Buffer (1 .. A_Name_Len) & ASIS_Line_Terminator & "disk is full or file may be used by other program", Stat => Data_Error); end if; -- if we are here, then the required tree has been successfully -- re-retrieved. So: Current_Context := Context; Current_Tree := Tree; if Debug_Flag_T then Write_Str ("In Context "); Write_Int (Int (Context)); Write_Str (" the tree "); Write_Int (Int (Tree)); Write_Str (" has been reset"); Write_Eol; end if; end Reset_Tree; ----------------------------- -- Reset_Tree_For_Element -- ----------------------------- procedure Reset_Tree_For_Element (E : Asis.Element) is begin Reset_Tree (Encl_Cont_Id (E), Encl_Tree (E)); end Reset_Tree_For_Element; ------------------------- -- Reset_Tree_For_Unit -- ------------------------- procedure Reset_Tree_For_Unit (C : Context_Id; U : Unit_Id) is Tree_List : Elist_Id; Tree_To_Set : Tree_Id; begin -- Special processing for GNSA mode: if Tree_Processing_Mode (Get_Current_Cont) = GNSA then -- This is no more then a workaround for -GNSA C1 Context when we -- have exactly one tree (and exactly one (GNSA) Context! return; end if; Tree_List := Unit_Table.Table (U).Trees; -- it cannot be No_List or Empty_List! Tree_To_Set := Tree_Id (Unit (First_Elmt (Tree_List))); if Debug_Flag_T then Write_Str ("For unit "); Write_Int (Int (U)); Write_Str (" "); end if; Reset_Tree (Context => C, Tree => Tree_To_Set); end Reset_Tree_For_Unit; procedure Reset_Tree_For_Unit (Unit : Asis.Compilation_Unit) is begin Reset_Tree_For_Unit (Encl_Cont_Id (Unit), Get_Unit_Id (Unit)); end Reset_Tree_For_Unit; ------------------------- -- Reset_Instance_Tree -- ------------------------- procedure Reset_Instance_Tree (Lib_Level_Instance : Asis.Compilation_Unit; Decl_Node : in out Node_Id) is U : Unit_Id := Get_Unit_Id (Lib_Level_Instance); Tree_To_Set : Tree_Id; Curr_Context : constant Context_Id := Get_Current_Cont; Curr_Tree : constant Tree_Id := Get_Current_Tree; In_Body : Boolean := False; begin -- Special processing for GNSA mode: if Tree_Processing_Mode (Curr_Context) = GNSA then -- This is no more then a workaround for -GNSA C1 Context when we -- have exactly one tree (and exactly one (GNSA) Context! return; end if; Tree_To_Set := Unit_Table.Table (U).Main_Tree; if No (Tree_To_Set) then if Kind (Lib_Level_Instance) in A_Package .. A_Generic_Package or else Kind (Lib_Level_Instance) in A_Library_Unit_Body then U := Get_Body (Current_Context, U); if Tree_Processing_Mode (Curr_Context) = Incremental and then (No (U) or else No (Unit_Table.Table (U).Main_Tree)) then -- In this situation we try to compile the needed body on the -- fly if Is_Body_Required (Lib_Level_Instance) or else Kind (Lib_Level_Instance) in A_Library_Unit_Body then U := Get_Main_Unit_Tree_On_The_Fly (Start_Unit => Get_Unit_Id (Lib_Level_Instance), Cont => Curr_Context, Spec => False); else U := Get_Main_Unit_Tree_On_The_Fly (Start_Unit => Get_Unit_Id (Lib_Level_Instance), Cont => Curr_Context, Spec => True); end if; end if; elsif Kind (Lib_Level_Instance) in A_Generic_Unit_Instance and then Tree_Processing_Mode (Encl_Cont_Id (Lib_Level_Instance)) = Incremental then U := Get_Main_Unit_Tree_On_The_Fly (Start_Unit => Get_Unit_Id (Lib_Level_Instance), Cont => Curr_Context, Spec => True); end if; if Present (U) then Tree_To_Set := Unit_Table.Table (U).Main_Tree; Reset_Tree (Context => Get_Current_Cont, Tree => Curr_Tree); end if; end if; if No (Tree_To_Set) or else Tree_To_Set = Current_Tree then return; end if; Create_Node_Trace (Decl_Node); Reset_Tree (Context => Get_Current_Cont, Tree => Tree_To_Set); if Kind (Lib_Level_Instance) in A_Library_Unit_Body then In_Body := True; end if; Decl_Node := Restore_Node_From_Trace (In_Body); end Reset_Instance_Tree; ---------------------------------- -- Tree_Consistent_With_Sources -- ---------------------------------- function Tree_Consistent_With_Sources (E : Asis.Element) return Boolean is begin Reset_Tree (Encl_Cont_Id (E), Encl_Tree (E)); return Current_Tree_Consistent_With_Sources; end Tree_Consistent_With_Sources; function Tree_Consistent_With_Sources (CU : Asis.Compilation_Unit) return Boolean is begin Reset_Tree_For_Unit (CU); return Current_Tree_Consistent_With_Sources; end Tree_Consistent_With_Sources; -------------------------- -- Unit_In_Current_Tree -- -------------------------- function Unit_In_Current_Tree (C : Context_Id; U : Unit_Id) return Boolean is begin if U = Standard_Id then return True; end if; if Current_Context /= C then return False; end if; return In_Elmt_List (Unit_Id (Current_Tree), Unit_Table.Table (U).Trees); end Unit_In_Current_Tree; -------------------------------------------------- -- General-Purpose Tree Table Subprograms -- -------------------------------------------------- --------------- -- Last_Tree -- --------------- function Last_Tree (C : Context_Id) return Tree_Id is begin Reset_Context (C); return Tree_Table.Last; end Last_Tree; -------- -- No -- -------- function No (Tree : Tree_Id) return Boolean is begin return Tree = Nil_Tree; end No; ----------------- -- Output_Tree -- ----------------- procedure Output_Tree (C : Context_Id; Tree : Tree_Id) is begin -- ??? Check for Debug_Mode should be moved into the context(s) where -- ??? Output_Tree is called if Debug_Mode then Write_Str ("Debug output for Tree Id " & Tree_Id'Image (Tree)); Write_Eol; if Tree = Nil_Tree then Write_Str ("This is a Nil Tree"); Write_Eol; return; end if; Get_Name_String (C, Tree); Write_Str ("Tree File Name is: " & A_Name_Buffer (1 .. A_Name_Len)); Write_Eol; Write_Str ("Main Unit Id : "); Write_Str (Main_Unit_Id (Tree)'Img); Write_Eol; Write_Str ("The list of the Units contained in the tree:"); Write_Eol; Print_List (Tree_Table.Table (Tree).Units); Write_Eol; end if; end Output_Tree; ------------- -- Present -- ------------- function Present (Tree : Tree_Id) return Boolean is begin return Tree /= No_Tree_Name; end Present; end A4G.Contt.TT; asis-2010.orig/asis/a4g-contt-tt.ads0000644000175000017500000002776111574704441017075 0ustar lbrentalbrenta------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- A 4 G . C O N T T . T T -- -- -- -- S p e c -- -- -- -- Copyright (C) 1995-2008, Free Software Foundation, Inc. -- -- -- -- ASIS-for-GNAT 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 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 51 Franklin -- -- Street, Fifth Floor, Boston, MA 02110-1301, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by AdaCore. -- -- (http://www.adacore.com). -- -- -- ------------------------------------------------------------------------------ -- This package defines for each ASIS Context the corresponding Tree Table, -- which contains the information about the tree output files needed for -- handling and swapping the ASTs represented by the tree output files -- accessed by ASIS. with Asis; package A4G.Contt.TT is -- Context_Table.Tree_Tables ---------------- -- Tree Table -- ---------------- -- The tree table has an entry for each AST ( = tree output file) -- created and read at least once for this run of ASIS application. -- The entries in the table are accessing using a Tree_Id which -- ranges from Nil_Tree (a special value using for initializing -- ASIS Nil_Element and ASIS Nil_Compilation_Unit) to Last_Tree. -- Each entry has the following fields: --------------------- -- Tree Name Table -- --------------------- procedure Get_Name_String (C : Context_Id; Id : Tree_Id); -- Get_Name_String is used to retrieve the string associated with -- an entry in the name table. The resulting string is stored in -- Name_Buffer and Name_Len is set. function Get_Tree_Name (C : Context_Id; Id : Tree_Id) return String; -- Returns the full name of the tree file. function Allocate_Tree_Entry return Tree_Id; -- ##### -- Allocates the new entry in the Tree Table for the tree output file -- name stored in the A_Name_Buffer (A_Name_Len should be set -- in a proper way). ------------------------------ -- Internal Tree Attributes -- ------------------------------ -- Each Tree entry contains the following fields, representing the Tree -- attributes needed to organize tree processing inside ASIS -- implementation: -- Enclosing_Lib : Context_Id; --## -- Context Id of the ASIS Context for which the tree has been -- created. -- Main_Unit_Id : Unit_Id; -- The ASIS Compilation Unit, corresponding to the main unit in -- the tree -- Main_Top : Node_Id; -- The top node (having N_Compilation_Unit Node Kind) of Main_Unit -- Units : Elist_Id; -- The list of all the Units (or all the Units except Main_Unit?) -- which may be processed on the base of this tree, [each Unit -- is accompanied by its top node, which it has in the given tree -- ??? Not implemented for now!] --------------------------------------------------------------- -- Internal Tree Unit Attributes Access and Update Routines -- --------------------------------------------------------------- function Main_Unit_Id (T : Tree_Id) return Unit_Id; function Main_Unit_Id return Unit_Id; -- Returns the Id of the main unit in Current_Tree procedure Set_Main_Unit_Id (T : Tree_Id; U : Unit_Id); procedure Set_Main_Top (T : Tree_Id; N : Node_Id); -- Do we really need Set procedures having a Tree (and its "enclosing" -- Context) as a parameter? Now it seems, that all settings will be -- done for the currently accessing Tree only. procedure Set_Main_Unit_Id (U : Unit_Id); procedure Set_Main_Top (N : Node_Id); ----------------------------------- -- Subprograms for Tree Swapping -- ----------------------------------- function Unit_In_Current_Tree (C : Context_Id; U : Unit_Id) return Boolean; -- Checks if the subtree for a given Unit defined by C and U, is -- contained in the currently accessed tree. procedure Reset_Tree (Context : Context_Id; Tree : Tree_Id); -- Resets the currently accessed tree to the tree identified by -- the Context and Tree parameters procedure Reset_Tree_For_Unit (C : Context_Id; U : Unit_Id); procedure Reset_Tree_For_Unit (Unit : Asis.Compilation_Unit); -- Resets the currently accessed tree to some tree containing -- the subtree for a given unit. For now, there is no special -- strategy for choosing the tree among all the trees containing -- the given unit procedure Reset_Tree_For_Element (E : Asis.Element); -- Resets the currently accessed tree to the tree containing the node(s) -- of the argument Element. procedure Reset_Instance_Tree (Lib_Level_Instance : Asis.Compilation_Unit; Decl_Node : in out Node_Id); -- Given Lib_Level_Instance as ASIS Compilation Unit being a library-level -- instantiation, or a package or generic package containing -- an instantiation of some library-level generic unit, and Decl_Node as -- the node representing some declaration in the corresponding spec (which -- can be either expanded generics spec if Lib_Level_Instance is a library- -- level instantiation or a normal spec in case of a (generic) package); -- it is an error to call this procedure with other arguments), this -- procedure resets the currently accessed tree to the main tree for -- Lib_Level_Instance (it may be the tree created for the body of -- Lib_Level_Instance in case if Lib_Level_Instance is a package -- declaration) and resets Decl_Node to point to the same construct in -- this tree. -- -- If the corresponding ASIS Context does not contain the main tree for -- this library-level instantiation, the procedure does nothing. -- Also does nothing if Lib_Level_Instance is a package body procedure Append_Tree_To_Unit (C : Context_Id; U : Unit_Id); -- Appends the currently accessed tree to the list of the (consistent) -- trees containing a given Unit (this tree list belongs to the unit U). procedure Reorder_Trees (C : Context_Id); -- This procedure is called in the very end of opening the context C, when -- all the information is already set in the Context Unit table. It -- reorders the tree lists associated with units according to the -- following rules (note, that currently the first tree in the tree list -- is used by Element gateway queries to get into the unit structure: -- -- (1) for a subunit, the tree for its ancestor body is moved into the -- first position in the tree list; -- -- (2) for a package declaration or generic package declaration, if this -- package requires a body, the tree for the body is moved into the -- first position in the tree list; -- -- (3) for package or generic package declaration which does not require a -- body, the tree created for the given (generic) package is moved -- into the first position in the tree list; -- -- (4) for a library-level instantiation, the tree created for the -- instantiation is moved into the first position in the tree list; -- -- (5) for a (generic) subprogram declaration, the tree for the -- corresponding body is moved into the first position in the tree -- list; -- -- (6) for the bodies, we may also need to set the main tree first, because -- according to Lib (h), the body may be compiled as being needed for -- some spec (or other body unit) -- -- For -CA Context, if the tree to be moved into the first position in -- the tree list does not exist, the corresponding warning is generated, -- except if the corresponding unit is of A_Predefined_Unit or -- An_Implementation_Unit origin --------------------------------- -- General-Purpose Subprograms -- --------------------------------- function Present (Tree : Tree_Id) return Boolean; -- Tests given Tree Id for non-equality with No_Tree_Name. -- This allows notations like "if Present (Tree)" as opposed to -- "if Tree /= No_Tree_Name" function No (Tree : Tree_Id) return Boolean; -- Tests given Tree Id for equality with No_Tree_Name. This allows -- notations like "if No (Tree)" as opposed to -- "if Tree = No_Tree_Name" function Last_Tree (C : Context_Id) return Tree_Id; -- Returns the Tree_Id of the last tree which has been allocated -- in the Tree Table. procedure Output_Tree (C : Context_Id; Tree : Tree_Id); -- Produces the debug output of the Tree Table entry corresponding -- to Tree procedure Print_Trees (C : Context_Id); -- Produces the debug output from the Tree table for the Context C. function Tree_Consistent_With_Sources (E : Asis.Element) return Boolean; function Tree_Consistent_With_Sources (CU : Asis.Compilation_Unit) return Boolean; -- These functions are supposed to be used for Incremental Context mode. -- They check that the tree from which their argument Element or Unit has -- been obtained is still consistent with all the sources from which -- the tree was generated (and that all these sources are available) -- This function supposes that its argument is not null and that the tree -- to check is available. function Current_Tree_Consistent_With_Sources return Boolean; -- Checks that for the current tree all the sources from which it has been -- obtained are still available and that the tree is consistent with -- these sources. The caller is responsible for setting as the current -- tree the tree he would like to check end A4G.Contt.TT; asis-2010.orig/asis/a4g-contt-ut.adb0000644000175000017500000015275411574704441017056 0ustar lbrentalbrenta------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- A 4 G . C O N T T . U T -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- -- -- -- ASIS-for-GNAT 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 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 51 Franklin -- -- Street, Fifth Floor, Boston, MA 02110-1301, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by AdaCore. -- -- (http://www.adacore.com). -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; with Asis.Errors; use Asis.Errors; with Asis.Exceptions; use Asis.Exceptions; with Asis.Set_Get; use Asis.Set_Get; with A4G.A_Debug; use A4G.A_Debug; with A4G.Contt.Dp; use A4G.Contt.Dp; with A4G.Contt.TT; use A4G.Contt.TT; with A4G.Vcheck; use A4G.Vcheck; with Atree; use Atree; with Einfo; use Einfo; with Lib; with Namet; use Namet; with Output; use Output; with Sinfo; use Sinfo; with Sinput; use Sinput; with Snames; use Snames; with Table; package body A4G.Contt.UT is ----------------------------------------- -- Local Subprograms (general-purpose) -- ----------------------------------------- function Allocate_New_Entry (C : Context_Id) return Unit_Id; -- allocates and returns a new entry in the Context Unit table -- No setting or any other changes are done procedure Set_Nil_Unit_Names (U : Unit_Id); -- Sets all the fields related to Unit Name Table as indicating empty -- strings -- The body is in "Unit Name Table Data and Subprograms" section procedure Set_Nil_Unit_Attributes (C : Context_Id; U : Unit_Id); -- Sets all the attributes, dependency lists and tree lists of U as -- if U is an ASIS Nil_Compilation_Unit. -- The body is in "Black-Box Unit Attributes Routines" section procedure Set_No_Source_File (U : Unit_Id); -- Makes settings corresponding to the absence of the source file -- name function Same_Names return Boolean; -- Compares the contents of the ASIS and GNAT Name Buffers. procedure Make_Unit_Name; -- Supposing that A_Name_Buffer contains the normalized name of a -- nonexistent unit (with a suffix ending with 'n', this procedure -- sets the content of A_Name_Buffer as equal to the Ada name of -- this nonexistent unit function Is_Spec (U : Unit_Id) return Boolean; -- Checks if U denotes a unit that is a library_unit_declaration function Get_Unit_Id_List (List : Elist_Id) return Unit_Id_List; -- Transforms the unit list into one-dimensional array of unit Ids. -- Returns Nil_Unit_Id_List for No_Elist function Absolute_Full_File_Name return Boolean; -- Checks that a source file name currently contained in the GNAT Name -- Table contains directory information in an absolute form type Top_Node_Rec is record Tree : Tree_Id; Top_Node : Node_Id; end record; package Top_Node_Cache is new Table.Table ( Table_Component_Type => Top_Node_Rec, Table_Index_Type => Unit_Id, Table_Low_Bound => First_Unit_Id, Table_Initial => 1000, Table_Increment => 100, Table_Name => "Top Node Cache"); -- Used to cache the already computed results of the Top function ----------------------------- -- Absolute_Full_File_Name -- ----------------------------- function Absolute_Full_File_Name return Boolean is Result : Boolean := False; begin if Namet.Name_Buffer (1) /= '.' then for I in 1 .. Namet.Name_Len loop if Namet.Name_Buffer (I) = '/' or else Namet.Name_Buffer (I) = '\' then Result := True; exit; end if; end loop; end if; return Result; end Absolute_Full_File_Name; ------------------------ -- Allocate_New_Entry -- ------------------------ function Allocate_New_Entry (C : Context_Id) return Unit_Id is Hash_Index : Hash_Index_Type; -- Computed hash index Curr_Id : Unit_Id; -- Id of entries in hash chain, if any New_Last : Unit_Id; -- the Id of the new entry being allocated in the Unit Table begin Hash_Index := Hash; Curr_Id := Contexts.Table (C).Hash_Table (Hash_Index); Unit_Table.Increment_Last; New_Last := Unit_Table.Last; -- correcting the hash chain, if any if Curr_Id = No_Unit_Id then Contexts.Table (C).Hash_Table (Hash_Index) := New_Last; -- no hash chain to correct else while Unit_Table.Table (Curr_Id).Hash_Link /= No_Unit_Id loop Curr_Id := Unit_Table.Table (Curr_Id).Hash_Link; end loop; -- now Curr_Id is the last entry in the hash chain Unit_Table.Table (Curr_Id).Hash_Link := New_Last; end if; return New_Last; end Allocate_New_Entry; ------------------------------------- -- Allocate_Nonexistent_Unit_Entry -- ------------------------------------- function Allocate_Nonexistent_Unit_Entry (C : Context_Id) return Unit_Id is New_Unit_Id : Unit_Id; begin -- first we should modify the normalized unit name to make it the -- name of a nonexistent unit: A_Name_Len := A_Name_Len + 1; A_Name_Buffer (A_Name_Len) := 'n'; if Debug_Flag_O or else Debug_Lib_Model or else Debug_Mode then Write_Str ("Allocating new nonexistent unit: "); Write_Str (A_Name_Buffer (1 .. A_Name_Len)); Write_Eol; Write_Eol; end if; -- DO WE REALLY NEED A SPECIAL SUFFIX FOR THE NAMES OF NONEXISTENT -- UNITS ??? New_Unit_Id := Allocate_New_Entry (C); Set_Nil_Unit_Names (New_Unit_Id); Set_Nil_Unit_Attributes (C, New_Unit_Id); Set_Norm_Ada_Name (New_Unit_Id); if A_Name_Buffer (A_Name_Len - 1) = 'b' then Set_Kind (C, New_Unit_Id, A_Nonexistent_Body); else Set_Kind (C, New_Unit_Id, A_Nonexistent_Declaration); end if; Make_Unit_Name; Set_Ada_Name (New_Unit_Id); return New_Unit_Id; end Allocate_Nonexistent_Unit_Entry; ------------------------- -- Allocate_Unit_Entry -- ------------------------- function Allocate_Unit_Entry (C : Context_Id) return Unit_Id is New_Unit_Id : Unit_Id; begin New_Unit_Id := Allocate_New_Entry (C); Set_Nil_Unit_Names (New_Unit_Id); Set_Nil_Unit_Attributes (C, New_Unit_Id); Set_Norm_Ada_Name (New_Unit_Id); if A_Name_Buffer (A_Name_Len) = 's' then Contexts.Table (C).Specs := Contexts.Table (C).Specs + 1; elsif A_Name_Buffer (A_Name_Len) = 'b' then Contexts.Table (C).Bodies := Contexts.Table (C).Bodies + 1; end if; if Debug_Mode then Write_Str ("Allocate_Unit_Entry: in context "); Write_Int (Int (C)); Write_Str (" unit "); Write_Int (Int (New_Unit_Id)); Write_Str (" is allocated..."); Write_Eol; end if; return New_Unit_Id; end Allocate_Unit_Entry; ----------------------- -- Already_Processed -- ----------------------- function Already_Processed (C : Context_Id; U : Unit_Id) return Boolean is begin return Kind (C, U) /= Not_A_Unit; end Already_Processed; ----------------------- -- Check_Consistency -- ----------------------- procedure Check_Consistency (C : Context_Id; U_Id : Unit_Id; U_Num : Unit_Number_Type) is Old_Stamp : Time_Stamp_Type; New_Stamp : Time_Stamp_Type; C_Tree_Mode : constant Tree_Mode := Tree_Processing_Mode (C); Tmp : Elmt_Id; Unit_Is_Older : Boolean; begin Old_Stamp := Time_Stamp (C, U_Id); New_Stamp := Sinput.Time_Stamp (Lib.Source_Index (U_Num)); if not (Old_Stamp = New_Stamp) then -- note, this is "=" explicitly defied in Types Unit_Is_Older := New_Stamp > Old_Stamp; if C_Tree_Mode = Incremental then raise Inconsistent_Incremental_Context; else -- There is a special case that requires a specific diagnostic -- message - (re)compilation of another version of System -- (See D617-017) Get_Name_String (U_Id, Norm_Ada_Name); if A_Name_Buffer (1 .. A_Name_Len) = "system%s" then Raise_ASIS_Failed (Diagnosis => "Asis.Ada_Environments.Open - " & "System is recompiled", Stat => Use_Error); else -- Generate the full details about detected inconsistency. Set_Standard_Error; Write_Str ("Different versions of unit "); Get_Name_String (U_Id, Ada_Name); Write_Str (A_Name_Buffer (1 .. A_Name_Len)); Write_Eol; Write_Str ("(source file "); Get_Name_String (U_Id, Ref_File_Name); Write_Str (A_Name_Buffer (1 .. A_Name_Len) & ")"); Write_Eol; Write_Str ("used to create the following tree files:"); Write_Eol; if Unit_Is_Older then Write_Str ("Older version used for:"); Write_Eol; else Write_Str ("Newer version used for:"); Write_Eol; end if; Tmp := First_Elmt (Unit_Table.Table (U_Id).Trees); while Present (Tmp) loop A4G.Contt.TT.Get_Name_String (C, Tree_Id (Unit (Tmp))); Write_Str (A_Name_Buffer (1 .. A_Name_Len)); Write_Eol; Tmp := Next_Elmt (Tmp); end loop; if Unit_Is_Older then Write_Str ("Newer version used for:"); Write_Eol; else Write_Str ("Older version used for:"); Write_Eol; end if; A4G.Contt.TT.Get_Name_String (C, Current_Tree); Write_Str (A_Name_Buffer (1 .. A_Name_Len)); Write_Eol; Set_Standard_Output; Raise_ASIS_Failed (Diagnosis => "Asis.Ada_Environments.Open - " & "a set of tree files is inconsistent", Stat => Use_Error); end if; end if; end if; end Check_Consistency; ------------------------------ -- Check_Source_Consistency -- ------------------------------ procedure Check_Source_Consistency (C : Context_Id; U_Id : Unit_Id) is Tree_Stamp : Time_Stamp_Type; Source_Stamp : Time_Stamp_Type; C_Source_Mode : constant Source_Mode := Source_Processing_Mode (C); C_Tree_Mode : constant Tree_Mode := Tree_Processing_Mode (C); Source_Status : Source_File_Statuses := No_File_Status; begin Get_Name_String (U_Id, Source_File_Name); A_Name_Len := A_Name_Len + 1; A_Name_Buffer (A_Name_Len) := ASCII.NUL; if Is_Regular_File (A_Name_Buffer) then Source_Stamp := TS_From_OS_Time (File_Time_Stamp (A_Name_Buffer)); Tree_Stamp := Time_Stamp (C, U_Id); if Source_Stamp > Tree_Stamp then Source_Status := Newer; elsif Source_Stamp < Tree_Stamp then Source_Status := Older; else Source_Status := Up_To_Date; end if; else Source_Status := Absent; end if; Set_Source_Status (C, U_Id, Source_Status); if C_Source_Mode = All_Sources and then Source_Status = Absent then if C_Tree_Mode = Incremental then raise Inconsistent_Incremental_Context; else Set_Error_Status (Status => Asis.Errors.Use_Error, Diagnosis => "Asis.Ada_Environments.Open - source file " & A_Name_Buffer (1 .. A_Name_Len - 1) & " does not exist"); raise ASIS_Failed; end if; end if; if (C_Source_Mode = All_Sources or else C_Source_Mode = Existing_Sources) and then (Source_Status = Newer or else Source_Status = Older) then if C_Tree_Mode = Incremental then raise Inconsistent_Incremental_Context; else Set_Error_Status (Status => Asis.Errors.Use_Error, Diagnosis => "Asis.Ada_Environments.Open - source file " & A_Name_Buffer (1 .. A_Name_Len - 1) & " is inconsistent with a tree file " & Get_Tree_Name (C, Current_Tree)); raise ASIS_Failed; end if; end if; end Check_Source_Consistency; -------------------- -- Enclosing_Unit -- -------------------- function Enclosing_Unit (Cont : Context_Id; Node : Node_Id) return Asis.Compilation_Unit is Current_Node : Node_Id := Node; Result_Unit_Id : Unit_Id := Nil_Unit; Success : Boolean := False; begin -- First, correct Current_Node in case if itreresents the defining -- operator of implicitly declared "/=" (as a consequence of explicit -- "=" definition if Nkind (Current_Node) = N_Defining_Operator_Symbol and then not Comes_From_Source (Current_Node) and then Chars (Current_Node) = Name_Op_Ne and then Present (Corresponding_Equality (Current_Node)) then Current_Node := Corresponding_Equality (Current_Node); end if; -- Then, checking if we are or are not in the package Standard: if Sloc (Node) <= Standard_Location then Result_Unit_Id := Standard_Id; else -- we are not in the package Standard here, therefore we have to -- find the top node of the enclosing subtree: while not (Nkind (Current_Node) = N_Compilation_Unit) loop pragma Assert (Present (Parent (Current_Node))); Current_Node := Parent (Current_Node); end loop; if Is_Rewrite_Substitution (Unit (Current_Node)) and then Is_Rewrite_Substitution (Original_Node (Unit (Current_Node))) and then Nkind (Original_Node (Unit (Current_Node))) = N_Package_Body then -- This corresponds to the situation when a library-level -- instantiation is a supporter of a main unit, and the expanded -- body of this instantiation is required according to Lib (h). -- (See 7523-A19, 7624-A06 9418-015 and 9416-A01). In this case we -- Have to go to the compilation unit created for the -- instantiation Current_Node := Library_Unit (Current_Node); end if; -- now - getting the normalized unit name Namet.Get_Decoded_Name_String (Lib.Unit_Name ( Lib.Get_Cunit_Unit_Number (Current_Node))); Set_Norm_Ada_Name_String_With_Check (Lib.Get_Cunit_Unit_Number (Current_Node), Success); if not Success then -- This means, that we most probably are in the unit created for -- expanded package spec in case of library-level package -- instantiation, ASIS skips such units and processes only -- units rooted by expanded bodies, so let's try this Current_Node := Unit (Current_Node); pragma Assert (Nkind (Current_Node) = N_Package_Declaration and then not Comes_From_Source (Current_Node)); Current_Node := Corresponding_Body (Current_Node); if Nkind (Parent (Current_Node)) = N_Defining_Program_Unit_Name then Current_Node := Parent (Current_Node); end if; Current_Node := Parent (Parent (Current_Node)); Set_Norm_Ada_Name_String_With_Check (Lib.Get_Cunit_Unit_Number (Current_Node), Success); end if; if Success then Result_Unit_Id := Name_Find (Cont); end if; end if; if No (Result_Unit_Id) then raise Internal_Implementation_Error; else return Get_Comp_Unit (Result_Unit_Id, Cont); end if; end Enclosing_Unit; ---------------------- -- Form_Parent_Name -- ---------------------- procedure Form_Parent_Name is New_Len : Integer := 0; begin for I in reverse 1 .. A_Name_Len loop if A_Name_Buffer (I) = '.' then New_Len := I; exit; end if; end loop; A_Name_Len := New_Len; if A_Name_Len = 0 then return; end if; A_Name_Buffer (A_Name_Len) := '%'; A_Name_Len := A_Name_Len + 1; A_Name_Buffer (A_Name_Len) := 's'; end Form_Parent_Name; --------------------- -- Get_Name_String -- --------------------- procedure Get_Name_String (Id : Unit_Id; Col : Column) is S : Int; L : Short; begin case Col is when Ada_Name => S := Unit_Table.Table (Id).Ada_Name_Chars_Index; L := Unit_Table.Table (Id).Ada_Name_Len; when Norm_Ada_Name => S := Unit_Table.Table (Id).Norm_Ada_Name_Chars_Index; L := Unit_Table.Table (Id).Norm_Ada_Name_Len; when Source_File_Name => S := Unit_Table.Table (Id).File_Name_Chars_Index; L := Unit_Table.Table (Id).File_Name_Len; when Ref_File_Name => S := Unit_Table.Table (Id).Ref_Name_Chars_Index; L := Unit_Table.Table (Id).Ref_Name_Len; end case; A_Name_Len := Natural (L); for I in 1 .. A_Name_Len loop A_Name_Buffer (I) := A_Name_Chars.Table (S + Int (I)); end loop; end Get_Name_String; ----------------- -- Get_Subunit -- ----------------- function Get_Subunit (Parent_Body : Asis.Compilation_Unit; Stub_Node : Node_Id) return Asis.Compilation_Unit is Def_S_Name : Node_Id; Arg_Unit_Id : constant Unit_Id := Get_Unit_Id (Parent_Body); Result_Unit_Id : Unit_Id; Result_Cont_Id : constant Context_Id := Encl_Cont_Id (Parent_Body); begin Get_Name_String (Arg_Unit_Id, Norm_Ada_Name); if Nkind (Stub_Node) = N_Subprogram_Body_Stub then Def_S_Name := Defining_Unit_Name (Specification (Stub_Node)); else Def_S_Name := Defining_Identifier (Stub_Node); end if; Append_Subunit_Name (Def_S_Name); -- Now we have a name of a subunit in A_Name_Buffer. Let's try -- to find this subunit out: Result_Unit_Id := Name_Find (Result_Cont_Id); return Get_Comp_Unit (Result_Unit_Id, Result_Cont_Id); end Get_Subunit; ---------------------- -- Get_Unit_Id_List -- ---------------------- function Get_Unit_Id_List (List : Elist_Id) return Unit_Id_List is Res_Len : Natural; Next_Element : Elmt_Id; begin if No (List) then return Nil_Unit_Id_List; end if; Res_Len := List_Length (List); declare Result : Unit_Id_List (1 .. Res_Len); begin Next_Element := First_Elmt (List); for I in 1 .. Res_Len loop Result (I) := Unit (Next_Element); Next_Element := Next_Elmt (Next_Element); end loop; return Result; end; end Get_Unit_Id_List; ----------------------------------- -- GNAT_Compilation_Dependencies -- ----------------------------------- function GNAT_Compilation_Dependencies (U : Unit_Id) return Unit_Id_List is begin return Get_Unit_Id_List (Unit_Table.Table (U).Compilation_Dependencies); end GNAT_Compilation_Dependencies; ------------- -- Is_Spec -- ------------- function Is_Spec (U : Unit_Id) return Boolean is begin Get_Name_String (U, Norm_Ada_Name); -- The second condition is needed to filter out -- A_Configuration_Compiation unit having the name -- "__configuration_compilation%s" return A_Name_Buffer (A_Name_Len) = 's' and then A_Name_Buffer (1) /= '_'; end Is_Spec; -------------------- -- Length_Of_Name -- -------------------- function Length_Of_Name (Id : Unit_Id; Col : Column) return Nat is L : Short; begin case Col is when Ada_Name => L := Unit_Table.Table (Id).Ada_Name_Len; when Norm_Ada_Name => L := Unit_Table.Table (Id).Norm_Ada_Name_Len; when Source_File_Name => L := Unit_Table.Table (Id).File_Name_Len; when Ref_File_Name => L := Unit_Table.Table (Id).Ref_Name_Len; end case; return Nat (L); end Length_Of_Name; -------------------- -- Make_Unit_Name -- -------------------- procedure Make_Unit_Name is begin -- getting rid of the suffix: A_Name_Len := A_Name_Len - 3; A_Name_Buffer (1) := Ada.Characters.Handling.To_Upper (A_Name_Buffer (1)); -- "normalizing" the name: for I in 1 .. A_Name_Len - 1 loop if A_Name_Buffer (I) = '.' or else A_Name_Buffer (I) = '_' then A_Name_Buffer (I + 1) := Ada.Characters.Handling.To_Upper (A_Name_Buffer (I + 1)); end if; end loop; end Make_Unit_Name; --------------- -- Name_Find -- --------------- -- The code has been borrowed from the GNAT Namet package. The quick -- search for one character names was removed and allocating of a new -- entry in case when no name has been found is changed to returning -- Nil_Unit function Name_Find (C : Context_Id) return Unit_Id is New_Id : Unit_Id; -- Id of entry in hash search, and value to be returned S : Int; -- Pointer into string table Hash_Index : Hash_Index_Type; -- Computed hash index begin Hash_Index := Hash; New_Id := Contexts.Table (C).Hash_Table (Hash_Index); if New_Id = No_Unit_Id then return Nil_Unit; else Search : loop if A_Name_Len /= Integer (Unit_Table.Table (New_Id).Norm_Ada_Name_Len) then goto No_Match; end if; S := Unit_Table.Table (New_Id).Norm_Ada_Name_Chars_Index; for I in 1 .. A_Name_Len loop if A_Name_Chars.Table (S + Int (I)) /= A_Name_Buffer (I) then goto No_Match; end if; end loop; return New_Id; -- Current entry in hash chain does not match <> if Unit_Table.Table (New_Id).Hash_Link /= No_Unit_Id then New_Id := Unit_Table.Table (New_Id).Hash_Link; else exit Search; end if; end loop Search; end if; -- We fall through here only if a matching entry was not found in the -- hash table. -- In the GNAT Name Table a new entry in the names table is created, -- but we simply return Nil_Unit. Remember, we will have to -- maintain the consistency of hash links when we will allocate -- the new entry for the newly successfully compiled ASIS Compilation -- Unit. return Nil_Unit; end Name_Find; ----------------- -- Reset_Cache -- ----------------- procedure Reset_Cache is begin for U in First_Unit_Id .. Top_Node_Cache.Last loop Top_Node_Cache.Table (U).Tree := Nil_Tree; end loop; end Reset_Cache; ------------------ -- Set_Ada_Name -- ------------------ procedure Set_Ada_Name (Id : Unit_Id) is begin -- Set the values of Ada_Name_Chars_Index and Ada_Name_Len Unit_Table.Table (Id).Ada_Name_Chars_Index := A_Name_Chars.Last; Unit_Table.Table (Id).Ada_Name_Len := Short (A_Name_Len); -- Set corresponding string entry in the Name_Chars table for I in 1 .. A_Name_Len loop A_Name_Chars.Increment_Last; A_Name_Chars. Table (A_Name_Chars.Last) := A_Name_Buffer (I); end loop; A_Name_Chars.Increment_Last; A_Name_Chars.Table (A_Name_Chars.Last) := ASCII.NUL; end Set_Ada_Name; ------------------------ -- Set_Nil_Unit_Names -- ------------------------ procedure Set_Nil_Unit_Names (U : Unit_Id) is Unit : constant Unit_Id := U; begin Unit_Table.Table (Unit).Ada_Name_Chars_Index := 0; Unit_Table.Table (Unit).Norm_Ada_Name_Chars_Index := 0; Unit_Table.Table (Unit).File_Name_Chars_Index := 0; Unit_Table.Table (Unit).Ada_Name_Len := 0; Unit_Table.Table (Unit).Norm_Ada_Name_Len := 0; Unit_Table.Table (Unit).File_Name_Len := 0; Unit_Table.Table (Unit).Ref_Name_Len := 0; Unit_Table.Table (Unit).Hash_Link := No_Unit_Id; end Set_Nil_Unit_Names; ----------------------- -- Set_Norm_Ada_Name -- ----------------------- procedure Set_Norm_Ada_Name (Id : Unit_Id) is begin -- Set the values of Norm_Ada_Name_Chars_Index and Norm_Ada_Name_Len Unit_Table.Table (Id).Norm_Ada_Name_Chars_Index := A_Name_Chars.Last; Unit_Table.Table (Id).Norm_Ada_Name_Len := Short (A_Name_Len); -- Set corresponding string entry in the Name_Chars table for I in 1 .. A_Name_Len loop A_Name_Chars.Increment_Last; A_Name_Chars. Table (A_Name_Chars.Last) := A_Name_Buffer (I); end loop; A_Name_Chars.Increment_Last; A_Name_Chars. Table (A_Name_Chars.Last) := ASCII.NUL; end Set_Norm_Ada_Name; ------------------------------ -- Set_Norm_Ada_Name_String -- ------------------------------ procedure Set_Norm_Ada_Name_String is begin A_Name_Len := Namet.Name_Len; A_Name_Buffer (1 .. A_Name_Len) := Namet.Name_Buffer (1 .. Namet.Name_Len); -- ??? The commented code caused problems for 7717-010 -- ??? We will keep it for a while in case of possible -- ??? regressions (18.05.2000) -- A_Name_Buffer (1 .. A_Name_Len) := Ada.Characters.Handling.To_Lower -- (Namet.Name_Buffer (1 .. Namet.Name_Len)); end Set_Norm_Ada_Name_String; ----------------------------------------- -- Set_Norm_Ada_Name_String_With_Check -- ----------------------------------------- procedure Set_Norm_Ada_Name_String_With_Check (Unit : Unit_Number_Type; Success : out Boolean) is Unit_Node : Node_Id; Unit_Node_Kind : Node_Kind; begin Set_Norm_Ada_Name_String; Success := True; Unit_Node := Sinfo.Unit (Lib.Cunit (Unit)); Unit_Node_Kind := Nkind (Unit_Node); if (Unit_Node_Kind = N_Package_Body or else Unit_Node_Kind = N_Package_Declaration) and then Nkind (Original_Node (Unit_Node)) in N_Generic_Instantiation then -- Unit created for library-level package or procedure instantiation -- It is a spec, but the compiler sets for it in the unit -- table suffix '%b' A_Name_Buffer (A_Name_Len) := 's'; elsif not Comes_From_Source (Unit_Node) then -- Unit created for expanded package spec in case of -- library-level package instantiation, we do not need it Success := False; end if; end Set_Norm_Ada_Name_String_With_Check; ------------------------ -- Set_No_Source_File -- ------------------------ procedure Set_No_Source_File (U : Unit_Id) is begin Unit_Table.Table (U).File_Name_Len := 0; Unit_Table.Table (U).Ref_Name_Len := 0; end Set_No_Source_File; -------------------------- -- Set_Source_File_Name -- -------------------------- procedure Set_Source_File_Name (Id : Unit_Id; Ref : Boolean := False) is begin -- Set the values of File_Name_Chars_Index and File_Name_Len if Ref then Unit_Table.Table (Id).Ref_Name_Chars_Index := A_Name_Chars.Last; Unit_Table.Table (Id).Ref_Name_Len := Short (A_Name_Len); else Unit_Table.Table (Id).File_Name_Chars_Index := A_Name_Chars.Last; Unit_Table.Table (Id).File_Name_Len := Short (A_Name_Len); end if; -- Set corresponding string entry in the Name_Chars table for I in 1 .. A_Name_Len loop A_Name_Chars.Increment_Last; A_Name_Chars. Table (A_Name_Chars.Last) := A_Name_Buffer (I); end loop; A_Name_Chars.Increment_Last; A_Name_Chars. Table (A_Name_Chars.Last) := ASCII.NUL; end Set_Source_File_Name; --------------------------------- -- Set_Ref_File_As_Source_File -- --------------------------------- procedure Set_Ref_File_As_Source_File (U : Unit_Id) is begin Unit_Table.Table (U).Ref_Name_Chars_Index := Unit_Table.Table (U).File_Name_Chars_Index; Unit_Table.Table (U).Ref_Name_Len := Unit_Table.Table (U).File_Name_Len; end Set_Ref_File_As_Source_File; ------------------------------ -- Set_Ref_File_Name_String -- ------------------------------ procedure Set_Ref_File_Name_String (U : Unit_Id) is Last_Dir_Separator : Natural := 0; begin if not Absolute_Full_File_Name then Get_Name_String (U, Source_File_Name); for I in reverse 1 .. A_Name_Len loop if A_Name_Buffer (I) = Directory_Separator then Last_Dir_Separator := I; exit; end if; end loop; end if; if Last_Dir_Separator > 0 and then not (Last_Dir_Separator = 2 and then A_Name_Buffer (1) = '.') then A_Name_Len := Last_Dir_Separator; else A_Name_Len := 0; end if; A_Name_Buffer (A_Name_Len + 1 .. A_Name_Len + Namet.Name_Len) := Namet.Name_Buffer (1 .. Namet.Name_Len); A_Name_Len := A_Name_Len + Namet.Name_Len; end Set_Ref_File_Name_String; -------------- -- Set_Unit -- -------------- procedure Set_Unit (C : Context_Id; U : Unit_Number_Type) is New_Unit : Unit_Id; begin New_Unit := Allocate_Unit_Entry (C); Set_Time_Stamp (C, New_Unit, Sinput.Time_Stamp (Lib.Source_Index (U))); Append_Tree_To_Unit (C, New_Unit); end Set_Unit; ---------------------------------------------- -- Black-Box Unit Attributes Routines -- ---------------------------------------------- ----------------------- -- Local Subprograms -- ----------------------- ------------------------------------------------ -- Unit Attributes Access and Update Routines -- ------------------------------------------------ function Top (U : Unit_Id) return Node_Id is Old_Last_Cache : Unit_Id; begin -- First, try to get the result from the cache if U <= Top_Node_Cache.Last and then Top_Node_Cache.Table (U).Tree = Get_Current_Tree then return Top_Node_Cache.Table (U).Top_Node; end if; -- we have to compute the top node of the unit on the base of the -- currently accessed tree. We are guaranteed here, that the currently -- accessed tree contains the subtree for a given Unit Get_Name_String (U, Norm_Ada_Name); -- and now we will compare it with the names of the units contained -- in the currently accessed tree for Current_Unit in Main_Unit .. Lib.Last_Unit loop Namet.Get_Decoded_Name_String (Lib.Unit_Name (Current_Unit)); -- Here we have to take into account, that in case of library -- level package instantiations, in the tree created for such -- an instantiation the main unit (corresponding to this -- instantiation) has suffix '%b', whereas in ASIS the corresponding -- normalized unit name has suffix '%s' if Current_Unit = Main_Unit and then Nkind (Original_Node (Sinfo.Unit (Lib.Cunit (Current_Unit)))) in N_Generic_Instantiation then Namet.Name_Buffer (Namet.Name_Len) := 's'; end if; if Same_Names then Old_Last_Cache := Top_Node_Cache.Last; if U > Old_Last_Cache then Top_Node_Cache.Set_Last (U); for J in Old_Last_Cache + 1 .. U - 1 loop Top_Node_Cache.Table (J).Tree := Nil_Tree; end loop; end if; Top_Node_Cache.Table (U).Top_Node := Lib.Cunit (Current_Unit); Top_Node_Cache.Table (U).Tree := Get_Current_Tree; return Lib.Cunit (Current_Unit); end if; end loop; -- we cannot be here! But if we are, the only cause may be some bug -- in ASIS implementation. So: raise Internal_Implementation_Error; end Top; function Kind (C : Context_Id; U : Unit_Id) return Unit_Kinds is begin Reset_Context (C); return Unit_Table.Table (U).Kind; end Kind; function Class (C : Context_Id; U : Unit_Id) return Unit_Classes is begin Reset_Context (C); return Unit_Table.Table (U).Class; end Class; function Origin (C : Context_Id; U : Unit_Id) return Unit_Origins is begin Reset_Context (C); return Unit_Table.Table (U).Origin; end Origin; function Is_Main_Unit (C : Context_Id; U : Unit_Id) return Boolean is begin Reset_Context (C); return Unit_Table.Table (U).Main_Unit; end Is_Main_Unit; function Is_Body_Required (C : Context_Id; U : Unit_Id) return Boolean is begin Reset_Context (C); return Unit_Table.Table (U).Is_Body_Required; end Is_Body_Required; function Time_Stamp (C : Context_Id; U : Unit_Id) return Time_Stamp_Type is begin Reset_Context (C); return Unit_Table.Table (U).Time_Stamp; end Time_Stamp; function Is_Consistent (C : Context_Id; U : Unit_Id) return Boolean is begin Reset_Context (C); return Unit_Table.Table (U).Is_Consistent; end Is_Consistent; function Source_Status (C : Context_Id; U : Unit_Id) return Source_File_Statuses is begin Reset_Context (C); return Unit_Table.Table (U).Source_File_Status; end Source_Status; function Main_Tree (C : Context_Id; U : Unit_Id) return Tree_Id is begin Reset_Context (C); return Unit_Table.Table (U).Main_Tree; end Main_Tree; -------- procedure Set_Top (C : Context_Id; U : Unit_Id; N : Node_Id) is begin Reset_Context (C); Unit_Table.Table (U).Top := N; end Set_Top; procedure Set_Kind (C : Context_Id; U : Unit_Id; K : Unit_Kinds) is begin Reset_Context (C); Unit_Table.Table (U).Kind := K; end Set_Kind; procedure Set_Class (C : Context_Id; U : Unit_Id; Cl : Unit_Classes) is begin Reset_Context (C); Unit_Table.Table (U).Class := Cl; end Set_Class; procedure Set_Origin (C : Context_Id; U : Unit_Id; O : Unit_Origins) is begin Reset_Context (C); Unit_Table.Table (U).Origin := O; end Set_Origin; procedure Set_Is_Main_Unit (C : Context_Id; U : Unit_Id; M : Boolean) is begin Reset_Context (C); Unit_Table.Table (U).Main_Unit := M; end Set_Is_Main_Unit; procedure Set_Is_Body_Required (C : Context_Id; U : Unit_Id; B : Boolean) is begin Reset_Context (C); Unit_Table.Table (U).Is_Body_Required := B; end Set_Is_Body_Required; procedure Set_Time_Stamp (C : Context_Id; U : Unit_Id; T : Time_Stamp_Type) is begin Reset_Context (C); Unit_Table.Table (U).Time_Stamp := T; end Set_Time_Stamp; procedure Set_Is_Consistent (C : Context_Id; U : Unit_Id; B : Boolean) is begin Reset_Context (C); Unit_Table.Table (U).Is_Consistent := B; end Set_Is_Consistent; procedure Set_Source_Status (C : Context_Id; U : Unit_Id; S : Source_File_Statuses) is begin Reset_Context (C); Unit_Table.Table (U).Source_File_Status := S; end Set_Source_Status; ---------------- -- Same_Names -- ---------------- function Same_Names return Boolean is begin if Contt.A_Name_Len /= Namet.Name_Len then return False; end if; -- a small optimization for comparing the Unit names: -- we start from comparing the spec/body sign :-) if Contt.A_Name_Buffer (A_Name_Len) /= Namet.Name_Buffer (A_Name_Len) then return False; end if; for I in 1 .. Contt.A_Name_Len - 1 loop if Contt.A_Name_Buffer (I) /= Namet.Name_Buffer (I) then return False; end if; end loop; return True; end Same_Names; ----------------------------- -- Set_Nil_Unit_Attributes -- ----------------------------- procedure Set_Nil_Unit_Attributes (C : Context_Id; U : Unit_Id) is begin Set_Top (C, U, Empty); Set_Kind (C, U, Not_A_Unit); Set_Class (C, U, Not_A_Class); Set_Origin (C, U, Not_An_Origin); Set_Is_Main_Unit (C, U, False); Set_Is_Body_Required (C, U, False); Set_No_Source_File (U); Set_Time_Stamp (C, U, (others => '0')); Set_Is_Consistent (C, U, True); Set_Source_Status (C, U, No_File_Status); -- setting the empty dependencies lists: Unit_Table.Table (U).Ancestors := New_Elmt_List; Unit_Table.Table (U).Descendants := New_Elmt_List; Unit_Table.Table (U).Direct_Supporters := New_Elmt_List; Unit_Table.Table (U).Supporters := New_Elmt_List; Unit_Table.Table (U).Implicit_Supporters := New_Elmt_List; Unit_Table.Table (U).Direct_Dependents := New_Elmt_List; Unit_Table.Table (U).Dependents := New_Elmt_List; Unit_Table.Table (U).Subunits_Or_Childs := New_Elmt_List; Unit_Table.Table (U).Subunits_Computed := False; Unit_Table.Table (U).Compilation_Dependencies := New_Elmt_List; Unit_Table.Table (U).Trees := New_Elmt_List; Unit_Table.Table (U).Main_Tree := Nil_Tree; end Set_Nil_Unit_Attributes; --------------------- -- TS_From_OS_Time -- --------------------- function TS_From_OS_Time (T : OS_Time) return Time_Stamp_Type is Y : Year_Type; Mon : Month_Type; D : Day_Type; H : Hour_Type; Min : Minute_Type; S : Second_Type; Res : Time_Stamp_Type; begin GM_Split (T, Y, Mon, D, H, Min, S); Make_Time_Stamp (Nat (Y), Nat (Mon), Nat (D), Nat (H), Nat (Min), Nat (S), Res); return Res; end TS_From_OS_Time; ---------------------------------------------------------- -- Subprograms for Semantic Dependencies Handling -- ---------------------------------------------------------- -------------- -- Children -- -------------- function Children (U : Unit_Id) return Unit_Id_List is begin return Get_Unit_Id_List (Unit_Table.Table (U).Subunits_Or_Childs); end Children; -------------------------- -- Get_Nonexistent_Unit -- -------------------------- function Get_Nonexistent_Unit (C : Context_Id) return Unit_Id is Result_Id : Unit_Id; begin -- A_Name_Buffer contains the normalized unit name ending with "%s" A_Name_Len := A_Name_Len + 1; A_Name_Buffer (A_Name_Len) := 'n'; Result_Id := Name_Find (C); if No (Result_Id) then -- coming back to the correct initial situation for -- Allocate_Nonexistent_Unit_Entry: A_Name_Len := A_Name_Len - 1; Result_Id := Allocate_Nonexistent_Unit_Entry (C); end if; return Result_Id; end Get_Nonexistent_Unit; --------------------- -- Get_Parent_Unit -- --------------------- function Get_Parent_Unit (C : Context_Id; U : Unit_Id) return Unit_Id is begin if U = Standard_Id then return Nil_Unit; end if; Get_Name_String (U, Norm_Ada_Name); Form_Parent_Name; if A_Name_Len = 0 then return Standard_Id; else return Name_Find (C); end if; end Get_Parent_Unit; -------------- -- Get_Body -- -------------- function Get_Body (C : Context_Id; U : Unit_Id) return Unit_Id is begin Get_Name_String (U, Norm_Ada_Name); A_Name_Buffer (A_Name_Len) := 'b'; return Name_Find (C); end Get_Body; --------------------- -- Get_Declaration -- --------------------- function Get_Declaration (C : Context_Id; U : Unit_Id) return Unit_Id is begin Get_Name_String (U, Norm_Ada_Name); A_Name_Buffer (A_Name_Len) := 's'; return Name_Find (C); end Get_Declaration; ------------------- -- Get_Same_Unit -- ------------------- function Get_Same_Unit (Arg_C : Context_Id; Arg_U : Unit_Id; Targ_C : Context_Id) return Unit_Id is Result : Unit_Id; begin if Arg_C = Targ_C or else Arg_U = Nil_Unit then return Arg_U; end if; Reset_Context (Arg_C); Get_Name_String (Arg_U, Norm_Ada_Name); Reset_Context (Targ_C); Result := Name_Find (Targ_C); if Present (Result) and then Time_Stamp (Arg_C, Arg_U) = Time_Stamp (Targ_C, Result) then return Result; else return Nil_Unit; end if; end Get_Same_Unit; ----------------------------- -- Get_Subunit_Parent_Body -- ----------------------------- function Get_Subunit_Parent_Body (C : Context_Id; U : Unit_Id) return Unit_Id is begin Get_Name_String (U, Norm_Ada_Name); Form_Parent_Name; A_Name_Buffer (A_Name_Len) := 'b'; -- for subunits Form_Parent_Name cannot set A_Name_Len as 0, and it -- sets A_Name_Buffer (A_Name_Len) as 's' return Name_Find (C); end Get_Subunit_Parent_Body; -------------- -- Not_Root -- -------------- function Not_Root return Boolean is begin for I in 1 .. A_Name_Len loop if A_Name_Buffer (I) = '.' then return True; end if; end loop; return False; end Not_Root; -------------- -- Subunits -- -------------- function Subunits (C : Context_Id; U : Unit_Id) return Unit_Id_List is begin if not Unit_Table.Table (U).Subunits_Computed then if not Unit_In_Current_Tree (C, U) then Reset_Tree_For_Unit (C, U); end if; Set_Subunits (C, U, Top (U)); end if; return Get_Unit_Id_List (Unit_Table.Table (U).Subunits_Or_Childs); end Subunits; -------------------------------------------------- -- General-Purpose Unit Table Subprograms -- -------------------------------------------------- ---------------------- -- Comp_Unit_Bodies -- ---------------------- function Comp_Unit_Bodies (C : Context_Id) return Natural is begin return Contexts.Table (C).Bodies; end Comp_Unit_Bodies; -------------- -- Finalize -- -------------- procedure Finalize (C : Context_Id) is begin if not Debug_Lib_Model then return; end if; for U in First_Unit_Id .. Last_Unit loop Output_Unit (C, U); end loop; end Finalize; ---------------- -- First_Body -- ---------------- function First_Body return Unit_Id is Result : Unit_Id := Nil_Unit; begin -- Note that we start iterating after Config_Comp_Id not to count -- A_Configuration_Compilation unit as a body for U in Config_Comp_Id + 1 .. Last_Unit loop if not Is_Spec (U) then Result := U; exit; end if; end loop; return Result; end First_Body; --------------- -- Last_Unit -- --------------- function Last_Unit return Unit_Id is begin return Unit_Table.Last; end Last_Unit; -------------------- -- Lib_Unit_Decls -- -------------------- function Lib_Unit_Decls (C : Context_Id) return Natural is begin return Contexts.Table (C).Specs; end Lib_Unit_Decls; --------------- -- Next_Body -- --------------- function Next_Body (B : Unit_Id) return Unit_Id is Result : Unit_Id := Nil_Unit; begin for U in B + 1 .. Last_Unit loop if not Is_Spec (U) then Result := U; exit; end if; end loop; return Result; end Next_Body; --------------- -- Next_Decl -- --------------- function Next_Decl (D : Unit_Id) return Unit_Id is Result : Unit_Id := Nil_Unit; begin for U in D + 1 .. Last_Unit loop if Is_Spec (U) then Result := U; exit; end if; end loop; return Result; end Next_Decl; -------- -- No -- -------- function No (Unit : Unit_Id) return Boolean is begin return Unit = Nil_Unit; end No; ------------- -- Present -- ------------- function Present (Unit : Unit_Id) return Boolean is begin return Unit /= Nil_Unit; end Present; ----------------- -- Output_Unit -- ----------------- procedure Output_Unit (C : Context_Id; Unit : Unit_Id) is begin Write_Str ("Debug output for Unit Id "); Write_Int (Int (Unit)); Write_Eol; Write_Str ("----------------------------"); Write_Eol; if Unit = Nil_Unit then Write_Str ("This is a Nil Unit"); Write_Eol; return; end if; Write_Str ("Ada Unit Name: "); Get_Name_String (Unit, Ada_Name); Write_Str (A_Name_Buffer (1 .. A_Name_Len)); Write_Eol; Write_Str ("Normalized Ada Unit Name: "); Get_Name_String (Unit, Norm_Ada_Name); Write_Str (A_Name_Buffer (1 .. A_Name_Len)); Write_Eol; Write_Str ("Source File Name: "); Get_Name_String (Unit, Source_File_Name); if A_Name_Len = 0 then Write_Str ("no source file available"); else Write_Str (A_Name_Buffer (1 .. A_Name_Len)); end if; Write_Eol; Write_Str ("Reference File Name: "); Get_Name_String (Unit, Ref_File_Name); if A_Name_Len = 0 then Write_Str ("no reference file available"); else Write_Str (A_Name_Buffer (1 .. A_Name_Len)); end if; Write_Eol; Write_Str ("Unit Kind: "); Write_Str (Unit_Kinds'Image (Kind (C, Unit))); Write_Eol; Write_Str ("Unit Class: "); Write_Str (Unit_Classes'Image (Class (C, Unit))); Write_Eol; Write_Str ("Unit Origin: "); Write_Str (Unit_Origins'Image (Origin (C, Unit))); Write_Eol; Write_Str ("Can be a main unit: "); Write_Str (Boolean'Image (Is_Main_Unit (C, Unit))); Write_Eol; Write_Str ("Is body required: "); Write_Str (Boolean'Image (Is_Body_Required (C, Unit))); Write_Eol; Write_Str ("Time stamp: "); Write_Str (String (Time_Stamp (C, Unit))); Write_Eol; Write_Str ("Is consistent: "); Write_Str (Boolean'Image (Is_Consistent (C, Unit))); Write_Eol; Write_Str ("Source file status: "); Write_Str (Source_File_Statuses'Image (Source_Status (C, Unit))); Write_Eol; Write_Str ("Consistent tree set:"); Write_Eol; Print_List (Unit_Table.Table (Unit).Trees); Write_Str ("Main_Tree: "); Write_Int (Int (Unit_Table.Table (Unit).Main_Tree)); Write_Eol; Write_Str ("Dependencies:"); Write_Eol; Write_Str ("============="); Write_Eol; Write_Str ("Ancestors:"); Write_Eol; Print_List (Unit_Table.Table (Unit).Ancestors); Write_Str ("Descendents:"); Write_Eol; Print_List (Unit_Table.Table (Unit).Descendants); Write_Str ("Direct_Supporters:"); Write_Eol; Print_List (Unit_Table.Table (Unit).Direct_Supporters); Write_Str ("Supporters:"); Write_Eol; Print_List (Unit_Table.Table (Unit).Supporters); Write_Str ("Implicit Supporters:"); Write_Eol; Print_List (Unit_Table.Table (Unit).Implicit_Supporters); Write_Str ("Direct_Dependents:"); Write_Eol; Print_List (Unit_Table.Table (Unit).Direct_Dependents); Write_Str ("Dependents:"); Write_Eol; Print_List (Unit_Table.Table (Unit).Dependents); Write_Str ("Subunits_Or_Childs:"); Write_Eol; Print_List (Unit_Table.Table (Unit).Subunits_Or_Childs); Write_Str ("Compilation_Dependencies:"); Write_Eol; Print_List (Unit_Table.Table (Unit).Compilation_Dependencies); Write_Str ("=============================================="); Write_Eol; end Output_Unit; ----------------- -- Print_Units -- ----------------- procedure Print_Units (C : Context_Id) is begin Write_Str ("Unit Table for Context number: "); Write_Int (Int (C)); Write_Eol; if C = Non_Associated then Write_Str (" Nil Context, it can never contain any unit"); Write_Eol; return; end if; if Is_Opened (C) then Write_Str ("The number of the unit entries being allocated is "); Write_Int (Int (Last_Unit - First_Unit_Id + 1)); Write_Eol; Write_Str ("The number of existing specs is "); Write_Int (Int (Contexts.Table (C).Specs)); Write_Eol; Write_Str ("The number of existing bodies is "); Write_Int (Int (Contexts.Table (C).Bodies)); Write_Eol; Write_Str ("The number of nonexisting units is "); Write_Int (Int (Last_Unit - First_Unit_Id + 1) - Int (Contexts.Table (C).Specs) - Int (Contexts.Table (C).Bodies)); Write_Eol; for U in First_Unit_Id .. Last_Unit loop Output_Unit (C, U); end loop; Write_Eol; else Write_Str ("This Context is closed"); Write_Eol; end if; end Print_Units; -------------------- -- Register_Units -- -------------------- procedure Register_Units (Set_First_New_Unit : Boolean := False) is Cont : constant Context_Id := Get_Current_Cont; Current_Unit : Unit_Id; Include_Unit : Boolean := False; Store_First_Unit : Boolean := Set_First_New_Unit; begin First_New_Unit := Nil_Unit; for N_Unit in Main_Unit .. Lib.Last_Unit loop if Present (Lib.Cunit (N_Unit)) then Namet.Get_Decoded_Name_String (Lib.Unit_Name (N_Unit)); Set_Norm_Ada_Name_String_With_Check (N_Unit, Include_Unit); if Include_Unit then Current_Unit := Name_Find (Cont); if No (Current_Unit) then Set_Unit (Cont, N_Unit); if Store_First_Unit then First_New_Unit := Last_Unit; Store_First_Unit := False; end if; end if; end if; end if; end loop; end Register_Units; begin -- Initializing the top node cache Reset_Cache; end A4G.Contt.UT; asis-2010.orig/asis/a4g-contt-ut.ads0000644000175000017500000010140211574704441017057 0ustar lbrentalbrenta------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- A 4 G . C O N T T . U T -- -- -- -- S p e c -- -- -- -- Copyright (C) 1995-2006, Free Software Foundation, Inc. -- -- -- -- ASIS-for-GNAT 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 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 51 Franklin -- -- Street, Fifth Floor, Boston, MA 02110-1301, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by AdaCore. -- -- (http://www.adacore.com). -- -- -- ------------------------------------------------------------------------------ -- This package defines for each ASIS Context the corresponding Unit Table, -- which contains all the information needed for the black-box ASIS queries -- about Compilation Units. This table also provides the mechanism for -- searching for a unit by its Ada name, this mechanism is some slight -- modification of the GNAT Namet package. with Asis; use Asis; with Asis.Extensions; use Asis.Extensions; package A4G.Contt.UT is -- Context_Table.Unit_Tables --------------------- -- ASIS Unit Table -- --------------------- -- ASIS Unit Table is the main part of the implementation of ASIS Context -- and ASIS Compilation Unit abstractions. The table is organized in the -- following way: -- - the internal representation of an ASIS Compilation Unit is the -- value of the corresponding Unit Record which is kept in Unit Table -- and indicated by Unit Id; -- - each ASIS Context has its own Unit Table, so most the routines -- dealing with Unit Table contain the Id of an Enclosing Context -- as a Parameter; -- - each ASIS Compilation Units keeps the Id of its enclosing -- Context as a part of its value; -- - The fully expanded Ada name, together for the spec/body sign, -- uniquely identifies a given unit inside its enclosing -- Context/Context; so the triple - expanded Ada name, spec/body -- sign and some identification of the Unit's enclosing Context/Context -- uniquely identifies a given unit among all the Unit processed -- by ASIS; -- - The normalized Ada name, is obtained from the fully expanded -- Ada Unit name by folding all the upper case letters in the -- corresponding lower case letters, appending the spec/body sign -- (which has the form "%s" for a spec and "%b" for a body); -- The entries in the table are accessed using a Unit_Id that ranges -- from First_Unit_Id to Last_Unit_Id. The fields of each entry and -- the corresponding interfaces may be subdivided into four groups. -- The first group, called as Unit Name Table, provides the modified -- version of the functionality of the GNAT Namet package, it is used -- for storing the names of the Units in two forms - in the normalized -- and in the form corresponding to the (defining) occurrence of a -- given name in a source text. Each unit can be effectively searched -- by its normalized name. -- The second group contains the black-box attributes of a Unit. -- The third group contains the information about relations (semantic -- dependencies) between the given unit and the other units in the -- enclosing Context/Context Note, that Ada Unit name, -- included in the first group, logically should also be considered -- as a black-box Unit attribute. -- And the fourth group contains the fields needed for organization of the -- tree swapping during the multiple Units processing. --------------------- -- Unit Name Table -- --------------------- -- Each Unit entry contain the following fields: -- "Normalized" Ada name "Normalized" Ada names of the ASIS Compilation -- Units are their names with upper case letters -- folded to lower case (by applying the -- Ada.Character.Handling.To_Lower functions; -- this lover-case-folding has no relation to GNAT -- conventions described in Namet!), appended by -- suffix %s or %b for spec or bodies/subunits, as -- defined in Uname (spec), and prepended by -- the string image of the Id value of the unit's -- enclosing Context. Each of the names of this -- kind may have only one entry in Unit Name Table. -- -- Ada name Ada names of the ASIS Compilation Units are -- stored keeping the casing from the source text. -- These entries are used to implement the ASIS -- query (-ies?) returning the Ada name of the -- Unit. Ada names may be included more than one -- time in Unit Name Table as the parts of the -- different table entries, as the name of a spec -- and the name of a corresponding body. -- -- Source File Name The name of the Ada source file used to compile -- the given compilation unit (on its own or as a -- supporter of some other unit). -- -- Reference File Name The name of the source file which represents -- the unit source from the user's viewpoint. It is -- the same as the Source File name unless the -- Source_Reference pragma presents for the given -- unit. type Column is (Norm_Ada_Name, Ada_Name, Source_File_Name, Ref_File_Name); -- This enumeration type defines literals used to make the difference -- between different forms of names stored in the Unit Table -- Really every name is kept as the reference into the Char table, -- together with the length of its name. -- The normalized names are hashed, so that a given normalized name appears -- only once in the table. -- Opposite to the GNAT name table, this name table does not handle the -- one-character values in a special way (there is no need for it, because -- storing an one-character name does not seem to be a usual thing -- for this table.) -- ASIS "normalized" Unit names follow the convention which is -- very similar to the GNAT convention defined in Uname (spec), the -- only difference is that ASIS folds all the upper case -- letters to the corresponding lower case letters without any encoding. -- ASIS packages implementing the ASIS Context model for GNAT contain -- "ASIS-related counterparts" of some facilities provided by three -- GNAT packages - Namet, Uname and Fname. -- We keep storing the two values, one of type Int and one of type Byte, -- with each names table entry and subprograms are provided for setting -- and retrieving these associated values. But for now these values are -- of no use in ASIS - we simply are keeping this mechanism from the -- GNAT name table - just in case. -- Unit Name Table may be considered as having the external view -- of the two-column table - for each row indicated by Unit_Id the -- first column contains the Ada name of the corresponding Unit and -- the second column contains Unit's "normalized" name. -- In fact we do not use any encoding-decoding in Unit Name Table. ASIS -- supports only a standard mode of GNAT (that is, it relies on the fact -- that all the identifiers contain only Row 00 characters). ASIS also -- assumes that all the names of the source files are the values of -- the Ada predefined String type. -- All the Unit Tables shares the same Name Buffer, see the specification -- of the parent package for its definition. --------------------------------- -- Unit Name Table Subprograms -- --------------------------------- procedure Get_Name_String (Id : Unit_Id; Col : Column); -- Get_Name_String is used to retrieve the one of the three strings -- associated with an entry in the names table. The Col parameter -- indicates which of the names should be retrieved (Ada name, normalized -- Ada name or source file name) by indicating the "column" in the table -- The resulting string is stored in Name_Buffer and Name_Len is set. function Length_Of_Name (Id : Unit_Id; Col : Column) return Nat; -- ??? pragma Inline (Length_Of_Name); -- Returns length of given name in characters, the result is equivalent to -- calling Get_Name_String and reading Name_Len, except that a call to -- Length_Of_Name does not affect the contents of Name_Len and Name_Buffer. function Name_Find (C : Context_Id) return Unit_Id; -- Name_Find is called with a string stored in Name_Buffer whose length -- is in Name_Len (i.e. the characters of the name are in subscript -- positions 1 to Name_Len in Name_Buffer). It searches the names -- table to see if the string has already been stored. If so the Id of -- the existing entry is returned. Otherwise (opposite to the GNAT name -- table, in which a new entry is created it this situation with its -- Name_Table_Info field set to zero) the Id value corresponding to the -- ASIS Nil_Compilation_Unit, that is Nil_Unit, is returned. -- -- Only normalized Ada names are hashed, so this function is intended to -- be applied to the normalized names only (in is not an error to apply -- it to other forms of names stored in the table, but the result will -- always be Nil_Unit. function Allocate_Unit_Entry (C : Context_Id) return Unit_Id; -- Allocates the new entry in the Unit Name Table for the "normalized" -- Ada Unit name stored in the Name_Buffer (Name_Len should be set -- in a proper way). This routine should be called only if the -- immediately preceding call to an operation working with Unit Name -- Table is the call to Name_Find which has yielded Nil_Unit as a -- result. Note, that this function sets only the "normalized" unit name, -- it does not set the Ada name or the source file name. It also -- increases by one the counter of allocated bodies or specs, depending -- on the suffix in the normalized unit name. function Allocate_Nonexistent_Unit_Entry (C : Context_Id) return Unit_Id; -- Differs from the previous function in the following aspects: -- - 'n' is added to the name suffix to mark that this entry -- corresponds to the nonexistent unit; -- - The body/spec counters are not increased -- - all the attributes of the allocated nonexistent unit are set by -- this procedure. -- -- Allocates the new entry in the Unit Name Table for the "normalized" -- Ada Unit name stored in the Name_Buffer (Name_Len should be set -- in a proper way). This routine should be called only if the -- immediately preceding call to an operation working with Unit Name -- Table is the call to Name_Find which has yielded Nil_Unit as a -- result. Note, that this function sets only the "normalized" unit name, -- it does not set the Ada name or the source file name. procedure Set_Unit (C : Context_Id; U : Unit_Number_Type); -- Creates the Unit table entry for the unit U and sets the normalized -- unit name (which is supposed to be stored in A_Name_Buffer when this -- procedure is called) and the time stamp for the unit. It also adds -- the (Id of the) currently accessed tree to the (empty) list -- of (consistent) trees for this unit. All the other unit attributes -- are set to nil values procedure Set_Ada_Name (Id : Unit_Id); pragma Inline (Set_Ada_Name); -- Sets the string stored in Name_Buffer whose length is Name_Len as the -- value of the Ada name of the ASIS Unit indicated by Id value procedure Set_Norm_Ada_Name (Id : Unit_Id); pragma Inline (Set_Norm_Ada_Name); -- Sets the string stored in Name_Buffer whose length is Name_Len as the -- value of the "normalized" Ada name of the ASIS Unit indicated by Id -- value procedure Set_Ref_File_As_Source_File (U : Unit_Id); -- For a given unit in a given context, sets the reference file name equal -- to the source file name (by copying the corresponding references to -- the ASIS Chars table procedure Set_Source_File_Name (Id : Unit_Id; Ref : Boolean := False); pragma Inline (Set_Source_File_Name); -- Sets the string stored in the A_Name_Buffer whose length is A_Name_Len -- as the value of the source or reference (depending on the actual set -- for the Ref parameter) file name of the ASIS Unit indicated by Id value procedure Set_Norm_Ada_Name_String; -- Sets the Normalized Ada Unit name as the value of Name_Buffer. -- This normalized version of the Ada Unit name is -- obtained by folding to lover cases of the GNAT unit name -- which should be previously get as the content of -- Namet.Name_Buffer (that means that every call to this procedure -- should be preceded by the appropriate call to -- Namet.Get_Unqualified_Decoded_Name_String (or -- Namet.Get_Decoded_Name_String if the caller is sure, that the name is -- not qualified) procedure Set_Norm_Ada_Name_String_With_Check (Unit : Unit_Number_Type; Success : out Boolean); -- This is the modified version of Set_Norm_Ada_Name_String: after setting -- the ASIS name buffer it checks if Unit should be considered as -- Compilation_Unit by ASIS. The need for this check caused by artificial -- compilation units created by the compiler for library-level generic -- instantiations. If the check is successful, Success is set True, -- otherwise it is set False. -- -- In case of a tree created for library-level instantiation of a generic -- package (only package ???) GNAT sets the suffix of the name of the -- corresponding unit in its unit table as '%b', but ASIS has to see -- this unit as a spec, therefore in this case this procedure resets the -- suffix of the unit name to '%s' procedure Set_Ref_File_Name_String (U : Unit_Id); -- Is supposed to be called when GNAT Namet.Name_Buffer contains a full -- reference file name. It sets the Reference File name as the value of -- A_Name_Buffer. This name is composed from the reference file name -- obtained from the tree and from the source file name (in which the -- directory information is already adjusted , if needed, by the -- corresponding call to Set_S_File_Name_String) to contain the directory -- information needed to access this file from the current directory. ------------------------------- -- Black-Box Unit Attributes -- ------------------------------- -- Each Unit entry contains the following fields, representing the Unit -- black-box attributes, which are for the direct interest for the ASIS -- queries from the Asis_Compilation_Unit package, the primary idea of -- implementing the Context/Compilation_Unit stuff in ASIS-for-GNAT is -- to compute each of these attribute only once, when the new tree is -- inputted by ASIS for the first time, and then store them in Unit -- Table, so then ASIS queries will be able to get the required -- answer without any new tree processing: -- Top : Node_Id; -- The top node of the unit subtree in the currently accessed full tree. -- From one side, this node should be reset every time the full tree -- is changed. From the other side, the corresponding actions may be -- considered as too time-consumed. This problem is postponed now as -- OPEN PROBLEM, it is not important till we are working under the -- limitation "only one tree can be accessed at a time" -- Enclosing_Context : Context_Id; -- The reference to the Context table which indicates the Enclosing -- Context for a Unit -- Kind : Unit_Kinds; -- The kind of a Compilation Unit, as defined by Asis.Unit_Kinds -- package -- Class : Unit_Classes; -- The class of a Compilation Unit, as defined by Asis.Unit_Kinds -- package -- Origin : Unit_Origins; -- The origin of a Compilation Unit, as defined by Asis.Unit_Kinds -- package -- Main_Unit : Boolean; -- The boolean flag indicating if a Compilation Unit may be treated -- as the main unit for a partition (See RM 10.2(7)) -- GNAT-specific!!?? -- Is_Body_Required : Boolean; -- The boolean flag indicating if a Compilation Unit requires a body -- as a completion ----------------------------------------------------------- -- Black-Box Unit Attributes Access and Update Routines -- ----------------------------------------------------------- function Top (U : Unit_Id) return Node_Id; -- this function is not trivial, it can have tree swapping as its -- "side effect" function Kind (C : Context_Id; U : Unit_Id) return Unit_Kinds; function Class (C : Context_Id; U : Unit_Id) return Unit_Classes; function Origin (C : Context_Id; U : Unit_Id) return Unit_Origins; function Is_Main_Unit (C : Context_Id; U : Unit_Id) return Boolean; function Is_Body_Required (C : Context_Id; U : Unit_Id) return Boolean; -- This function does not reset Context, a Caller is responsible for this function Time_Stamp (C : Context_Id; U : Unit_Id) return Time_Stamp_Type; function Is_Consistent (C : Context_Id; U : Unit_Id) return Boolean; function Source_Status (C : Context_Id; U : Unit_Id) return Source_File_Statuses; function Main_Tree (C : Context_Id; U : Unit_Id) return Tree_Id; -------- procedure Set_Top (C : Context_Id; U : Unit_Id; N : Node_Id); procedure Set_Kind (C : Context_Id; U : Unit_Id; K : Unit_Kinds); procedure Set_Class (C : Context_Id; U : Unit_Id; Cl : Unit_Classes); procedure Set_Origin (C : Context_Id; U : Unit_Id; O : Unit_Origins); procedure Set_Is_Main_Unit (C : Context_Id; U : Unit_Id; M : Boolean); procedure Set_Is_Body_Required (C : Context_Id; U : Unit_Id; B : Boolean); procedure Set_Time_Stamp (C : Context_Id; U : Unit_Id; T : Time_Stamp_Type); procedure Set_Is_Consistent (C : Context_Id; U : Unit_Id; B : Boolean); procedure Set_Source_Status (C : Context_Id; U : Unit_Id; S : Source_File_Statuses); ------------------------------------------------- --------------------------- -- Semantic Dependencies -- --------------------------- ---------------------------------------------------- -- Subprograms for Semantic Dependencies Handling -- ---------------------------------------------------- function Not_Root return Boolean; -- Checks if U is not a root library unit (by checking if -- its name contains a dot). This function itself does not set the -- normalized name of U in A_Name_Buffer, it is supposed to be called -- when a proper name is already set. function Subunits (C : Context_Id; U : Unit_Id) return Unit_Id_List; -- Returns the full list of Ids of subunits for U (if any). The full list -- contains nonexistent units for missed subunits -- -- Note, that this function does not reset Context, it should be done in -- the caller! function Get_Subunit (Parent_Body : Asis.Compilation_Unit; Stub_Node : Node_Id) return Asis.Compilation_Unit; -- This function is intended to be used only when all the Unit attributes -- are already computed. It gets the Parent_Body, whose tree should -- contain Stub_Node as a node representing some body stub, and it -- returns the Compilation Unit containing the proper body for this stub. -- It returns a Nil_Compilation_Unit, if the Compilation Unit containing -- the proper body does not exist in the enclosing Context or if it is -- inconsistent with Parent_Body. function Children (U : Unit_Id) return Unit_Id_List; -- returns the list of Ids of children for U (if any) -- -- Note, that this function does not reset Context, it should be done in -- the caller! function GNAT_Compilation_Dependencies (U : Unit_Id) return Unit_Id_List; -- Returns the full list of GNAT compilation dependencies for U -- This list is empty if and only if U is not a main unit of some -- compilation which creates some tree for C. procedure Form_Parent_Name; -- supposing A_Name_Buffer containing a normalized unit name, this -- function forms the normalized name of its parent by stripping out -- the suffix in the Ada part of the name (that is, the part of the -- name between the rightmost '.' and '%") and changing the -- "normalized" suffix to "%s". A_Name_Len is set in accordance with -- this. If the Ada part of the name contains no suffix (that is, if -- it corresponds to a root library unit), A_Name_Len is set equal -- to 0. function Get_Parent_Unit (C : Context_Id; U : Unit_Id) return Unit_Id; -- returns the Id of the parent unit declaration for U. If U is -- First_Unit_Id, returns Nil_Unit. -- -- Note, that this function does not reset Context, it should be done in -- the caller! function Get_Body (C : Context_Id; U : Unit_Id) return Unit_Id; -- returns the Id of the library_unit_body for the unit U. -- Nil_Unit is not a valid argument for this function. -- -- Note, that this function does not reset Context, it should be done in -- the caller! function Get_Declaration (C : Context_Id; U : Unit_Id) return Unit_Id; -- returns the Id of the library_unit_declaration for the unit U. -- Nil_Unit is not a valid argument for this function. -- -- Note, that this function does not reset Context, it should be done in -- the caller! function Get_Subunit_Parent_Body (C : Context_Id; U : Unit_Id) return Unit_Id; -- returns the Id of the library_unit_body or subunit being the parent -- body for subunit U (a caller is responsible for calling this function -- for subunits). function Get_Nonexistent_Unit (C : Context_Id) return Unit_Id; -- Is supposed to be called just after an attempt to get a unit which is -- supposed to be a needed declaration or a needed body (that is, -- A_Name_Buffer contains a normalized unit name ending with "%s" or "%b" -- respectively). Tries to find the unit of A_Nonexistent_Declaration -- or A_Nonexistent_Body kind with this name, if this attempt fails, -- allocates the new unit entry for the corresponding nonexistent unit. -- Returns the Id of found or allocated unit. function Get_Same_Unit (Arg_C : Context_Id; Arg_U : Unit_Id; Targ_C : Context_Id) return Unit_Id; -- Tries to find in Targ_C just the same unit as Arg_U is in Arg_C. -- Just the same means, that Arg_U and the result of this function -- should have just the same time stamps. If Arg_C = Targ_C, Arg_U -- is returned. If there is no "just the same" unit in Targ_C, -- Nil_Unit is returned. -- -- If No (Arg_U), then the currently accessed Context is not reset (but -- this function is not supposed to be called for Arg_U equal to -- Nil_Unit_Id, although it is not an error). Otherwise Context is reset -- to Targ_C -------------------------------------- -- General-Purpose Unit Subprograms -- -------------------------------------- procedure Finalize (C : Context_Id); -- Currently this routine is only used to generate debugging output -- for the Unit Table of a given Context. function Present (Unit : Unit_Id) return Boolean; -- Tests given Unit Id for equality with Nil_Unit. This allows -- notations like "if Present (Current_Supporter)" as opposed to -- "if Current_Supporter /= Nil_Unit function No (Unit : Unit_Id) return Boolean; -- Tests given Unit Id for equality with Nil_Unit. This allows -- notations like "if No (Current_Supporter)" as opposed to -- "if Current_Supporter = Nil_Unit function Last_Unit return Unit_Id; -- Returns the Unit_Id of the last unit which has been allocated in the -- Unit Name Table. Used to define that the Unit_Id value returned by -- Name_Find corresponds to the ASIS Compilation Unit which is not -- known to ASIS. function Lib_Unit_Decls (C : Context_Id) return Natural; -- returns the number of library_unit_declaratios allocated in the -- Context Unit table function Comp_Unit_Bodies (C : Context_Id) return Natural; -- returns the number of library_unit_bodies and subunits allocated -- in the Context Unit table function Next_Decl (D : Unit_Id) return Unit_Id; -- Returns the Unit_Id of the next unit (starting from, but not including -- D), which is a library_unit_declaration. Returns Nil_Unit, if there -- is no such a unit in C. -- -- Note, that this function does not reset Context, it should be done in -- the caller! function First_Body return Unit_Id; -- Returns the Unit_Id of the first unit which is a -- compilation_unit_body or a subunit. Returns Nil_Unit, if there is -- no such a unit in a current Context. -- -- Note, that this function does not reset Context, it should be done in -- the caller! function Next_Body (B : Unit_Id) return Unit_Id; -- Returns the Unit_Id of the next unit (starting from, but not including -- B) which is a compilation_unit_body or a subunit. Returns Nil_Unit, -- if there is no such a unit in C. -- -- Note, that this function does not reset Context, it should be done in -- the caller! procedure Output_Unit (C : Context_Id; Unit : Unit_Id); -- Produces the debug output of the Unit Table entry corresponding -- to Unit -- DO WE NEED THIS PROCEDURE IN THE SPECIFICATION???? procedure Print_Units (C : Context_Id); -- Produces the debug output from the Unit table for the Context C. function Enclosing_Unit (Cont : Context_Id; Node : Node_Id) return Asis.Compilation_Unit; -- This function is intended to be used to define the enclosing -- unit for an Element obtained as a result of some ASIS semantic query. -- It finds the N_Compilation_Unit node for the subtree enclosing -- the Node given as its argument, and then defines the corresponding -- Unit Id, which is supposed to be the Id of Enclosing Unit for an -- Element built up on the base of Node. It does not change the tree -- being currently accessed. All these computations are supposed -- to be performed for a Context Cont. -- Node should not be a result of Atree.Original_Node, because -- it is used as an argument for Atree.Parent function -- -- Note, that this function does no consistency check, that is, the -- currently accessed tree may be not from the list of consistent trees -- for the resulted Unit. --------------- -- NEW STUFF -- --------------- procedure Register_Units (Set_First_New_Unit : Boolean := False); -- When a new tree file is read in during Opening a Context, this procedure -- goes through all the units represented by this tree and checks if these -- units are already known to ASIS. If some unit is unknown, this -- procedure "register" it - it creates the corresponding entry in the -- unit table, and it sets the normalized unit name. It does not set any -- other field of unit record except Kind. It sets Kind as Not_A_Unit -- to indicate, that this unit is only registered, but not processed. -- -- We need this (pre-)registration to be made before starting unit -- processing performed by Process_Unit_New, because we need all the units -- presenting in the tree to be presented also in the Context unit table -- when storing the dependency information. -- -- Note, that all the consistency checks are made by Process_Unit_New, -- even though we can make them here. The reason is to separate this -- (pre-)registration (which is an auxiliary technical action) from -- unit-by-unit processing to facilitate the maintainability of the code. -- -- If Set_First_New_Unit is set ON, stores in A4G.Contt.First_New_Unit -- the first new unit being registered. If Set_First_New_Unit is set OFF -- or if no new units has been registered, First_New_Unit is set to -- Nil_Unit -- -- ??? The current implementation uses Set_Unit, which also sets time -- ??? stamp for a unit being registered. It looks like we do not need -- ??? this, so we can get rid of this. function Already_Processed (C : Context_Id; U : Unit_Id) return Boolean; -- Checks if U has already been processed when scanning previous trees -- during opening C procedure Check_Source_Consistency (C : Context_Id; U_Id : Unit_Id); -- Is called when a Unit is being investigated as encountered for the first -- time during opening the Context C. It checks the existence of the source -- file for this unit, and if the source file exists, it checks that the -- units as represented by the tree is consistent with the source (if this -- is required by the options associated with the Context). -- This procedure should be called after extracting the source file name -- from the tree and putting this into the Context unit table. procedure Check_Consistency (C : Context_Id; U_Id : Unit_Id; U_Num : Unit_Number_Type); -- Is called when a unit is encountered again when opening C. Checks if in -- the currently accessed tree this unit has the same time stamp as it had -- in all the previously processed trees. In case if this check fails, it -- raises ASIS_Failed and forms the diagnosis on behalf of -- Asis.Ada_Environments.Open. (This procedure does not check the source -- file for the unit - this should be done by Check_Source_Consistency -- when the unit was processed for the first time) function TS_From_OS_Time (T : OS_Time) return Time_Stamp_Type; -- Converts OS_Time into Time_Stamp_Type. Is this the right place for -- this function??? procedure Reset_Cache; -- Resents to the empty state the cache data structure used to speed up the -- Top function. Should be called as a part of closing a Context. end A4G.Contt.UT; asis-2010.orig/asis/a4g-contt.adb0000644000175000017500000017227411574704441016427 0ustar lbrentalbrenta------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- A 4 G . C O N T T -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2010, Free Software Foundation, Inc. -- -- -- -- ASIS-for-GNAT 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 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 51 Franklin -- -- Street, Fifth Floor, Boston, MA 02110-1301, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by AdaCore. -- -- (http://www.adacore.com). -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; with GNAT.Directory_Operations; with Asis; use Asis; with Asis.Errors; use Asis.Errors; with Asis.Exceptions; use Asis.Exceptions; with Asis.Extensions; use Asis.Extensions; with A4G.A_Debug; use A4G.A_Debug; with A4G.A_Osint; use A4G.A_Osint; with A4G.A_Output; use A4G.A_Output; with A4G.Contt.Dp; use A4G.Contt.Dp; with A4G.Contt.SD; use A4G.Contt.SD; with A4G.Contt.TT; use A4G.Contt.TT; with A4G.Contt.UT; use A4G.Contt.UT; with A4G.Defaults; use A4G.Defaults; with A4G.Vcheck; use A4G.Vcheck; with Namet; use Namet; with Output; use Output; package body A4G.Contt is ------------------------------------------- -- Local Subprograms and Data Structures -- ------------------------------------------- procedure Set_Empty_Context (C : Context_Id); -- Set all the attribute of the Context indicated by C as for a -- Context having no associations (being empty) procedure Set_Predefined_Units; -- Sets in the Unit Table the unit entries corresponding to the predefined -- Ada environment. For now it sets the entries for the package Standard -- and for A_Configuration_Compilation only. procedure Print_Context_Search_Dirs (C : Context_Id; Dir_Kind : Search_Dir_Kinds); -- outputs the list of the directories making up the Dir_Kind search path -- for the context C; is intended to be used to produce a part of the -- Context debug output procedure Process_Dir (Dir_Name : String; Dir_Kind : Search_Dir_Kinds); -- verifies the part of the context association parameter following the -- two leading "-