pax_global_header00006660000000000000000000000064147007537340014524gustar00rootroot0000000000000052 comment=3db10ae062c1a8f2a5eeb9c5abf91de6828a9f20 gprbuild-25.0.0/000077500000000000000000000000001470075373400134205ustar00rootroot00000000000000gprbuild-25.0.0/.gitattributes000066400000000000000000000000361470075373400163120ustar00rootroot00000000000000install-sh no-precommit-check gprbuild-25.0.0/.gitignore000066400000000000000000000052001470075373400154050ustar00rootroot00000000000000*~ /*.ali *.pyc *.swp /CVS /gprclean /gprconfig /gprconfig.exe /gprbuild /gprbuild.exe /gprmake /gprmake.exe /gprbind /gprbind.exe /gprinstall /gprinstall.exe /gprlib /gprlib.exe /gprslave /gprslave.exe /install /create_ada_runtime_project /create_ada_runtime_project.exe /config.log /config.status /gnat.gpr /gnat_src /obj /exe /config/obj /config/lib /gpr/lib /gpr/libobj /share/gprconfig makefile.setup /doc/txt /doc/html /doc/info /doc/pdf /doc/build /doc/projects_unw.texi /doc/xgnatugn /doc/xgnatugn.ali /doc/xgnatugn.o /gnat/projects.texi /gnat/ug_words /gnat/xgnatugn.adb /gnat/*.ali /gnat/ali.ad? /gnat/ali-util.ad? /gnat/alloc.ads /gnat/aspects.ad? /gnat/atree.ad? /gnat/binderr.ad? /gnat/butil.ad? /gnat/casing.ad? /gnat/clean.ad? /gnat/csets.ad? /gnat/debug.ad? /gnat/einfo.ad? /gnat/elists.ad? /gnat/errout.ad? /gnat/erroutc.ad? /gnat/errutil.ad? /gnat/err_vars.ads /gnat/fmap.ad? /gnat/fname.ad? /gnat/fname-uf.ad? /gnat/fname-sf.ads /gnat/gnatcmd.ad? /gnat/gnat_style.css /gnat/gnatvsn.ad? /gnat/hostparm.ads /gnat/krunch.ad? /gnat/lib.ad? /gnat/lib-list.adb /gnat/lib-sort.adb /gnat/link.c /gnat/makeutl.ad? /gnat/make.ad? /gnat/makeusg.ads /gnat/mlib-prj.ads /gnat/mlib.ad? /gnat/mlib-fil.ad? /gnat/mlib-tgt.ad? /gnat/mlib-tgt-specific.ad? /gnat/mlib-tgt-specific-linux.adb /gnat/mlib-tgt-specific-vms-alpha.adb /gnat/mlib-tgt-specific-vms-ia64.adb /gnat/mlib-tgt-vms.ad? /gnat/mlib-tgt-vms_common.ad? /gnat/mlib-tgt-vms-alpha.adb /gnat/mlib-tgt-vms-ia64.adb /gnat/mlib-utl.ad? /gnat/namet.ad? /gnat/nlists.ad? /gnat/*.o /gnat/opt.ad? /gnat/osint.ad? /gnat/osint-m.ads /gnat/output.ad? /gnat/prj.ad? /gnat/prj-attr.ad? /gnat/prj-attr-pm.ad? /gnat/prj-com.ads /gnat/prj-conf.ad? /gnat/prj-dect.ad? /gnat/prj-env.ad? /gnat/prj-err.ad? /gnat/prj-ext.ad? /gnat/prj-gnat-6.0.1.diff /gnat/prj-nmsc.ad? /gnat/prj-pars.ad? /gnat/prj-part.ad? /gnat/prj-pp.ad? /gnat/prj-proc.ad? /gnat/prj-strt.ad? /gnat/prj-tree.ad? /gnat/prj-util.ad? /gnat/restrict.ad? /gnat/rident.ads /gnat/scans.ad? /gnat/scng.ad? /gnat/sdefault.ads /gnat/sem_aux.ad? /gnat/sfn_scan.ads /gnat/sinfo.ad? /gnat/sinput.ad? /gnat/sinput-c.ad? /gnat/sinput-p.ad? /gnat/snames.ad? /gnat/snames.adb-tmpl /gnat/snames.ads-tmpl /gnat/snames.h-tmpl /gnat/snames.nb /gnat/snames.nh /gnat/snames.ns /gnat/stand.ad? /gnat/stringt.ad? /gnat/style.ads /gnat/styleg.ad? /gnat/styleg-c.ad? /gnat/stylesw.ad? /gnat/switch-m.ads /gnat/switch.ad? /gnat/table.ad? /gnat/targparm.ad? /gnat/tempdir.ad? /gnat/tree_io.ad? /gnat/types.ad? /gnat/uintp.ad? /gnat/uname.ad? /gnat/urealp.ad? /gnat/xsnamest /gnat/xsnamest.adb /gnat/xutil.ad? /gnat/widechar.ad? /gnat/Make-generated.in /gnat/bldtools/ /gnat/snames.h /gnat/stamp-snames gprbuild-25.0.0/.gitlab-ci.yml000066400000000000000000000021311470075373400160510ustar00rootroot00000000000000include: - project: eng/gpr/gpr-issues file: /.gitlab/.gitlab-ci-shared.yml stages: - build - test build: extends: .job_template stage: build script: # Build using anod - anod build gnat # and save the gprbuild install - tar czf $CI_PROJECT_DIR/gprbuild.tar.gz -C $SANDBOX/$HOST/gprbuild/ install/ artifacts: paths: - gprbuild.tar.gz debug_build: extends: .job_template stage: build script: # build gprbuild in debug mode without rebuilding dependencies, # so we can catch coding style errors. - anod build gprbuild -Qdbg test_gprbuild: extends: .test_template script: - install_packages gnatall - run_testsuite gprbuild "" test_gprbuild artifacts: when: always paths: - testgprbuild_result.xml reports: junit: testgprbuild_result.xml test_gpr2ls: extends: .test_template script: - install_packages gnatall - run_testsuite gprbuild "-Qcheck-gpr2ls" test_gpr2ls artifacts: when: always paths: - testgpr2ls_result.xml reports: junit: testgpr2ls_result.xml gprbuild-25.0.0/COPYING.RUNTIME000066400000000000000000000063731470075373400156060ustar00rootroot00000000000000GCC RUNTIME LIBRARY EXCEPTION Version 3.1, 31 March 2009 Copyright (c) 2009 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. This GCC Runtime Library Exception ("Exception") is an additional permission under section 7 of the GNU General Public License, version 3 ("GPLv3"). It applies to a given file (the "Runtime Library") that bears a notice placed by the copyright holder of the file stating that the file is governed by GPLv3 along with this Exception. When you use GCC to compile a program, GCC may combine portions of certain GCC header files and runtime libraries with the compiled program. The purpose of this Exception is to allow compilation of non-GPL (including proprietary) programs to use, in this way, the header files and runtime libraries covered by this Exception. 0. Definitions. A file is an "Independent Module" if it either requires the Runtime Library for execution after a Compilation Process, or makes use of an interface provided by the Runtime Library, but is not otherwise based on the Runtime Library. "GCC" means a version of the GNU Compiler Collection, with or without modifications, governed by version 3 (or a specified later version) of the GNU General Public License (GPL) with the option of using any subsequent versions published by the FSF. "GPL-compatible Software" is software whose conditions of propagation, modification and use would permit combination with GCC in accord with the license of GCC. "Target Code" refers to output from any compiler for a real or virtual target processor architecture, in executable form or suitable for input to an assembler, loader, linker and/or execution phase. Notwithstanding that, Target Code does not include data in any format that is used as a compiler intermediate representation, or used for producing a compiler intermediate representation. The "Compilation Process" transforms code entirely represented in non-intermediate languages designed for human-written code, and/or in Java Virtual Machine byte code, into Target Code. Thus, for example, use of source code generators and preprocessors need not be considered part of the Compilation Process, since the Compilation Process can be understood as starting with the output of the generators or preprocessors. A Compilation Process is "Eligible" if it is done using GCC, alone or with other GPL-compatible software, or if it is done without using any work based on GCC. For example, using non-GPL-compatible Software to optimize any GCC intermediate representations would not qualify as an Eligible Compilation Process. 1. Grant of Additional Permission. You have permission to propagate a work of Target Code formed by combining the Runtime Library with Independent Modules, even if such propagation would otherwise violate the terms of GPLv3, provided that all Target Code was generated by Eligible Compilation Processes. You may then convey such a combination under terms of your choice, consistent with the licensing of the Independent Modules. 2. No Weakening of GCC Copyleft. The availability of this Exception does not imply any general presumption that third-party software is unaffected by the copyleft requirements of the license of GCC. gprbuild-25.0.0/COPYING3000066400000000000000000001045131470075373400145420ustar00rootroot00000000000000 GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The GNU General Public License is a free, copyleft license for software and other kinds of works. The licenses for most software and other practical works are designed to take away your freedom to share and change the works. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change all versions of a program--to make sure it remains free software for all its users. We, the Free Software Foundation, use the GNU General Public License for most of our software; it applies also to any other work released this way by its authors. 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 them 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 prevent others from denying you these rights or asking you to surrender the rights. Therefore, you have certain responsibilities if you distribute copies of the software, or if you modify it: responsibilities to respect the freedom of others. For example, if you distribute copies of such a program, whether gratis or for a fee, you must pass on to the recipients the same freedoms that you received. 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. Developers that use the GNU GPL protect your rights with two steps: (1) assert copyright on the software, and (2) offer you this License giving you legal permission to copy, distribute and/or modify it. For the developers' and authors' protection, the GPL clearly explains that there is no warranty for this free software. For both users' and authors' sake, the GPL requires that modified versions be marked as changed, so that their problems will not be attributed erroneously to authors of previous versions. Some devices are designed to deny users access to install or run modified versions of the software inside them, although the manufacturer can do so. This is fundamentally incompatible with the aim of protecting users' freedom to change the software. The systematic pattern of such abuse occurs in the area of products for individuals to use, which is precisely where it is most unacceptable. Therefore, we have designed this version of the GPL to prohibit the practice for those products. If such problems arise substantially in other domains, we stand ready to extend this provision to those domains in future versions of the GPL, as needed to protect the freedom of users. Finally, every program is threatened constantly by software patents. States should not allow patents to restrict development and use of software on general-purpose computers, but in those that do, we wish to avoid the special danger that patents applied to a free program could make it effectively proprietary. To prevent this, the GPL assures that patents cannot be used to render the program non-free. The precise terms and conditions for copying, distribution and modification follow. TERMS AND CONDITIONS 0. Definitions. "This License" refers to version 3 of the GNU General Public License. "Copyright" also means copyright-like laws that apply to other kinds of works, such as semiconductor masks. "The Program" refers to any copyrightable work licensed under this License. Each licensee is addressed as "you". "Licensees" and "recipients" may be individuals or organizations. To "modify" a work means to copy from or adapt all or part of the work in a fashion requiring copyright permission, other than the making of an exact copy. The resulting work is called a "modified version" of the earlier work or a work "based on" the earlier work. A "covered work" means either the unmodified Program or a work based on the Program. To "propagate" a work means to do anything with it that, without permission, would make you directly or secondarily liable for infringement under applicable copyright law, except executing it on a computer or modifying a private copy. Propagation includes copying, distribution (with or without modification), making available to the public, and in some countries other activities as well. To "convey" a work means any kind of propagation that enables other parties to make or receive copies. Mere interaction with a user through a computer network, with no transfer of a copy, is not conveying. An interactive user interface displays "Appropriate Legal Notices" to the extent that it includes a convenient and prominently visible feature that (1) displays an appropriate copyright notice, and (2) tells the user that there is no warranty for the work (except to the extent that warranties are provided), that licensees may convey the work under this License, and how to view a copy of this License. If the interface presents a list of user commands or options, such as a menu, a prominent item in the list meets this criterion. 1. Source Code. The "source code" for a work means the preferred form of the work for making modifications to it. "Object code" means any non-source form of a work. A "Standard Interface" means an interface that either is an official standard defined by a recognized standards body, or, in the case of interfaces specified for a particular programming language, one that is widely used among developers working in that language. The "System Libraries" of an executable work include anything, other than the work as a whole, that (a) is included in the normal form of packaging a Major Component, but which is not part of that Major Component, and (b) serves only to enable use of the work with that Major Component, or to implement a Standard Interface for which an implementation is available to the public in source code form. A "Major Component", in this context, means a major essential component (kernel, window system, and so on) of the specific operating system (if any) on which the executable work runs, or a compiler used to produce the work, or an object code interpreter used to run it. The "Corresponding Source" for a work in object code form means all the source code needed to generate, install, and (for an executable work) run the object code and to modify the work, including scripts to control those activities. However, it does not include the work's System Libraries, or general-purpose tools or generally available free programs which are used unmodified in performing those activities but which are not part of the work. For example, Corresponding Source includes interface definition files associated with source files for the work, and the source code for shared libraries and dynamically linked subprograms that the work is specifically designed to require, such as by intimate data communication or control flow between those subprograms and other parts of the work. The Corresponding Source need not include anything that users can regenerate automatically from other parts of the Corresponding Source. The Corresponding Source for a work in source code form is that same work. 2. Basic Permissions. All rights granted under this License are granted for the term of copyright on the Program, and are irrevocable provided the stated conditions are met. This License explicitly affirms your unlimited permission to run the unmodified Program. The output from running a covered work is covered by this License only if the output, given its content, constitutes a covered work. This License acknowledges your rights of fair use or other equivalent, as provided by copyright law. You may make, run and propagate covered works that you do not convey, without conditions so long as your license otherwise remains in force. You may convey covered works to others for the sole purpose of having them make modifications exclusively for you, or provide you with facilities for running those works, provided that you comply with the terms of this License in conveying all material for which you do not control copyright. Those thus making or running the covered works for you must do so exclusively on your behalf, under your direction and control, on terms that prohibit them from making any copies of your copyrighted material outside their relationship with you. Conveying under any other circumstances is permitted solely under the conditions stated below. Sublicensing is not allowed; section 10 makes it unnecessary. 3. Protecting Users' Legal Rights From Anti-Circumvention Law. No covered work shall be deemed part of an effective technological measure under any applicable law fulfilling obligations under article 11 of the WIPO copyright treaty adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention of such measures. When you convey a covered work, you waive any legal power to forbid circumvention of technological measures to the extent such circumvention is effected by exercising rights under this License with respect to the covered work, and you disclaim any intention to limit operation or modification of the work as a means of enforcing, against the work's users, your or third parties' legal rights to forbid circumvention of technological measures. 4. Conveying Verbatim Copies. You may convey 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; keep intact all notices stating that this License and any non-permissive terms added in accord with section 7 apply to the code; keep intact all notices of the absence of any warranty; and give all recipients a copy of this License along with the Program. You may charge any price or no price for each copy that you convey, and you may offer support or warranty protection for a fee. 5. Conveying Modified Source Versions. You may convey a work based on the Program, or the modifications to produce it from the Program, in the form of source code under the terms of section 4, provided that you also meet all of these conditions: a) The work must carry prominent notices stating that you modified it, and giving a relevant date. b) The work must carry prominent notices stating that it is released under this License and any conditions added under section 7. This requirement modifies the requirement in section 4 to "keep intact all notices". c) You must license the entire work, as a whole, under this License to anyone who comes into possession of a copy. This License will therefore apply, along with any applicable section 7 additional terms, to the whole of the work, and all its parts, regardless of how they are packaged. This License gives no permission to license the work in any other way, but it does not invalidate such permission if you have separately received it. d) If the work has interactive user interfaces, each must display Appropriate Legal Notices; however, if the Program has interactive interfaces that do not display Appropriate Legal Notices, your work need not make them do so. A compilation of a covered work with other separate and independent works, which are not by their nature extensions of the covered work, and which are not combined with it such as to form a larger program, in or on a volume of a storage or distribution medium, is called an "aggregate" if the compilation and its resulting copyright are not used to limit the access or legal rights of the compilation's users beyond what the individual works permit. Inclusion of a covered work in an aggregate does not cause this License to apply to the other parts of the aggregate. 6. Conveying Non-Source Forms. You may convey a covered work in object code form under the terms of sections 4 and 5, provided that you also convey the machine-readable Corresponding Source under the terms of this License, in one of these ways: a) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by the Corresponding Source fixed on a durable physical medium customarily used for software interchange. b) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by a written offer, valid for at least three years and valid for as long as you offer spare parts or customer support for that product model, to give anyone who possesses the object code either (1) a copy of the Corresponding Source for all the software in the product that is covered by this License, on a durable physical medium customarily used for software interchange, for a price no more than your reasonable cost of physically performing this conveying of source, or (2) access to copy the Corresponding Source from a network server at no charge. c) Convey individual copies of the object code with a copy of the written offer to provide the Corresponding Source. This alternative is allowed only occasionally and noncommercially, and only if you received the object code with such an offer, in accord with subsection 6b. d) Convey the object code by offering access from a designated place (gratis or for a charge), and offer equivalent access to the Corresponding Source in the same way through the same place at no further charge. You need not require recipients to copy the Corresponding Source along with the object code. If the place to copy the object code is a network server, the Corresponding Source may be on a different server (operated by you or a third party) that supports equivalent copying facilities, provided you maintain clear directions next to the object code saying where to find the Corresponding Source. Regardless of what server hosts the Corresponding Source, you remain obligated to ensure that it is available for as long as needed to satisfy these requirements. e) Convey the object code using peer-to-peer transmission, provided you inform other peers where the object code and Corresponding Source of the work are being offered to the general public at no charge under subsection 6d. A separable portion of the object code, whose source code is excluded from the Corresponding Source as a System Library, need not be included in conveying the object code work. A "User Product" is either (1) a "consumer product", which means any tangible personal property which is normally used for personal, family, or household purposes, or (2) anything designed or sold for incorporation into a dwelling. In determining whether a product is a consumer product, doubtful cases shall be resolved in favor of coverage. For a particular product received by a particular user, "normally used" refers to a typical or common use of that class of product, regardless of the status of the particular user or of the way in which the particular user actually uses, or expects or is expected to use, the product. A product is a consumer product regardless of whether the product has substantial commercial, industrial or non-consumer uses, unless such uses represent the only significant mode of use of the product. "Installation Information" for a User Product means any methods, procedures, authorization keys, or other information required to install and execute modified versions of a covered work in that User Product from a modified version of its Corresponding Source. The information must suffice to ensure that the continued functioning of the modified object code is in no case prevented or interfered with solely because modification has been made. If you convey an object code work under this section in, or with, or specifically for use in, a User Product, and the conveying occurs as part of a transaction in which the right of possession and use of the User Product is transferred to the recipient in perpetuity or for a fixed term (regardless of how the transaction is characterized), the Corresponding Source conveyed under this section must be accompanied by the Installation Information. But this requirement does not apply if neither you nor any third party retains the ability to install modified object code on the User Product (for example, the work has been installed in ROM). The requirement to provide Installation Information does not include a requirement to continue to provide support service, warranty, or updates for a work that has been modified or installed by the recipient, or for the User Product in which it has been modified or installed. Access to a network may be denied when the modification itself materially and adversely affects the operation of the network or violates the rules and protocols for communication across the network. Corresponding Source conveyed, and Installation Information provided, in accord with this section must be in a format that is publicly documented (and with an implementation available to the public in source code form), and must require no special password or key for unpacking, reading or copying. 7. Additional Terms. "Additional permissions" are terms that supplement the terms of this License by making exceptions from one or more of its conditions. Additional permissions that are applicable to the entire Program shall be treated as though they were included in this License, to the extent that they are valid under applicable law. If additional permissions apply only to part of the Program, that part may be used separately under those permissions, but the entire Program remains governed by this License without regard to the additional permissions. When you convey a copy of a covered work, you may at your option remove any additional permissions from that copy, or from any part of it. (Additional permissions may be written to require their own removal in certain cases when you modify the work.) You may place additional permissions on material, added by you to a covered work, for which you have or can give appropriate copyright permission. Notwithstanding any other provision of this License, for material you add to a covered work, you may (if authorized by the copyright holders of that material) supplement the terms of this License with terms: a) Disclaiming warranty or limiting liability differently from the terms of sections 15 and 16 of this License; or b) Requiring preservation of specified reasonable legal notices or author attributions in that material or in the Appropriate Legal Notices displayed by works containing it; or c) Prohibiting misrepresentation of the origin of that material, or requiring that modified versions of such material be marked in reasonable ways as different from the original version; or d) Limiting the use for publicity purposes of names of licensors or authors of the material; or e) Declining to grant rights under trademark law for use of some trade names, trademarks, or service marks; or f) Requiring indemnification of licensors and authors of that material by anyone who conveys the material (or modified versions of it) with contractual assumptions of liability to the recipient, for any liability that these contractual assumptions directly impose on those licensors and authors. All other non-permissive additional terms are considered "further restrictions" within the meaning of section 10. If the Program as you received it, or any part of it, contains a notice stating that it is governed by this License along with a term that is a further restriction, you may remove that term. If a license document contains a further restriction but permits relicensing or conveying under this License, you may add to a covered work material governed by the terms of that license document, provided that the further restriction does not survive such relicensing or conveying. If you add terms to a covered work in accord with this section, you must place, in the relevant source files, a statement of the additional terms that apply to those files, or a notice indicating where to find the applicable terms. Additional terms, permissive or non-permissive, may be stated in the form of a separately written license, or stated as exceptions; the above requirements apply either way. 8. Termination. You may not propagate or modify a covered work except as expressly provided under this License. Any attempt otherwise to propagate or modify it is void, and will automatically terminate your rights under this License (including any patent licenses granted under the third paragraph of section 11). However, if you cease all violation of this License, then your license from a particular copyright holder is reinstated (a) provisionally, unless and until the copyright holder explicitly and finally terminates your license, and (b) permanently, if the copyright holder fails to notify you of the violation by some reasonable means prior to 60 days after the cessation. Moreover, your license from a particular copyright holder is reinstated permanently if the copyright holder notifies you of the violation by some reasonable means, this is the first time you have received notice of violation of this License (for any work) from that copyright holder, and you cure the violation prior to 30 days after your receipt of the notice. Termination of your rights under this section does not terminate the licenses of parties who have received copies or rights from you under this License. If your rights have been terminated and not permanently reinstated, you do not qualify to receive new licenses for the same material under section 10. 9. Acceptance Not Required for Having Copies. You are not required to accept this License in order to receive or run a copy of the Program. Ancillary propagation of a covered work occurring solely as a consequence of using peer-to-peer transmission to receive a copy likewise does not require acceptance. However, nothing other than this License grants you permission to propagate or modify any covered work. These actions infringe copyright if you do not accept this License. Therefore, by modifying or propagating a covered work, you indicate your acceptance of this License to do so. 10. Automatic Licensing of Downstream Recipients. Each time you convey a covered work, the recipient automatically receives a license from the original licensors, to run, modify and propagate that work, subject to this License. You are not responsible for enforcing compliance by third parties with this License. An "entity transaction" is a transaction transferring control of an organization, or substantially all assets of one, or subdividing an organization, or merging organizations. If propagation of a covered work results from an entity transaction, each party to that transaction who receives a copy of the work also receives whatever licenses to the work the party's predecessor in interest had or could give under the previous paragraph, plus a right to possession of the Corresponding Source of the work from the predecessor in interest, if the predecessor has it or can get it with reasonable efforts. You may not impose any further restrictions on the exercise of the rights granted or affirmed under this License. For example, you may not impose a license fee, royalty, or other charge for exercise of rights granted under this License, and you may not initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging that any patent claim is infringed by making, using, selling, offering for sale, or importing the Program or any portion of it. 11. Patents. A "contributor" is a copyright holder who authorizes use under this License of the Program or a work on which the Program is based. The work thus licensed is called the contributor's "contributor version". A contributor's "essential patent claims" are all patent claims owned or controlled by the contributor, whether already acquired or hereafter acquired, that would be infringed by some manner, permitted by this License, of making, using, or selling its contributor version, but do not include claims that would be infringed only as a consequence of further modification of the contributor version. For purposes of this definition, "control" includes the right to grant patent sublicenses in a manner consistent with the requirements of this License. Each contributor grants you a non-exclusive, worldwide, royalty-free patent license under the contributor's essential patent claims, to make, use, sell, offer for sale, import and otherwise run, modify and propagate the contents of its contributor version. In the following three paragraphs, a "patent license" is any express agreement or commitment, however denominated, not to enforce a patent (such as an express permission to practice a patent or covenant not to sue for patent infringement). To "grant" such a patent license to a party means to make such an agreement or commitment not to enforce a patent against the party. If you convey a covered work, knowingly relying on a patent license, and the Corresponding Source of the work is not available for anyone to copy, free of charge and under the terms of this License, through a publicly available network server or other readily accessible means, then you must either (1) cause the Corresponding Source to be so available, or (2) arrange to deprive yourself of the benefit of the patent license for this particular work, or (3) arrange, in a manner consistent with the requirements of this License, to extend the patent license to downstream recipients. "Knowingly relying" means you have actual knowledge that, but for the patent license, your conveying the covered work in a country, or your recipient's use of the covered work in a country, would infringe one or more identifiable patents in that country that you have reason to believe are valid. If, pursuant to or in connection with a single transaction or arrangement, you convey, or propagate by procuring conveyance of, a covered work, and grant a patent license to some of the parties receiving the covered work authorizing them to use, propagate, modify or convey a specific copy of the covered work, then the patent license you grant is automatically extended to all recipients of the covered work and works based on it. A patent license is "discriminatory" if it does not include within the scope of its coverage, prohibits the exercise of, or is conditioned on the non-exercise of one or more of the rights that are specifically granted under this License. You may not convey a covered work if you are a party to an arrangement with a third party that is in the business of distributing software, under which you make payment to the third party based on the extent of your activity of conveying the work, and under which the third party grants, to any of the parties who would receive the covered work from you, a discriminatory patent license (a) in connection with copies of the covered work conveyed by you (or copies made from those copies), or (b) primarily for and in connection with specific products or compilations that contain the covered work, unless you entered into that arrangement, or that patent license was granted, prior to 28 March 2007. Nothing in this License shall be construed as excluding or limiting any implied license or other defenses to infringement that may otherwise be available to you under applicable patent law. 12. No Surrender of Others' Freedom. If 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 convey a covered work so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not convey it at all. For example, if you agree to terms that obligate you to collect a royalty for further conveying from those to whom you convey the Program, the only way you could satisfy both those terms and this License would be to refrain entirely from conveying the Program. 13. Use with the GNU Affero General Public License. Notwithstanding any other provision of this License, you have permission to link or combine any covered work with a work licensed under version 3 of the GNU Affero General Public License into a single combined work, and to convey the resulting work. The terms of this License will continue to apply to the part which is the covered work, but the special requirements of the GNU Affero General Public License, section 13, concerning interaction through a network will apply to the combination as such. 14. Revised Versions of this License. The Free Software Foundation may publish revised and/or new versions of the GNU 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 that a certain numbered version of the GNU General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that numbered version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the GNU General Public License, you may choose any version ever published by the Free Software Foundation. If the Program specifies that a proxy can decide which future versions of the GNU General Public License can be used, that proxy's public statement of acceptance of a version permanently authorizes you to choose that version for the Program. Later license versions may give you additional or different permissions. However, no additional obligations are imposed on any author or copyright holder as a result of your choosing to follow a later version. 15. Disclaimer of Warranty. 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. 16. Limitation of Liability. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS 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. 17. Interpretation of Sections 15 and 16. If the disclaimer of warranty and limitation of liability provided above cannot be given local legal effect according to their terms, reviewing courts shall apply local law that most closely approximates an absolute waiver of all civil liability in connection with the Program, unless a warranty or assumption of liability accompanies a copy of the Program in return for a fee. 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 state 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) 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 3 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, see . Also add information on how to contact you by electronic and paper mail. If the program does terminal interaction, make it output a short notice like this when it starts in an interactive mode: Copyright (C) This program 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, your program's commands might be different; for a GUI interface, you would use an "about box". You should also get your employer (if you work as a programmer) or school, if any, to sign a "copyright disclaimer" for the program, if necessary. For more information on this, and how to apply and follow the GNU GPL, see . The GNU 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 Lesser General Public License instead of this License. But first, please read . gprbuild-25.0.0/Makefile000066400000000000000000000140701470075373400150620ustar00rootroot00000000000000# Makefile targets # ---------------- # # Setup: make [VAR=VALUE] setup (see below) # Build gprbuild: make all # Install gprbuild: make install # Create gprbuild package: make distall # Build tool : make # Build libgpr: make libgpr.build # Install libgpr: make libgpr.install # (for libgpr you can add ".type" where type is static, static-pic or shared # build a specific version of the lib. by default all supported variants are # built). # Variables which can be set: # # ENABLE_SHARED : yes / no (or empty) # BUILD : debug production coverage profiling # PROCESSORS : nb parallel compilations (0 to use all cores) # TARGET : target triplet for cross-compilation # # Out-of-tree build: # # $ make -f /Makefile setup # $ make -f /Makefile HOST := $(shell gcc -dumpmachine) TARGET := $(shell gcc -dumpmachine) prefix := $(dir $(shell which gnatls)).. BUILD = production PROCESSORS = 0 BUILD_DIR = SOURCE_DIR := $(shell dirname "$(MAKEFILE_LIST)") LIB_DIR = lib/ # Load current setup if any -include makefile.setup # target options for cross-build ifeq ($(HOST),$(TARGET)) GTARGET= # INSTALLER=exe/$(BUILD)/$(LIB_INSTALLER) else GTARGET=--target=$(TARGET) endif INSTALLER=$(LIB_INSTALLER) EXEC_INSTALLER=$(INSTALLER) -XBUILD=${BUILD} # check for out-of-tree build ifeq ($(SOURCE_DIR),.) RBD= GPRBUILD_GPR=gprbuild.gpr GPR_GPR=gpr/gpr.gpr MAKEPREFIX= else RBD=--relocate-build-tree GPRBUILD_GPR=$(SOURCE_DIR)/gprbuild.gpr GPR_GPR=$(SOURCE_DIR)/gpr/gpr.gpr MAKEPREFIX=$(SOURCE_DIR)/ endif ENABLE_SHARED := $(shell gprbuild $(GTARGET) -c -q -p \ -P$(MAKEPREFIX)config/test_shared 2>/dev/null && echo "yes") ifeq ($(ENABLE_SHARED), yes) LIBGPR_TYPES=static shared static-pic else LIBGPR_TYPES=static endif # Make sure Windows's "OS" environment variable does not cause # confusion for cross-Linux builds. LIBGPR_OS = $(if $(findstring linux,$(TARGET)),-XOS=UNIX) # Used to pass extra options to GPRBUILD, like -d for instance GPRBUILD_OPTIONS= BUILDER=gprbuild -p -m $(GTARGET) $(RBD) -j${PROCESSORS} -XBUILD=${BUILD} ${GPRBUILD_OPTIONS} LIB_INSTALLER=gprinstall -p -f --target=$(TARGET) $(RBD) "--prefix=${prefix}" CLEANER=gprclean -q $(RBD) GPRBUILD_BUILDER=$(BUILDER) $(GPRBUILD_GPR) \ -XLIBRARY_TYPE=static -XXMLADA_BUILD=static LIBGPR_BUILDER=$(BUILDER) $(GPR_GPR) $(LIBGPR_OS) LIBGPR_INSTALLER=$(LIB_INSTALLER) $(GPR_GPR) $(LIBGPR_OS) -XBUILD=${BUILD} \ --install-name=gpr \ --build-var=LIBRARY_TYPE --build-var=GPR_BUILD $(GTARGET) LIBGPR_UNINSTALLER=$(LIB_INSTALLER) $(GPR_GPR) $(LIBGPR_OS) --install-name=gpr --uninstall ######### # build # ######### .PHONY: all distall gprbuild gprconfig gprclean gprinstall gprname gprls build all: $(GPRBUILD_BUILDER) distall: all install gprbuild: $(GPRBUILD_BUILDER) gprbuild-main.adb gprinstall: $(GPRBUILD_BUILDER) gprinstall-main.adb gprclean: $(GPRBUILD_BUILDER) gprclean-main.adb gprconfig: $(GPRBUILD_BUILDER) gprconfig-main.adb gprname: $(GPRBUILD_BUILDER) gprname-main.adb gprls: $(GPRBUILD_BUILDER) gprls-main.adb ################################# # Gprbuild installation targets # ################################# .PHONY: install install: $(EXEC_INSTALLER) --mode=usage --install-name=gprbuild \ -XINSTALL_MODE=nointernal $(GPRBUILD_GPR) $(EXEC_INSTALLER) --target=$(TARGET) --mode=usage --install-name=gprbuild \ -XINSTALL_MODE=internal $(GPRBUILD_GPR) complete: all install libgpr.install.static ########## # Libgpr # ########## .PHONY: libgpr.build libgpr.build.static libgpr.build.shared libgpr.build.static-pic .PHONY: libgpr.install libgpr.install.static libgpr.install.shared libgpr.install.static-pic .PHONY: libgpr.uninstall libgpr.build: $(foreach t, $(LIBGPR_TYPES), libgpr.build.$(t)) libgpr.build.shared: ${LIBGPR_BUILDER} -XLIBRARY_TYPE=relocatable \ -XXMLADA_BUILD=relocatable libgpr.build.static: ${LIBGPR_BUILDER} -XLIBRARY_TYPE=static \ -XXMLADA_BUILD=static libgpr.build.static-pic: ${LIBGPR_BUILDER} -XLIBRARY_TYPE=static-pic \ -XXMLADA_BUILD=static-pic libgpr.install: libgpr.uninstall $(foreach t, $(LIBGPR_TYPES), libgpr.install.$(t)) libgpr.install.static: $(LIBGPR_INSTALLER) \ -XLIBRARY_TYPE=static \ -XXMLADA_BUILD=static \ --lib-subdir=${LIB_DIR}/gpr/static \ --build-name=static libgpr.install.static-pic: $(LIBGPR_INSTALLER) \ -XLIBRARY_TYPE=static-pic \ -XXMLADA_BUILD=static-pic \ --lib-subdir=${LIB_DIR}/gpr/static-pic \ --build-name=static-pic libgpr.install.shared: $(LIBGPR_INSTALLER) \ -XLIBRARY_TYPE=relocatable \ -XXMLADA_BUILD=relocatable \ --lib-subdir=${LIB_DIR}/gpr/relocatable \ --build-name=relocatable libgpr.uninstall: -$(LIBGPR_UNINSTALLER) libgpr.clean: -$(CLEANER) -XLIBRARY_TYPE=relocatable $(GPR_GPR) -$(CLEANER) -XLIBRARY_TYPE=static $(GPR_GPR) -$(CLEANER) -XLIBRARY_TYPE=static-pic $(GPR_GPR) rm -fr gpr/lib gpr/libobj ######### # setup # ######### .SILENT: setup setup: echo "prefix=$(prefix)" > makefile.setup echo "ENABLE_SHARED=$(ENABLE_SHARED)" >> makefile.setup echo "BUILD=$(BUILD)" >> makefile.setup echo "PROCESSORS=$(PROCESSORS)" >> makefile.setup echo "TARGET=$(TARGET)" >> makefile.setup echo "SOURCE_DIR=$(SOURCE_DIR)" >> makefile.setup ################### # Cleanup targets # ################### .PHONY: clean clean: libgpr.clean -$(CLEANER) -r -Pgprbuild -XBUILD=$(BUILD) -$(CLEANER) -r -XBUILD=${BUILD} \ -XLIBRARY_TYPE=static-pic $(GPR_GPR) -$(CLEANER) -r -XBUILD=${BUILD} \ -XLIBRARY_TYPE=static $(GPR_GPR) ifeq ($(ENABLE_SHARED), yes) -$(CLEANER) -r -XBUILD=${BUILD} \ -XLIBRARY_TYPE=relocatable $(GPR_GPR) -$(CLEANER) $(GPR_GPR) -XBUILD=$(BUILD) \ -XLIBRARY_TYPE=relocatable endif make -C $(MAKEPREFIX)doc clean make -C $(MAKEPREFIX)examples clean rm -fr obj exe makefile.setup .PHONY: doc examples doc: make -C $(MAKEPREFIX)doc examples: force make -C $(MAKEPREFIX)examples force: # Let gprbuild handle parallelization. In general, we don't support parallel # runs in this Makefile, as concurrent gprinstall processes may crash. .NOTPARALLEL: gprbuild-25.0.0/README.md000066400000000000000000000050121470075373400146750ustar00rootroot00000000000000Preliminary note for Windows users ================================== The build instructions for `gprbuild` may have a slight UNIX flavor but they can be used on Windows platforms with a full Cygwin installation. The latter makes it simpler to build `gprbuild` but is not required to use it. Bootstrapping ============= `gprbuild` needs `gprbuild` to build... So we also provide a way to easily bootstrap if you don't already have `gprbuild`, provided you already have installed GNAT. Download XML/Ada sources (from https://github.com/AdaCore/xmlada), together with the gprconfig knowledge base (from https://github.com/AdaCore/gprconfig_kb). Run the `bootstrap.sh` script (written for POSIX systems) specifying the install location and the sources of `XML/Ada` and `gprconfig_kb`. The script will build *and* install `gprbuild`. For example, to build `gprbuild` and install it to `./bootstrap` in the current working directory, run: $ ./bootstrap.sh --with-xmlada=../xmlada --with-kb=../gprconfig_kb --prefix=./bootstrap For maintainers, the environment `DESTDIR` is honoured for staged installs, see `./bootstrap.sh -h` for more. With this bootstrapped `gprbuild`, you can build XML/Ada and `gprbuild` as documented below. Configuring =========== You should first configure the build like this (if you plan to build in the source tree directly, you can omit setting the SOURCE_DIR variable): $ make prefix=xxx SOURCE_DIR=/path/to/gprbuild/sources setup Building and Installing ======================= XML/Ada must be installed before building. Building the main executables is done simply with: $ make all When compiling, you can choose whether you want to link statically with XML/Ada (the default), or dynamically. To compile dynamically, you should run: $ make LIBRARY_TYPE=relocatable all instead of the above. Installation is done with: $ make install To build and install LIBGPR libraries, you can use the make targets libgpr.build and libgpr.install. Doc & Examples ============== The documentation is provided in various formats in the `doc` subdirectory. You can also find it [online](http://docs.adacore.com/gprbuild-docs/html/gprbuild_ug.html). It refers to concrete examples that are to be found in the `examples` subdirectory. Each example can be built easily using the simple attached Makefile: $ make all # build the example $ make run # run the executable(s) $ make clean # cleanup All the examples can be `built/run/cleaned` using the same targets and the top level examples Makefile. gprbuild-25.0.0/bootstrap.sh000077500000000000000000000072041470075373400157770ustar00rootroot00000000000000#!/bin/sh # bootstrap.sh - a simple bootstrap for building gprbuild with xmlada progname=bootstrap prefix=/usr/local bindir=/bin datarootdir=/share libexecdir=/libexec srcdir=$PWD xmlada_src=../xmlada kb_src=../gprconfig_kb CC=${CC:-cc} GNATMAKE=${GNATMAKE:-gnatmake} CFLAGS=${CFLAGS:-$CFLAGS} GNATMAKEFLAGS=${GNATMAKEFLAGS:--j0} usage() { cat >&2 <&2 exit 1 } while :; do case $1 in --prefix=?*) prefix=${1#*=} ;; --bindir=?*) bindir=${1#*=} ;; --libexecdir=?*) libexecdir=${1#*=} ;; --datarootdir=?*) datarootdir=${1#*=} ;; --srcdir=?*) srcdir=${1#*=} ;; --with-xmlada=?*) xmlada_src=${1#*=} ;; --with-kb=?*) kb_src=${1#*=} ;; --build) MODE="build";; --install) MODE="install";; -h|-\?|--help) usage ;; *=*) error '%s: Requires a value, try --help\n' "$1" ;; -?*) error '%s: Unknown option, try --help\n' "$1" ;; *) break # End of arguments. esac shift done set -e inc_flags="-I$srcdir/src -I$srcdir/gpr/src -I$xmlada_src/sax -I$xmlada_src/dom \ -I$xmlada_src/schema -I$xmlada_src/unicode -I$xmlada_src/input_sources" # Programs to build and install bin_progs="gprbuild gprconfig gprclean gprinstall gprname gprls" lib_progs="gprlib gprbind" # Install the gprconfig knowledge base rm -rf "$srcdir"/share/gprconfig cp -r "$kb_src"/db "$srcdir"/share/gprconfig # Windows and Unix differencies UName=`uname | cut -b -5` PutUsage=gpr/src/gpr-util-put_resource_usage rm -f ${PutUsage}.adb if [ "$UName" = "CYGWI" ] || [ "$UName" = "MINGW" ] then cp ${PutUsage}__null.adb ${PutUsage}.adb else ln -s $PWD/${PutUsage}__unix.adb ${PutUsage}.adb fi # Build if [ "x"${MODE} = "x" ] || [ ${MODE} = "build" ]; then command $CC -c $CFLAGS "$srcdir"/gpr/src/gpr_imports.c for bin in $bin_progs; do command $GNATMAKE $inc_flags "$bin"-main -o "$bin" $CFLAGS $GNATMAKEFLAGS -largs gpr_imports.o done for lib in $lib_progs; do command $GNATMAKE $inc_flags "$lib" $CFLAGS $GNATMAKEFLAGS -largs gpr_imports.o done fi; # Install if [ "x"${MODE} = "x" ] || [ ${MODE} = "install" ]; then mkdir -p "$DESTDIR$prefix$bindir" mkdir -p "$DESTDIR$prefix$libexecdir"/gprbuild mkdir -p "$DESTDIR$prefix$datarootdir"/gprconfig mkdir -p "$DESTDIR$prefix$datarootdir"/gpr install -m0755 $bin_progs "$DESTDIR$prefix$bindir" install -m0755 $lib_progs "$DESTDIR$prefix$libexecdir"/gprbuild install -m0644 "$srcdir"/share/gprconfig/*.xml "$DESTDIR$prefix$datarootdir"/gprconfig install -m0644 "$srcdir"/share/gprconfig/*.ent "$DESTDIR$prefix$datarootdir"/gprconfig install -m0644 "$srcdir"/share/_default.gpr "$DESTDIR$prefix$datarootdir"/gpr/_default.gpr fi gprbuild-25.0.0/config/000077500000000000000000000000001470075373400146655ustar00rootroot00000000000000gprbuild-25.0.0/config/foo.ads000066400000000000000000000025301470075373400161410ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2016-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ package Foo is end Foo; gprbuild-25.0.0/config/test_shared.gpr000066400000000000000000000030171470075373400177050ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2004-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ library project Test_Shared is for Source_Dirs use ("."); for Object_Dir use "obj"; for Library_Dir use "lib"; for Library_Name use "lib"; for Library_Kind use "relocatable"; end Test_Shared; gprbuild-25.0.0/debug.adc000066400000000000000000000000331470075373400151530ustar00rootroot00000000000000pragma Initialize_Scalars; gprbuild-25.0.0/doc/000077500000000000000000000000001470075373400141655ustar00rootroot00000000000000gprbuild-25.0.0/doc/Makefile000066400000000000000000000032351470075373400156300ustar00rootroot00000000000000# Makefile for Sphinx documentation # You can set these variables from the command line. SPHINXOPTS = SPHINXBUILD = sphinx-build PAPER = BUILDDIR = . SOURCEDIR = . # Internal variables. PAPEROPT_a4 = -D latex_paper_size=a4 PAPEROPT_letter = -D latex_paper_size=letter ALLSPHINXOPTS = $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) \ -c $(SOURCEDIR)/share \ -d $(BUILDDIR)/$*/doctrees \ $(SOURCEDIR) FMT_LIST=html txt info pdf DOC_NAME=gprbuild_ug CP=cp .PHONY: help clean all: $(foreach fmt, $(FMT_LIST), $(fmt)) help: @echo "Please use \`make ' where is one of" @echo " html to make standalone HTML files" @echo " pdf to make LaTeX files and run them through pdflatex" @echo " txt to make text files" @echo " texinfo to make Texinfo files" @echo " info to make info files" @echo " all to build documentation in all formats" @echo "" @echo "source and location can be overriden using SOURCEDIR and BUILDDIR variables" clean: -rm -rf $(BUILDDIR)/html \ $(BUILDDIR)/pdf \ $(BUILDDIR)/txt \ $(BUILDDIR)/info \ $(BUILDDIR)/doctrees \ share/__pycache__ html: force $(SPHINXBUILD) -b html $(ALLSPHINXOPTS) $(BUILDDIR)/html pdf: force $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/pdf $(MAKE) -C $(BUILDDIR)/pdf all-pdf LATEXOPTS="-interaction=nonstopmode" txt: force $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/$*/txt $(MAKE) -C $(BUILDDIR)/txt plaintext info: force $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/$*/info $(MAKE) -C $(BUILDDIR)/info info texinfo: $(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/$*/texinfo force: gprbuild-25.0.0/doc/gprbuild_gps.xml000066400000000000000000000006711470075373400173740ustar00rootroot00000000000000 share/doc/gprbuild/html /Help/Gprbuild gprbuild_ug.html Gprbuild User's Guide GNAT /Help/Gprbuild/Gprbuild User's Guide gprbuild-25.0.0/doc/gprbuild_ug.rst000066400000000000000000000014001470075373400172150ustar00rootroot00000000000000GPRbuild and GPR Companion Tools User's Guide ============================================= | Version |version| | Date: |today| AdaCore Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.3 or any later version published by the Free Software Foundation; with no Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. A copy of the license is included in the section entitled :ref:`gnu_fdl`. .. toctree:: :numbered: :maxdepth: 3 gprbuild_ug/introduction gprbuild_ug/gnat_project_manager gprbuild_ug/building_with_gprbuild gprbuild_ug/companion_tools .. raw:: latex \appendix .. toctree:: :maxdepth: 3 share/gnu_free_documentation_license gprbuild-25.0.0/doc/gprbuild_ug/000077500000000000000000000000001470075373400164705ustar00rootroot00000000000000gprbuild-25.0.0/doc/gprbuild_ug/building_with_gprbuild.rst000066400000000000000000001305651470075373400237540ustar00rootroot00000000000000.. _Building_with_GPRbuild: ********************** Building with GPRbuild ********************** .. _Building_with_GPRbuild_Introduction: Introduction ============ `GPRbuild` is a generic build tool designed for the construction of large multi-language systems organized into subsystems and libraries. It is well-suited for compiled languages supporting separate compilation, such as Ada, C, C++ and Fortran. `GPRbuild` manages a three step build process. * compilation phase: Each compilation unit of each subsystem is examined in turn, checked for consistency, and compiled or recompiled when necessary by the appropriate compiler. The recompilation decision is based on dependency information that is typically produced by a previous compilation. * post-compilation phase (or binding): Compiled units from a given language are passed to a language-specific post-compilation tool if any. Also during this phase objects are grouped into static or dynamic libraries as specified. * linking phase: All units or libraries from all subsystems are passed to a linker tool specific to the set of toolchains being used. The tool is generic in that it provides, when possible, equivalent build capabilities for all supported languages. For this, it uses a configuration file :file:`.cgpr` that has a syntax and structure very similar to a project file, but which defines the characteristics of the supported languages and toolchains. The configuration file contains information such as: * the default source naming conventions for each language, * the compiler name, location and required options, * how to compute inter-unit dependencies, * how to build static or dynamic libraries, * which post-compilation actions are needed, * how to link together units from different languages. On the other hand, `GPRbuild` is not a replacement for general-purpose build tools such as `make` or `ant` which give the user a high level of control over the build process itself. When building a system requires complex actions that do not fit well in the three-phase process described above, `GPRbuild` might not be sufficient. In such situations, `GPRbuild` can still be used to manage the appropriate part of the build. For instance it can be called from within a Makefile. .. _Command_Line: Command Line ============ Three elements can optionally be specified on GPRbuild's command line: * the main project file, * the switches for GPRbuild itself or for the tools it drives, and * the main source files. The general syntax is thus: :: gprbuild [.gpr] [switches] [names] {[-cargs opts] [-cargs:lang opts] [-largs opts] [-kargs opts] [-gargs opts]} GPRbuild requires a project file, which may be specified on the command line either directly or through the :samp:`-P` switch. If not specified, GPRbuild uses the project file :file:`default.gpr` if there is one in the current working directory. Otherwise, if there is only one project file in the current working directory, GPRbuild uses this project file. Main source files represent the sources to be used as the main programs. If they are not specified on the command line, GPRbuild uses the source files specified with the `Main` attribute in the project file. If none exists, then no executable will be built. It is also possible to specify absolute file names, or file names relative to the current directory. When source files are specified along with the option :samp:`-c`, then recompilation will be considered only for those source files. In all other cases, GPRbuild compiles or recompiles all sources in the project tree that are not up to date, and builds or rebuilds libraries that are not up to date. If invoked without the :samp:`--config=` or :samp:`--autoconf=` options, then GPRbuild will look for a configuration project file. The file name or path name of this configuration project file depends on the target, the runtime and environment variable `GPR_CONFIG` See :ref:`Configuring_with_GPRconfig`. If there is no such file in the default locations expected by GPRbuild (/share/gpr and the current directory) then GPRbuild will invoke GPRconfig with the languages from the project files, and create a configuration project file :file:`auto.cgpr` in the object directory of the main project. The project :file:`auto.cgpr` will be rebuilt at each GPRbuild invocation unless you use the switch :samp:`--autoconf=path/auto.cgpr`, which will use the configuration project file if it exists and create it otherwise. Options given on the GPRbuild command line may be passed along to individual tools by preceding them with one of the "command line separators" shown below. Options following the separator, up to the next separator (or end of the command line), are passed along. The different command line separators are: * :samp:`-cargs` The arguments that follow up to the next command line separator are options for all compilers for all languages. Example: :samp:`-cargs` :samp:`-g` * :samp:`-cargs:{language name}` The arguments that follow up to the next command line separator are options for the compiler of the specific language. Examples: * :samp:`-cargs:Ada -gnatf` * :samp:`-cargs:C -E` * :samp:`-bargs` The arguments that follow up to the next command line separator are options for all binder drivers. * :samp:`-bargs:{language name}` The arguments that follow up to the next command line separators are options for the binder driver of the specific language. Examples: * :samp:`-bargs:Ada binder_prefix=ppc-elf` * :samp:`-bargs:C++ c_compiler_name=ccppc` * :samp:`-largs` The arguments that follow up to the next command line separator are options for the linker, when linking an executable. * :samp:`-kargs` The arguments that follow up to the next command line separator are options for gprconfig when performing auto-configuration. * :samp:`-gargs` The arguments that follow up to the next command line separator are options for GPRbuild itself. Usually :samp:`-gargs` is specified after one or several other command line separators. * :samp:`-margs` Equivalent to :samp:`-gargs`, provided for compatibility with *gnatmake*. .. _Switches: Switches ======== GPRbuild takes into account switches that may be specified on the command line or in attributes Switches(
) or Default_Switches () in package Builder of the main project. When there are a single main (specified on the command line or in attribute Main in the main project), the switches that are taken into account in package Builder of the main project are Switches (
), if declared, or Switches (), if declared. When there are several mains, if there are sources of the same language, then Switches () is taken into account, if specified. When there are no main specified, if there is only one compiled language (that is a language with a non empty Compiler Driver), then Switches () is taken into account, if specified. The switches that are interpreted directly by GPRbuild are listed below. First, the switches that may be specified only on the command line, but not in package Builder of the main project: * :samp:`--build-script=` This switch is not compatible with :samp:`--distributed=`. When this switch is specified, a shell script is created. Provided that the temporary files created by gprbuild are not deleted, running this script should perform the same build as the invocation of gprbuild, with the same sources. * :samp:`--no-project` This switch cannot be used if a project file is specified on the command line. When this switch is specified, it indicates to gprbuild that the project files in the current directory should not be considered and that the default project file in /share/gpr is to be used. It is usually used with one or several mains specified on the command line. * :samp:`--no-complete-output` Synonym: :samp:`-n`. By default, gprbuild redirects the standard output and the standard error of the compilations to different text files. This allows to inspect the results afterwards, and also ensures that parallel processes do not clobber each other's output. When this switch is specified, these files are not created and individual compilations output directly to common standard streams. * :samp:`--complete-output` This switch is not compatible with :samp:`--distributed=`. When this switch is specified, if a source is up to date and compilation log files exist, their contents are sent to standard output and standard error. This allows to redisplay any warning or info from the last invocation of gprbuild. * :samp:`--distributed[={slave1}[,{slave2}]]` This switch is not compatible with :samp:`--complete-output`, or with :samp:`--build-script=`. Activate the distributed compilation on the listed slaves nodes (IP or name). Or if no slave are specified they are search in `GPR_SLAVES` or `GPR_SLAVES_FILE` environment variables. see :ref:`Distributed_compilation`. * :samp:`--hash={string}` Specify an hash string. This is just a value which is checked against the GPRslave hash value. If GPRslave has a hash value specified this string must match, otherwise it is ignored. For example: :: $ gprbuild --hash=$(echo $ADA_PROJECT_PATH | shasum) --distributed=... * :samp:`--slave-env={name}` Use name as the slave's environment directory instead of the default one. This options is only used in distributed mode. * :samp:`--version` Display information about GPRbuild: version, origin and legal status, then exit successfully, ignoring other options. * :samp:`--help` Display GPRbuild usage, then exit successfully, ignoring other options. * :samp:`--display-paths` Display two lines: the configuration project file search path and the user project file search path, then exit successfully, ignoring other options. * :samp:`--config={config project file name}` This specifies the configuration project file name. By default, the configuration project file name is :file:`default.cgpr`. Option :samp:`--config=` cannot be specified more than once. The configuration project file specified with :samp:`--config=` must exist. * :samp:`--autoconf={config project file name}` This specifies a configuration project file name that already exists or will be created automatically. Option :samp:`--autoconf=` cannot be specified more than once. If the configuration project file specified with :samp:`--autoconf=` exists, then it is used. Otherwise, GPRconfig is invoked to create it automatically. * :samp:`--target={targetname}` This specifies that the default configuration project file is :file:`.cgpr`. If no configuration project file with this name is found, then GPRconfig is invoked with option :samp:`--target={targetname}` to create a configuration project file :file:`auto.cgpr`. Note: only one of :samp:`--config`, :samp:`--autoconf` or :samp:`--target=` can be specified. * :samp:`--implicit-with={project file name}` Adds a given project as an implicit dependency to every project in the build tree by creating an implicit "limited with" clause at the start of each project. This switch can only appear once on the command line. * :samp:`--subdirs={subdir}` This indicates that the object, library and executable directories specified in the project file will be suffixed with {subdir}. If needed, those subdirectories are created except for externally built projects: in this case if the subdirectories already exist they are used, otherwise the base directories are used. * :samp:`--src-subdirs={subdir}` This adds the given subdirectory (relative to each object directory of the project tree) to the list of source directories of the project, one directory per object directory. This is useful for overriding temporarily some source files for the purpose of e.g. source instrumentation such as source coverage or preprocessing. This option may be combined with :samp:`--subdirs`. * :samp:`--relocate-build-tree[={dir}]` With this option it is possible to achieve out-of-tree build. That is, real object, library or exec directories are relocated to the current working directory or dir if specified. * :samp:`--root-dir={dir}` This option is to be used with --relocate-build-tree above and cannot be specified alone. This option specifies the root directory for artifacts for proper relocation. The default value is the main project directory. This may not be suitable for relocation if for example some artifact directories are in parent directory of the main project. The specified directory must be a parent of all artifact directories. * :samp:`--unchecked-shared-lib-imports` Allow shared library projects to import projects that are not shared library projects. * :samp:`--source-info={source info file}` Specify a source info file. If the source info file is specified as a relative path, then it is relative to the object directory of the main project. If the source info file does not exist, then after the Project Manager has successfully parsed and processed the project files and found the sources, it creates the source info file. If the source info file already exists and can be read successfully, then the Project Manager will get all the needed information about the sources from the source info file and will not look for them. This reduces the time to process the project files, especially when looking for sources that take a long time. If the source info file exists but cannot be parsed successfully, the Project Manager will attempt to recreate it. If the Project Manager fails to create the source info file, a message is issued, but GPRbuild does not fail. * :samp:`--restricted-to-languages={list of language names}` Restrict the sources to be compiled to one or several languages. Each language name in the list is separated from the next by a comma, without any space. Example: :samp:`--restricted-to-languages=Ada,C` When this switch is used, switches :samp:`-c`, :samp:`-b` and :samp:`-l` are ignored. Only the compilation phase is performed and the sources that are not in the list of restricted languages are not compiled, including mains specified in package Builder of the main project. * :samp:`--no-sal-binding` Specify to GPRbuild to not rebind a Stand-Alone Library (SAL), but instead to reuse the files created during a previous build of the SAL. GPRbuild will fail if there are missing files. This option is unsafe and not recommended, as it may result in incorrect binding of the SAL, for example if sources have been added, removed or modified in a significant way related to binding. It is only provided to improve performance, when it is known that the resulting binding files will be the same as the previous ones. * :samp:`-aP {dir}` (Add directory :file:`dir` to project search path) Specify to GPRbuild to add directory :file:`dir` to the user project file search path, before the default directory. * :samp:`-d` (Display progress) Display progress for each source, up to date or not, as a single line *completed x out of y (zz%)...*. If the file needs to be compiled this is displayed after the invocation of the compiler. These lines are displayed even in quiet output mode (switch :samp:`-q`). * :samp:`-I{nn}` (Index of main unit in multi-unit source file) Indicate the index of the main unit in a multi-unit source file. The index must be a positive number and there should be one and only one main source file name on the command line. * :samp:`-eL` (Follow symbolic links when processing project files) By default, symbolic links on project files are not taken into account when processing project files. Switch :samp:`-eL` changes this default behavior. * :samp:`-eS` (no effect) This switch is only accepted for compatibility with gnatmake, but it has no effect. For gnatmake, it means: echo commands to standard output instead of standard error, but for gprbuild, commands are always echoed to standard output. * :samp:`-F` (Full project path name in brief error messages) By default, in non verbose mode, when an error occurs while processing a project file, only the simple name of the project file is displayed in the error message. When switch :samp:`-F` is used, the full path of the project file is used. This switch has no effect when switch :samp:`-v` is used. * :samp:`-o {name}` (Choose an alternate executable name) Specify the file name of the executable. Switch :samp:`-o` can be used only if there is exactly one executable being built; that is, there is exactly one main on the command line, or there are no mains on the command line and exactly one main in attribute `Main` of the main project. * :samp:`-P {proj}` (use Project file *proj*) Specify the path name of the main project file. The space between :samp:`-P` and the project file name is optional. Specifying a project file name (with suffix :file:`.gpr`) may be used in place of option :samp:`-P`. Exactly one main project file can be specified. * :samp:`-r` (Recursive) This switch has an effect only when :samp:`-c` or :samp:`-u` is also specified and there are no mains: it means that all sources of all projects need to be compiled or recompiled. * :samp:`-u` (Unique compilation, only compile the given files) If there are sources specified on the command line, only compile these sources. If there are no sources specified on the command line, compile all the sources of the main project. In both cases, do not attempt the binding and the linking phases. * :samp:`-U` (Compile all sources of all projects) If there are sources specified on the command line, only compile these sources. If there are no sources specified on the command line, compile all the sources of all the projects in the project tree. In both cases, do not attempt the binding and the linking phases. * :samp:`-vP{x}` (Specify verbosity when parsing Project Files) By default, GPRbuild does not display anything when processing project files, except when there are errors. This default behavior is obtained with switch :samp:`-vP0`. Switches :samp:`-vP1` and :samp:`-vP2` yield increasingly detailed output. * :samp:`-Xnm={val}` (Specify an external reference for Project Files) Specify an external reference that may be queried inside the project files using built-in function `external`. For example, with :samp:`-XBUILD=DEBUG`, `external("BUILD")` inside a project file will have the value `"DEBUG"`. * :samp:`--compiler-subst={lang},{tool}` (Specify alternative compiler) Use *tool* for compiling files in language *lang*, instead of the normal compiler. For example, if :samp:`--compiler-subst=ada,my-compiler` is given, then Ada files will be compiled with *my-compiler* instead of the usual *gcc*. This and :samp:`--compiler-pkg-subst` are intended primarily for use by ASIS tools using :samp:`--incremental` mode. * :samp:`--compiler-pkg-subst={pkg}` (Specify alternative package) Use the switches in project-file package *pkg* when running the compiler, instead of the ones in package Compiler. Then, the switches that may be specified on the command line as well as in package Builder of the main project (attribute Switches): * :samp:`--keep-temp-files` Normally, GPRbuild delete the temporary files that it creates. When this switch is used, the temporary files that GPRbuild creates are not deleted. * :samp:`--create-map-file` When linking an executable, if supported by the platform, create a map file with the same name as the executable, but with suffix :file:`.map`. * :samp:`--create-map-file={map file}` When linking an executable, if supported by the platform, create a map file with file name :file:`map file`. * :samp:`--gnu-make-jobserver` Specify to GPRbuild that it should attempt to connect to GNU make jobserver in order to be instructed when it is allowed to spawn another simultaneous compilation jobs. This option should be used when GNU make contains :samp:`-j{num}` switch when invoking GPRbuild to ensure correct ressources allocation. If :samp:`-j{num}` is set alongside :samp:`--gnu-make-jobserver` the former will be ignored. * :samp:`--no-indirect-imports` This indicates that sources of a project should import only sources or header files from directly imported projects, that is those projects mentioned in a with clause and the projects they extend directly or indirectly. A check is done in the compilation phase, after a successful compilation, that the sources follow these restrictions. For Ada sources, the check is fully enforced. For non Ada sources, the check is partial, as in the dependency file there is no distinction between header files directly included and those indirectly included. The check will fail if there is no possibility that a header file in a non directly imported project could have been indirectly imported. If the check fails, the compilation artifacts (dependency file, object file, switches file) are deleted. * :samp:`--indirect-imports` This indicates that sources of a project can import sources or header files from directly or indirectly imported projects. This is the default behavior. This switch is provided to cancel a previous switch :samp:`--no-indirect-imports` on the command line. * :samp:`--no-object-check` Do not check if an object has been created after compilation. * :samp:`--no-split-units` Forbid the sources of the same Ada unit to be in different projects. * :samp:`--single-compile-per-obj-dir` Disallow several simultaneous compilations for the same object directory. * :samp:`-b` (Bind only) Specify to GPRbuild that the post-compilation (or binding) phase is to be performed, but not the other phases unless they are specified by appropriate switches. * :samp:`-c` (Compile only) Specify to GPRbuild that the compilation phase is to be performed, but not the other phases unless they are specified by appropriate switches. * :samp:`-f` (Force recompilations) Force the complete processing of all phases (or of those explicitly specified) even when up to date. * :samp:`-j{num}` (use *num* simultaneous compilation jobs) By default, GPRbuild invokes one compiler at a time. With switch :samp:`-j`, it is possible to instruct GPRbuild to spawn several simultaneous compilation jobs if needed. For example, :samp:`-j2` for two simultaneous compilation jobs or :samp:`-j4` for four. On a multi-processor system, :samp:`-j{num}` can greatly speed up the build process. If :samp:`-j0` is used, then the maximum number of simultaneous compilation jobs is the number of core processors on the platform. Switch :samp:`-j{num}` is also used to spawned several simultaneous binding processes and several simultaneous linking processes when there are several mains to be bound and/or linked. Note: if :samp:`--gnu-make-jobserver` is set, then :samp:`-j{num}` will simply be ignored. * :samp:`-k` (Keep going after compilation errors) By default, GPRbuild stops spawning new compilation jobs at the first compilation failure. Using switch :samp:`-k`, it is possible to attempt to compile/recompile all the sources that are not up to date, even when some compilations failed. The post-compilation phase and the linking phase are never attempted if there are compilation failures, even when switch :samp:`-k` is used. * :samp:`-l` (Link only) Specify to GPRbuild that the linking phase is to be performed, but not the other phases unless they are specified by appropriate switches. * :samp:`-m` (Minimum Ada recompilation) Do not recompile Ada code if timestamps are different but checksums are the same. Note that for the case when source code contains preprocessing directives, this switch has no effect. * :samp:`-m2` (Checksum based recompilation) Recompile Ada code even if timestamps are the same, but checksums are different. Note that for the case when source code contains preprocessing directives, this switch has the same effect as -f. * :samp:`-p` or :samp:`--create-missing-dirs` (Create missing object, library and exec directories) By default, GPRbuild checks that the object, library and exec directories specified in project files exist. GPRbuild automatically creates any of these directories which is specified relatively to the project dir, for instance :samp:`for Object_Dir use "obj/"`. The :samp:`-p` switch instructs GPRbuild to attempt to create missing directories that are specified as absolute paths as well. Note that these switches may be specified in package Builder of the main project, but they are not useful there as either the directories already exist or the processing of the project files has failed before the evaluation of the Builder switches, because there is at least one missing directory. * :samp:`-q` (Quiet output) Do not display anything except errors and progress (switch :samp:`-d`). Cancel any previous switch :samp:`-v`. * :samp:`-R` (no run path option) Do not use a run path option to link executables or shared libraries, even when attribute Run_Path_Option is specified. * :samp:`-s` (recompile if compilation switches have changed) By default, GPRbuild will not recompile a source if all dependencies are satisfied. Switch :samp:`-s` instructs GPRbuild to recompile sources when a different set of compilation switches has been used in the previous compilation, even if all dependencies are satisfied. Each time GPRbuild invokes a compiler, it writes a text file that lists the switches used in the invocation of the compiler, so that it can retrieve these switches if :samp:`-s` is used later. * :samp:`-v` (Verbose output) Same as switch :samp:`-vl`. * :samp:`-vl` (Verbose output, low level) Display full paths, all options used in spawned processes, as well as creations of missing directories and changes of current working directories. * :samp:`-vm` (Verbose output, medium level) Not significantly different from switch :samp:`-vh`. * :samp:`-vh` (Verbose output, high level) In addition to what is displayed with switch :samp:`vl`, displayed internal behavior of gprbuild and reasons why the spawned processes are invoked. * :samp:`-we` (Treat all warnings as errors) When :samp:`-we` is used, any warning during the processing of the project files becomes an error and GPRbuild does not attempt any of the phases. * :samp:`-wn` (Treat warnings as warnings) Switch :samp:`-wn` may be used to restore the default after :samp:`-we` or :samp:`-ws`. * :samp:`-ws` (Suppress all warnings) Do not generate any warnings while processing the project files. Note that this switch is only for warnings generated by gprbuild, not for warnings generated by the compiler. Use the compiler switch :samp:`-gnatws` to suppress warnings generated by the GNAT front end, and the compiler switch :samp:`-w` to suppress warnings generated by the gcc back end. * :samp:`-x` (Create include path file) Create the include path file for the Ada compiler. This switch is often necessary when Ada sources are compiled with switch :samp:`-gnatep=`. Switches that are accepted for compatibility with gnatmake, either on the command line or in the Builder Ada switches in the main project file: * :samp:`-nostdinc` * :samp:`-nostdlib` * :samp:`-fstack-check` * :samp:`-fno-inline` * :samp:`-g{*}` Any switch starting with :samp:`-g` * :samp:`-O{*}` Any switch starting with :samp:`-O` These switches are passed to the Ada compiler. .. _Initialization: Initialization ============== Before performing one or several of its three phases, GPRbuild has to read the command line, obtain its configuration, and process the project files. If GPRbuild is invoked with an invalid switch or without any project file on the command line, it will fail immediately. Examples: :: $ gprbuild -P gprbuild: project file name missing after -P $ gprbuild -P c_main.gpr -WW gprbuild: illegal option "-WW" GPRbuild looks for the configuration project file first in the current working directory, then in the default configuration project directory. If the GPRbuild executable is located in a subdirectory :file:`/bin`, then the default configuration project directory is :file:`/share/gpr`, otherwise there is no default configuration project directory. When it has found its configuration project path, GPRbuild needs to obtain its configuration. By default, the file name of the main configuration project is :file:`default.cgpr`. This default may be modified using the switch :samp:`--config=...` Example: :: $ gprbuild --config=my_standard.cgpr -P my_project.gpr If GPRbuild cannot find the main configuration project on the configuration project path, then it will look for all the languages specified in the user project tree and invoke GPRconfig to create a temporary configuration project file. This file is located in the directory computed by the following sequence: * Look for a valid absolute path in the environment variables TMPDIR, TEMP, and TMP. * If this fails, check some predefined platform-specific temp dirs (e.g. /tmp for linux). * Finally if none is accessible we fall back onto the current working directory. The invocation of GPRconfig will take into account the target, if specified either by switch --target= on the command line or by attribute Target in the main project. Also, if Ada is one of the languages, it will take into account the Ada runtime directory, specified either by switches --RTS= or --RTS:ada= on the command line or by attribute Runtime ("Ada") in the main project file. If the Ada runtime is specified as a relative path, gprbuild will try to locate the Ada runtime directory as a subdirectory of the main project directory, or if environment variable GPR_RUNTIME_PATH is defined in the path specified by GPR_RUNTIME_PATH. Once it has found the configuration project, GPRbuild will process its configuration: if a single string attribute is specified in the configuration project and is not specified in a user project, then the attribute is added to the user project. If a string list attribute is specified in the configuration project then its value is prepended to the corresponding attribute in the user project. After GPRbuild has processed its configuration, it will process the user project file or files. If these user project files are incorrect then GPRbuild will fail with the appropriate error messages: :: $ gprbuild -P my_project.gpr ada_main.gpr:3:26: "src" is not a valid directory gprbuild: "my_project.gpr" processing failed Once the user project files have been dealt with successfully, GPRbuild will start its processing. .. _Compilation_of_one_or_several_sources: Compilation of one or several sources ===================================== If GPRbuild is invoked with :samp:`-u` or :samp:`-U` and there are one or several source file names specified on the command line, GPRbuild will compile or recompile these sources, if they are not up to date or if :samp:`-f` is also specified. Then GPRbuild will stop its execution. The options/switches used to compile these sources are described in section :ref:`Compilation_Phase`. If GPRbuild is invoked with :samp:`-u` and no source file name is specified on the command line, GPRbuild will compile or recompile all the sources of the *main* project and then stop. In contrast, if GPRbuild is invoked with :samp:`-U`, and again no source file name is specified on the command line, GPRbuild will compile or recompile all the sources of *all the projects in the project tree* and then stop. .. _Compilation_Phase: Compilation Phase ================= When switch :samp:`-c` is used or when switches :samp:`-b` or :samp:`-l` are not used, GPRbuild will first compile or recompile the sources that are not up to date in all the projects in the project tree. The sources considered are: * all the sources in languages other than Ada * if there are no main specified, all the Ada sources * if there is a non Ada main, but no attribute `Roots` specified for this main, all the Ada sources * if there is a main with an attribute `Roots` specified, all the Ada sources in the closures of these Roots. * if there is an Ada main specified, all the Ada sources in the closure of the main Attribute Roots takes as an index a main and a string list value. Each string in the list is the name of an Ada library unit. Example: :: for Roots ("main.c") use ("pkga", "pkgb"); Package PkgA and PkgB will be considered, and all the Ada units in their closure will also be considered. GPRbuild will first consider each source and decide if it needs to be (re)compiled. A source needs to be compiled in the following cases: * Switch :samp:`-f` (force recompilations) is used * The object file does not exist * The source is more recent than the object file * The dependency file does not exist * The source is more recent than the dependency file * When :samp:`-s` is used: the switch file does not exist * When :samp:`-s` is used: the source is more recent than the switch file * The dependency file cannot be read * The dependency file is empty * The dependency file has a wrong format * A source listed in the dependency file does not exist * A source listed in the dependency file has an incompatible time stamp * A source listed in the dependency file has been replaced * Switch :samp:`-s` is used and the source has been compiled with different switches or with the same switches in a different order When a source is successfully compiled, the following files are normally created in the object directory of the project of the source: * An object file * A dependency file, except when the dependency kind for the language is `none` * A switch file if switch :samp:`-s` is used The compiler for the language corresponding to the source file name is invoked with the following switches/options: * The required compilation switches for the language * The compilation switches coming from package `Compiler` of the project of the source * The compilation switches specified on the command line for all compilers, after :samp:`-cargs` * The compilation switches for the language of the source, specified after :samp:`-cargs:{language}` * Various other options including a switch to create the dependency file while compiling, a switch to specify a configuration file, a switch to specify a mapping file, and switches to indicate where to look for other source or header files that are needed to compile the source. If compilation is needed, then all the options/switches, except those described as 'Various other options' are written to the switch file. The switch file is a text file. Its file name is obtained by replacing the suffix of the source with :file:`.cswi`. For example, the switch file for source :file:`main.adb` is :file:`main.cswi` and for :file:`toto.c` it is :file:`toto.cswi`. If the compilation is successful, then if the creation of the dependency file is not done during compilation but after (see configuration attribute `Compute_Dependency`), then the process to create the dependency file is invoked. For each project file, attribute Interfaces may be declared. Its value is a list of sources or header files of the project file. For a project file extending another one, directly or indirectly, inherited sources may be in the list. When Interfaces is not declared, all sources or header files are part of the interface of the project. When Interfaces is declared, only those sources or header files are part of the interface of the project file. After a successful compilation, gprbuild checks that all imported or included sources or header files that are from an imported project are part of the interface of the imported project. If this check fails, the compilation is invalidated and the compilation artifacts (dependency, object and switches files) are deleted. Example: :: project Prj is for Languages use ("Ada", "C"); for Interfaces use ("pkg.ads", "toto.h"); end Prj; If a source from a project importing project Prj imports sources from Prj other than package Pkg or includes header files from Prj other than "toto.h", then its compilation will be invalidated. .. _Simultaneous_compilation: Simultaneous compilation ======================== If GPRbuild is invoked with a switch :samp:`-j` specifying more than one compilation process, then several compilation processes for several sources of possibly different languages are spawned concurrently. Furthermore, GPRbuild is GNU make jobserver compatible when using the switch :samp:`--gnu-make-jobserver`. This means if GPRbuild is embedded in a GNU make recursive invocation and :samp:`--gnu-make-jobserver` is set, then GPRbuild will only spawn an additionnal compilation process if GNU make's jobserver allows it. This is particularly useful to ensure that GPRbuild comply to the ressource management of GNU make. Example: :: build1: +gprbuild -P prjA/prj.gpr --gnu-make-jobserver build2: +gprbuild -P prjB/prj.gpr --gnu-make-jobserver build_all: +make build1 build2 calling :samp:`make build_all -j4` will spawn two GPRbuild processes, resulting in two remaining and available slots for both GPRbuild compilation phase. Note: If :samp:`--gnu-make-jobserver` is set, then any :samp:`-j{num}` will simply be ignored by GPRbuild and a warning will be issued. .. _Post-Compilation_Phase: Post-Compilation Phase ====================== The post-compilation phase has two parts: library building and program binding. If there are libraries that need to be built or rebuilt, *gprbuild* will call the library builder, specified by attribute `Library_Builder`. This is generally the tool *gprlib*, provided with GPRbuild. If gprbuild can determine that a library is already up to date, then the library builder will not be called. If there are mains specified, and for these mains there are sources of languages with a binder driver (specified by attribute Binder'Driver (), then the binder driver is called for each such main, but only if it needs to. For Ada, the binder driver is normally *gprbind*, which will call the appropriate version of *gnatbind*, that either the one in the same directory as the Ada compiler or the fist one found on the path. When neither of those is appropriate, it is possible to specify to *gprbind* the full path of *gnatbind*, using the Binder switch `--gnatbind_path=`. Example: :: package Binder is for Switches ("Ada") use ("--gnatbind_path=/toto/gnatbind"); end Binder; If GPRbuild can determine that the artifacts from a previous post-compilation phase are already up to date, the binder driver is not called. If there are no libraries and no binder drivers, then the post-compilation phase is empty. .. _Linking_Phase: Linking Phase ============= When there are mains specified, either in attribute Main or on the command line, and these mains are not up to date, the linker is invoked for each main, with all the specified or implied options, including the object files generated during the post-compilation phase by the binder drivers. If switch :samp:`-j{nnn}` is used, with `nnn` other than 1, gprbuild will attempt to link simultaneously up to `nnn` executables. .. _Distributed_compilation: Distributed compilation ======================= .. _Introduction_to_distributed_compilation: Introduction to distributed compilation --------------------------------------- For large projects the compilation time can become a limitation in the development cycle. To cope with that, GPRbuild supports distributed compilation. In the distributed mode, the local machine (called the build master) compiles locally but also sends compilation requests to remote machines (called the build slaves). The compilation process can use one or more build slaves. Once the compilation phase is done, the build master will conduct the binding and linking phases locally. .. _Setup_build_environments: Setup build environments ------------------------ The configuration process to be able to use the distributed compilation support is the following: * Optionally add a Remote package in the main project file This Remote package is to be placed into the project file that is passed to GPRbuild to build the application. The Root_Dir default value is the project's directory. This attribute designates the sources root directory. That is, the directory from which all the sources are to be found to build the application. If the project passed to GPRbuild to build the application is not at the top-level directory but in a direct sub-directory the Remote package should be: .. code-block:: gpr package Remote is for Root_Dir use ".."; end Remote; * Launch a slave driver on each build slave The build master will communicate with each build slave with a specific driver in charge of running the compilation process and returning statuses. This driver is *gprslave*, :ref:`GPRslave`. The requirement for the slaves are: * The same build environment must be setup (same compiler version). * The same libraries must be installed. That is, if the GNAT project makes use of external libraries the corresponding C headers or Ada units must be installed on the remote slaves. When all the requirement are set, just launch the slave driver: :: $ gprslave When all this is done, the remote compilation can be used simply by running GPRbuild in distributed mode from the build master: :: $ gprbuild --distributed=comp1.xyz.com,comp2.xyz.com prj.gpr Alternatively the slaves can be set using the `GPR_SLAVES` environment variable. So the following command is equivalent to the above: :: $ export GPR_SLAVES=comp1.xyz.com,comp2.xyz.com $ gprbuild --distributed prj.gpr A third alternative is proposed using a list of slaves in a file (one per line). In this case the `GPR_SLAVES_FILE` environment variable must contain the path name to this file: :: $ export GPR_SLAVES_FILE=$HOME/slave-list.txt $ gprbuild --distributed prj.gpr Finally note that the search for the slaves are in this specific order. First the command line values, then `GPR_SLAVES` if set and finally `GPR_SLAVES_FILES`. The build slaves are specified with the following form: :: [:port] .. _GPRslave: GPRslave -------- This is the slave driver in charge of running the compilation jobs as requested by the build master. One instance of this tool must be launched in each build slave referenced in the project file. Compilations for a specific project are conducted under a sub-directory from where the slave is launched by default. This can be overridden with the `-d` option below. The current options are: * :samp:`-v, --verbose` Activate the verbose mode * :samp:`-vv`, :samp:`--debug` Activate the debug mode (very verbose) * :samp:`-h`, :samp:`--help` Display the usage * :samp:`-d`, :samp:`--directory=` Set the work directory for the slave. This is where the sources will be copied and where the compilation will take place. A sub-directory will be created for each root project built. * :samp:`-s`, :samp:`--hash={string}` Specify an hash string. This is just a value which is checked against the GPRbuild hash value. If set, GPRbuild hash value must match, otherwise the connection with the slave is aborted. For example: :: $ gprslave --hash=$(echo $ADA_PROJECT_PATH | shasum) * :samp:`-j{N}`, :samp:`--jobs={N}` Set the maximum simultaneous compilation. The default for `N` is the number of cores. * :samp:`-p`, :samp:`--port={N}` Set the port the slave will listen to. The default value is 8484. The same port must be specified for the build slaves on `GPRbuild` command line. * :samp:`-r`, :samp:`--response-handler={N}` Set maximum number of simultaneous responses. With this option it is possible to control the number of simultaneous responses (sending back object code and ALI files) supported. The value must be between 1 and the maximum number of simultaneous compilations. Note that a slave can be pinged to see if it is running and in response a set of information are delivered. The ping command has the following format: :: PG When and are 32bits binary values for the PG string command. As an example here is how to send a ping command from a UNIX shell using the echo command: :: echo -e "\x01\x00\x00\x00\x02\x00\x00\x00PG" | nc 8484 The answer from the ping command has the following format: :: OK[ASCII.GS][ASCII.GS] The ASCII.GS is the Group Separator character whose code is 29. gprbuild-25.0.0/doc/gprbuild_ug/companion_tools.rst000066400000000000000000002651241470075373400224370ustar00rootroot00000000000000.. _GPRbuild_Companion_Tools: ************************ GPRbuild Companion Tools ************************ This chapter describes the various tools that can be used in conjunction with GPRbuild. .. _Configuring_with_GPRconfig: Configuring with GPRconfig ========================== .. _Configuration: Configuration ------------- GPRbuild requires one configuration file describing the languages and toolchains to be used, and project files describing the characteristics of the user project. Typically the configuration file can be created automatically by `GPRbuild` based on the languages defined in your projects and the compilers on your path. In more involved situations --- such as cross compilation, or environments with several compilers for the same language --- you may need to control more precisely the generation of the desired configuration of toolsets. A tool, GPRconfig, described in :ref:`Configuring_with_GPRconfig`), offers this capability. In this chapter most of the examples can use autoconfiguration. GPRbuild will start its build process by trying to locate a configuration file, using the following rules. * If either `--config` or `--autoconf` switches are specified, the argument of this switch is used as configuration file. * If neither switch is specified, and both target and rts are explicitly specified in the project or on the command line, then configuration file is called `-.cgpr`; if only target or only rts is specified, it is called `.cgpr` respectively; if neither is specified, it is called `default.cgpr`. This file is looked for in the current directory. * If the environment variable `GPR_CONFIG` is specified, the above rule is modified as follows: if this variable designates a directory, then this directory is searched for the configuration file instead of the current directory; otherwise, the value of this variable is used as a configuration file name (absolute or relative). GPRbuild assumes that there are known compilers on your path for each of the necessary languages. A user can manually generate a configuration file (and reference it using `--config` switch); this is especially useful when: * using cross compilers (in which case you need to use gprconfig's :samp:`--target=`) option; * using a specific Ada runtime (e.g. :samp:`--RTS=sjlj`); * working with compilers not in the path or not first in the path; * autoconfiguration does not give the expected results; * autoconfiguration perceptively delays the build. GPRconfig provides several ways of generating configuration files. By default, a simple interactive mode lists all the known compilers for all known languages. You can then select a compiler for each of the languages; once a compiler has been selected, only compatible compilers for other languages are proposed. Here are a few examples of GPRconfig invocation: * The following command triggers interactive mode. The configuration will be generated in GPRbuild's default location, `./default.cgpr)`, unless :samp:`-o` is used. :: gprconfig * The first command below also triggers interactive mode, but the resulting configuration file has the name and path selected by the user. The second command shows how GPRbuild can make use of this specific configuration file instead of the default one. :: gprconfig -o path/my_config.cgpr gprbuild --config=path/my_config.cgpr * The following command again triggers interactive mode, and only the relevant cross compilers for target ppc-elf will be proposed. :: gprconfig --target=ppc-elf * The next command triggers batch mode and generates at the default location a configuration file using the first native Ada and C compilers on the path. :: gprconfig --config=Ada --config=C --batch * The next command, a combination of the previous examples, creates in batch mode a configuration file named :file:`x.cgpr` for cross-compiling Ada with a run-time called `hi` and using C for the LEON processor. :: gprconfig --target=leon-elf --config=Ada,,hi --config=C --batch -o x.cgpr .. _Using_GPRconfig: Using GPRconfig --------------- Description ^^^^^^^^^^^ The GPRconfig tool helps you generate the configuration files for GPRbuild. It automatically detects the available compilers on your system and, after you have selected the one needed for your application, it generates the proper configuration file. .. note:: In general, you will not launch GPRconfig explicitly. Instead, it is used implicitly by GPRbuild through the use of `--config` and `--autoconf` switches. Command line arguments ^^^^^^^^^^^^^^^^^^^^^^ GPRconfig supports the following command line switches: .. index:: --target (gprconfig) :samp:`--target={platform}` .. -- @TIPHTML{Use :samp:`--target` to specify on which machine your application will run} This switch indicates the target computer on which your application will be run. It is mostly useful for cross configurations. Examples include :samp:`ppc-elf`, :samp:`ppc-vx6-windows`. It can also be used in native configurations and is useful when the same machine can run different kind of compilers such as mingw32 and cygwin on Windows or x86-32 and x86-64 on GNU Linux. Since different compilers will often return a different name for those targets, GPRconfig has an extensive knowledge of which targets are compatible, and will for example accept :samp:`x86-linux` as an alias for :samp:`i686-pc-linux-gnu`. The default target is the machine on which GPRconfig is run. If you enter the special target :samp:`all`, then all compilers found on the :envvar:`PATH` will be displayed. .. index:: --show-target (gprconfig) :samp:`--show-targets` As mentioned above, GPRconfig knows which targets are compatible. You can use this switch to find the list of targets that are compatible with `--target`. .. index:: --config (gprconfig) :samp:`--config={language}[,{version}[,{runtime}[,{path}[,{name}]]]]` .. -- @TIPHTML{Use :samp:`--config` to automatically select the first matching compiler} The intent of this switch is to preselect one or more compilers directly from the command line. This switch takes several optional arguments, which you can omit simply by passing the empty string. When omitted, the arguments will be computed automatically by GPRconfig. In general, only *language* needs to be specified, and the first compiler on the :envvar:`PATH` that can compile this language will be selected. As an example, for a multi-language application programmed in C and Ada, the command line would be: :: --config=Ada --config=C *path* is the directory that contains the compiler executable, for instance :file:`/usr/bin` (and not the installation prefix :file:`/usr`). *name* should be one of the compiler names defined in the GPRconfig knowledge base. The list of supported names includes :samp:`GNAT`, :samp:`GCC`,.... This name is generally not needed, but can be used to distinguish among several compilers that could match the other arguments of :samp:`--config`. Another possible more frequent use of *name* is to specify the base name of an executable. For instance, if you prefer to use a diab C compiler (executable is called :file:`dcc`) instead of :file:`gcc`, even if the latter appears first in the path, you could specify :file:`dcc` as the name parameter. :: gprconfig --config Ada,,,/usr/bin # automatic parameters gprconfig --config C,,,/usr/bin,GCC # automatic version gprconfig --config C,,,/usr/bin,gcc # same as above, with exec name This switch is also the only possibility to include in your project some languages that are not associated with a compiler. This is sometimes useful especially when you are using environments like GPS that support project files. For instance, if you select "Project file" as a language, the files matching the :file:`.gpr` extension will be shown in the editor, although they of course play no role for gprbuild itself. .. index:: --batch (gprconfig) :samp:`--batch` .. -- @TIPHTML{Use :samp:`--batch` to generate the configuration file with no user interaction} If this switch is specified, GPRconfig automatically selects the first compiler matching each of the `--config` switches, and generates the configuration file immediately. It will not display an interactive menu. .. index:: -o (gprconfig) :samp:`-o {file}` .. -- @TIPHTML{Use :samp:`-o` to specify the name of the configuration file to generate} This specifies the name of the configuration file that will be generated. If this switch is not specified, a default file is generated in the installation directory of GPRbuild (assuming you have write access to that directory), so that it is automatically picked up by GPRbuild later on. If you select a different output file, you will need to specify it to GPRbuild. .. index:: --db (gprconfig) :samp:`--db {directory}`, :samp:`--db-` Indicates another directory that should be parsed for GPRconfig's knowledge base. Most of the time this is only useful if you are creating your own XML description files locally. Additional directories are always processed after the default knowledge base. The second version of the switch prevents GPRconfig from reading its default knowledge base. .. index:: -h (gprconfig) :samp:`-h` Generates a brief help message listing all GPRconfig switches and the default value for their arguments. This includes the location of the knowledge base, the default target, etc. Interactive use ^^^^^^^^^^^^^^^ When you launch GPRconfig, it first searches for all compilers it can find on your :envvar:`PATH`, that match the target specified by :samp:`--target`. It is recommended, although not required, that you place the compilers that you expect to use for your application in your :envvar:`PATH` before you launch *gprconfig*, since that simplifies the setup. .. -- @TIPHTML{The list of compilers is sorted so that the most likely compilers appear first} GPRconfig then displays the list of all the compilers it has found, along with the language they can compile, the run-time they use (when applicable),.... It then waits for you to select one of the compilers. This list is sorted by language, then by order in the :envvar:`PATH` environment variable (so that compilers that you are more likely to use appear first), then by run-time names and finally by version of the compiler. Thus the first compiler for any language is most likely the one you want to use. You make a selection by entering the letter that appears on the line for each compiler (be aware that this letter is case sensitive). If the compiler was already selected, it is deselected. .. -- @TIPHTML{The list of compilers is filtered, so that only compatible compilers can be selected} A filtered list of compilers is then displayed: only compilers that target the same platform as the selected compiler are now shown. GPRconfig then checks whether it is possible to link sources compiled with the selected compiler and each of the remaining compilers; when linking is not possible, the compiler is not displayed. Likewise, all compilers for the same language are hidden, so that you can only select one compiler per language. As an example, if you need to compile your application with several C compilers, you should create another language, for instance called C2, for that purpose. That will give you the flexibility to indicate in the project files which compiler should be used for which sources. The goal of this filtering is to make it more obvious whether you have a good chance of being able to link. There is however no guarantee that GPRconfig will know for certain how to link any combination of the remaining compilers. You can select as many compilers as are needed by your application. Once you have finished selecting the compilers, select :kbd:`s`, and GPRconfig will generate the configuration file. .. _The_GPRconfig_knowledge_base: The GPRconfig knowledge base ---------------------------- GPRconfig itself has no hard-coded knowledge of compilers. Thus there is no need to recompile a new version of GPRconfig when a new compiler is distributed. .. note:: The role and format of the knowledge base are irrelevant for most users of GPRconfig, and are only needed when you need to add support for new compilers. You can skip this section if you only want to learn how to use GPRconfig. All knowledge of compilers is embedded in a set of XML files called the *knowledge base*. Users can easily contribute to this general knowledge base, and have GPRconfig immediately take advantage of any new data. The knowledge base contains various kinds of information: * Compiler description When it is run interactively, GPRconfig searches the user's :envvar:`PATH` for known compilers, and tries to deduce their configuration (version, supported languages, supported targets, run-times, ...). From the knowledge base GPRconfig knows how to extract the relevant information about a compiler. This step is optional, since a user can also enter all the information manually. However, it is recommended that the knowledge base explicitly list its known compilers, to make configuration easier for end users. * Specific compilation switches When a compiler is used, depending on its version, target, run-time,..., some specific command line switches might have to be supplied. The knowledge base is a good place to store such information. For instance, with the GNAT compiler, using the soft-float runtime should force *gprbuild* to use the :samp:`-msoft-float` compilation switch. * Linker options Linking a multi-language application often has some subtleties, and typically requires specific linker switches. These switches depend on the list of languages, the list of compilers,.... * Unsupported compiler mix It is sometimes not possible to link together code compiled with two particular compilers. The knowledge base should store this information, so that end users are informed immediately when attempting to use such a compiler combination. The end of this section will describe in more detail the format of this knowledge base, so that you can add your own information and have GPRconfig advantage of it. .. _General_file_format: General file format ^^^^^^^^^^^^^^^^^^^ The knowledge base is implemented as a set of XML files. None of these files has a special name, nor a special role. Instead, the user can freely create new files, and put them in the knowledge base directory, to contribute new knowledge. The location of the knowledge base is :file:`$prefix/share/gprconfig`, where :file:`$prefix` is the directory in which GPRconfig was installed. Any file with extension :file:`.xml` in this directory will be parsed automatically by GPRconfig at startup after sorting them alphabetically. All files must have the following format: :: ... The root tag must be ``. The remaining sections in this chapter will list the valid XML tags that can be used to replace the '...' code above. These tags can either all be placed in a single XML file, or split across several files. .. _Compiler_description: Compiler description ^^^^^^^^^^^^^^^^^^^^ One of the XML tags that can be specified as a child of `` is ``. This node and its children describe one of the compilers known to GPRconfig. The tool uses them when it initially looks for all compilers known on the user's :envvar:`PATH` environment variable. This is optional information, but simplifies the use of GPRconfig, since the user is then able to omit some parameters from the :samp:`--config` command line argument, and have them automatically computed. The `` node doesn't accept any XML attribute. However, it accepts a number of child tags that explain how to query the various attributes of the compiler. The child tags are evaluated (if necessary) in the same order as they are documented below. ** This tag contains a simple string, which is the name of the compiler. This name must be unique across all the configuration files, and is used to identify that `compiler_description` node. :: GNAT ** This tag contains a string, which is the name of an executable to search for on the PATH. Examples are :samp:`gnatls`, :samp:`gcc`,... In some cases, the tools have a common suffix, but a prefix that might depend on the target. For instance, GNAT uses :samp:`gnatmake` for native platforms, but :samp:`powerpc-wrs-vxworks-gnatmake` for cross-compilers to VxWorks. Most of the compiler description is the same, however. For such cases, the value of the `executable` node is considered as beginning a regular expression. The tag also accepts an optional attribute `prefix`, which is an integer indicating the parenthesis group that contains the prefix. In the following example, you obtain the version of the GNAT compiler by running either *gnatls* or *powerpc-wrs-vxworks-gnatls*, depending on the name of the executable that was found. The regular expression needs to match the whole name of the file, i.e. it contains an implicit '^' at the start, and an implicit '$' at the end. Therefore if you specify :samp:`.*gnatmake` as the regexp, it will not match :samp:`gnatmake-debug`. A special case is when this node is empty (but it must be specified!). In such a case, you must also specify the language (see below) as a simple string. It is then assumed that the specified language does not require a compiler. In the configurations file (:ref:`Configurations`), you can test whether that language was specified on the command line by using a filter such as :: :: (powerpc-wrs-vxworks-)?gnatmake ${PREFIX}gnatls -v GPRconfig searches in all directories listed on the PATH for such an executable. When one is found, the rest of the `` children are checked to know whether the compiler is valid. The directory in which the executable was found becomes the 'current directory' for the remaining XML children. ** This node indicates how to query the target architecture for the compiler. See :ref:`GPRconfig_external_values` for valid children. If this isn't specified, the compiler will always be considered as matching on the current target. ** This tag contains any of the nodes defined in :ref:`GPRconfig_external_values` below. It shows how to query the version number of the compiler. If the version cannot be found, the executable will not be listed in the list of compilers. ** This node will define a user variable which may be later referenced. The variables are evaluated just after the version but before the languages and the runtimes nodes. See :ref:`GPRconfig_external_values` below for valid children of this node. If the evaluation of this variable is empty then the compiler is considered as invalid. ** This node indicates how to query the list of languages. See :ref:`GPRconfig_external_values` below for valid children of this node. The value returned by the system will be split into words. As a result, if the returned value is 'ada,c,c++', there are three languages supported by the compiler (and three entries are added to the menu when using GPRconfig interactively). If the value is a simple string, the words must be comma-separated, so that you can specify languages whose names include spaces. However, if the actual value is computed from the result of a command, the words can also be space-separated, to be compatible with more tools. ** This node indicates how to query the list of supported runtimes for the compiler. See :ref:`GPRconfig_external_values` below for valid children. The returned value is split into words as for ``. This node accepts one attribute, `"default"`, which contains a list of comma-separated names of runtimes. It is used to sort the runtimes when listing which compilers were found on the PATH. As a special case, gprconfig will merge two runtimes if the XML nodes refer to the same directories after normalization and resolution of links. As such, on Unix systems, the "adalib" link to "rts-native/adalib" (or similar) will be ignored and only the "native" runtime will be displayed. .. _GPRconfig_external_values: GPRconfig external values ^^^^^^^^^^^^^^^^^^^^^^^^^ A number of the XML nodes described above can contain one or more children, and specify how to query a value from an executable. Here is the list of valid contents for these nodes. The `` and `` children can be repeated multiple times, and the `` and `` nodes will be applied to each of these. The final value of the external value is the concatenation of the computation for each of the `` and `` nodes. .. index:: gprconfig external values * A simple string A simple string given in the node indicates a constant. For instance, the list of supported languages might be defined as: :: GNAT gnatmake Ada for the GNAT compiler, since this is an Ada-only compiler. Variables can be referenced in simple strings. * `` If the contents of the node is a `` child, the value of the environment variable `variable` is returned. If the variable is not defined, this is an error and the compiler is ignored. :: GCC-WRS cc(arm|pentium) * `command` If the contents of the node is an `` child, this indicates that a command should be run on the system. When the command is run, the current directory (i.e., the one that contains the executable found through the `` node), is placed first on the :envvar:`PATH`. The output of the command is returned and may be later filtered. The command is not executed through a shell; therefore you cannot use output redirection, pipes, or other advanced features. For instance, extracting the target processor from *gcc* can be done with: :: gcc -dumpmachine Since the :envvar:`PATH` has been modified, we know that the *gcc* command that is executed is the one from the same directory as the `` node. Variables are substituted in `command`. * `` This node must come after the previously described ones. It is used to further filter the output. The previous output is matched against the regular expression `regexp` and the parenthesis group specified by `group` is returned. By default, group is 0, which indicates the whole output of the command. For instance, extracting the version number from *gcc* can be done with: :: gcc -v * `regexp` If the contents of the node is a ` child, this indicates that GPRconfig should find all the files matching the regular expression. Regexp is a path relative to the directory that contains the `` file, and should use Unix directory separators (i.e. '/'), since the actual directory will be converted into this format before the match, for system independence of the knowledge base. The group attribute indicates which parenthesis group should be returned. It defaults to 0 which indicates the whole matched path. If this attribute is a string rather than an integer, then it is the value returned. `regexp` can be any valid regular expression. This will only match a directory or file name, not a subdirectory. Remember to quote special characters, including '.', if you do not mean to use a regexp. The optional attribute `contents` can be used to indicate that the contents of the file should be read. The first line that matches the regular expression given by `contents` will be used as a file path instead of the file matched by `regexp`. This is in general used on platforms that do not have symbolic links, and a file is used instead of a symbolic link. In general, this will work better than `group` specifies a string rather than a parenthesis group, since the latter will match the path matched by `regexp`, not the one read in the file. For instance, finding the list of supported runtimes for the GNAT compiler is done with: :: \.\./lib/gcc/${TARGET/.*/rts-(.*)/adainclude \.\./lib/gcc/${TARGET}/.*/adainclude } Note the second node, which matches the default run-time, and displays it as such. * `value1,value2,...` This node must come after one of the previously described ones. It is used to further filter the output. The previous output is split into words (it is considered as a comma-separated or space-separated list of words), and only those words in :samp:`value1`, :samp:`value2`,... are kept. For instance, the *gcc* compiler will return a variety of supported languages, including 'ada'. If we do not want to use it as an Ada compiler we can specify: :: gcc -v c,c++,fortran * `regexp` If this node is present, then the filtered output is compared with the specified regular expression. If no match is found, then the executable is not stored in the list of known compilers. For instance, if you want to have a `` tag specific to an older version of GCC, you could write: :: gcc -v 2.8.1 Other versions of gcc will not match this `` node. .. _GPRconfig_variable_substitution: GPRconfig variable substitution ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ The various compiler attributes defined above are made available as variables in the rest of the XML files. Each of these variables can be used in the value of the various nodes (for instance in ``), and in the configurations (:ref:`Configuration`). A variable is referenced by `${name}` where `name` is either a user variable or a predefined variable. An alternate reference is `$name` where `name` is a sequence of alpha numeric characters or underscores. Finally `$$` is replaced by a simple `$`. User variables are defined by `` nodes and may override predefined variables. To avoid a possible override use lower case names. The variables are used in two contexts: either in a `` node, in which case the variable refers to the compiler we are describing, or within a `` node. In the latter case, and since there might be several compilers selected, you need to further specify the variable by adding in parenthesis the language of the compiler you are interested in. For instance, the following is invalid: :: package Compiler is for Driver ("Ada") use "${PATH}gcc"; -- Invalid ! end Compiler; The trouble with the above is that if you are using multiple languages like C and Ada, both compilers will match the "negate" part, and therefore there is an ambiguity for the value of `${PATH}`. To prevent such issues, you need to use the following syntax instead when inside a `` node: .. code-block:: gpr for Driver ("Ada") use "${PATH(ada)}gcc"; -- Correct Predefined variables are always in upper case. Here is the list of predefined variables * *EXEC* is the name of the executable that was found through ``. It only contains the basename, not the directory information. * *HOST* is replaced by the architecture of the host on which GPRconfig is running. This name is hard-coded in GPRconfig itself, and is generated by *configure* when GPRconfig was built. * *TARGET* is replaced by the target architecture of the compiler, as returned by the `` node. This is of course not available when computing the target itself. This variable takes the language of the compiler as an optional index when in a `` block: if the language is specified, the target returned by that specific compiler is used; otherwise, the normalized target common to all the selected compilers will be returned (target normalization is also described in the knowledge base's XML files). * *VERSION* is replaced by the version of the compiler. This is not available when computing the target or, of course, the version itself. * *PREFIX* is replaced by the prefix to the executable name, as defined by the `` node. * *PATH* is the current directory, i.e. the one containing the executable found through ``. It always ends with a directory separator. * *LANGUAGE* is the language supported by the compiler, always folded to lower-case * *RUNTIME*, *RUNTIME_DIR* This string will always be substituted by the empty string when the value of the external value is computed. These are special strings used when substituting text in configuration chunks. `RUNTIME_DIR` always end with a directory separator. * *GPRCONFIG_PREFIX* is the directory in which GPRconfig was installed (e.g :file:`"/usr/local/"` if the executable is :file:`"/usr/local/bin/gprconfig"`. This directory always ends with a directory separator. This variable never takes a language in parameter, even within a `` node. If a variable is not defined, an error message is issued and the variable is substituted by an empty string. .. _Configurations: Configurations ^^^^^^^^^^^^^^ The second type of information stored in the knowledge base are the chunks of *gprbuild* configuration files. Each of these chunks is also placed in an XML node that provides optional filters. If all the filters match, then the chunk will be merged with other similar chunks and placed in the final configuration file that is generated by GPRconfig. For instance, it is possible to indicate that a chunk should only be included if the GNAT compiler with the soft-float runtime is used. Such a chunk can for instance be used to ensure that Ada sources are always compiled with the `-msoft-float` command line switch. GPRconfig does not perform sophisticated merging of chunks. It simply groups packages together. For example, if the two chunks are: .. code-block:: gpr chunk1: package Language_Processing is for Attr1 use ("foo"); end Language_Processing; chunk2: package Language_Processing is for Attr1 use ("bar"); end Language_Processing; Then the final configuration file will look like: .. code-block:: gpr package Language_Processing is for Attr1 use ("foo"); for Attr1 use ("bar"); end Language_Processing; As a result, to avoid conflicts, it is recommended that the chunks be written so that they easily collaborate together. For instance, to obtain something equivalent to .. code-block:: gpr package Language_Processing is for Attr1 use ("foo", "bar"); end Language_Processing; the two chunks above should be written as: .. code-block:: gpr chunk1: package Language_Processing is for Attr1 use Language_Processing'Attr1 & ("foo"); end Language_Processing; chunk2: package Language_Processing is for Attr1 use Language_Processing'Attr1 & ("bar"); end Language_Processing; The chunks are described in a `` XML node. The most important child of such a node is ``, which contains the chunk itself. For instance, you would write: :: ... list of filters, see below package Language_Processing is for Attr1 use Language_Processing'Attr1 & ("foo"); end Language_Processing; If `` is an empty node (i.e., :samp:`` or :samp:`` was used), then the combination of selected compilers will be reported as invalid, in the sense that code compiled with these compilers cannot be linked together. As a result, GPRconfig will not create the configuration file. The special variables (:ref:`GPRconfig_variable_substitution`) are also substituted in the chunk. That allows you to compute some attributes of the compiler (its path, the runtime,...), and use them when generating the chunks. The filters themselves are of course defined through XML tags, and can be any of: ** This filter contains a list of `` children. The `` filter matches if any of its children match. However, you can have several `` filters, in which case they must all match. This can be used to include linker switches chunks. For instance, the following code would be used to describe the linker switches to use when GNAT 5.05 or 5.04 is used in addition to g++ 3.4.1: :: ... If the attribute `negate` is :samp:`true`, then the meaning of this filter is inverted, and it will match if none of its children matches. The format of the `` is the following: :: The language attribute, when specified, matches the corresponding attribute used in the `` children. All other attributes are regular expressions, which are matched against the corresponding selected compilers. Runtime attribute is matched against the base name of corresponding compiler runtime if it is given as a full path. When an attribute is not specified, it will always match. Matching is done in a case-insensitive manner. For instance, to check a GNAT compiler in the 5.x family, use: :: ** This filter contains a list of `` children. It matches when any of its children matches. You can specify only one `` node. The format of `` is a node with one mandatory attribute `name`, which is a regexp matched against the architecture on which GPRconfig is running, and one optional attribute `except`, which is also a regexp, but a negative one. If both `name` and `except` match the architecture, corresponding `` node is ignored. The name of the architecture was computed by `configure` when GPRconfig was built. Note that the regexp might match a substring of the host name, so you might want to surround it with "^" and "$" so that it only matches the whole host name (for instance, "elf" would match "powerpc-elf", but "^elf$" would not). If the `negate` attribute is :samp:`true`, then the meaning of this filter is inverted, and it will match when none of its children matches. For instance, to activate a chunk only if the compiler is running on an Intel Linux machine, use: :: ** This filter contains a list of `` children. It behaves exactly like ``, but matches against the architecture targeted by the selected compilers. For instance, to activate a chunk only when the code is targeted for linux, use: If the `negate` attribute is :samp:`true`, then the meaning of this filter is inverted, and it will match when none of its children matches. :: .. _Configuration_File_Reference: Configuration File Reference ============================ A text file using the project file syntax. It defines languages and their characteristics as well as toolchains for those languages and their characteristics. GPRbuild needs to have a configuration file to know the different characteristics of the toolchains that can be used to compile sources and build libraries and executables. A configuration file is a special kind of project file: it uses the same syntax as a standard project file. Attributes in the configuration file define the configuration. Some of these attributes have a special meaning in the configuration. The default name of the configuration file, when not specified to GPRbuild by switches :samp:`--config=` or :samp:`--autoconf=` is :file:`default.cgpr`. Although the name of the configuration file can be any valid file name, it is recommended that its suffix be :file:`.cgpr` (for Configuration GNAT Project), so that it cannot be confused with a standard project file which has the suffix :file:`.gpr`. When :file:`default.cgpr` cannot be found in the configuration project path, GPRbuild invokes GPRconfig to create a configuration file. In the following description of the attributes, when an attribute is an indexed attribute and its index is a language name, for example `Spec_Suffix ()`, then the name of the language is case insensitive. For example, both `C` and `c` are allowed. Any attribute may appear in a configuration project file. All attributes in a configuration project file are inherited by each user project file in the project tree. However, usually only the attributes listed below make sense in the configuration project file. .. _Project_Level_Configuration_Attributes: Project Level Configuration Attributes -------------------------------------- .. _General_Attributes: General Attributes ^^^^^^^^^^^^^^^^^^ * Default_Language Specifies the name of the language of the immediate sources of a project when attribute `Languages` is not declared in the project. If attribute `Default_Language` is not declared in the configuration file, then each user project file in the project tree must have an attribute `Languages` declared, unless it extends another project. Example: .. code-block:: gpr for Default_Language use "ada"; * Run_Path_Option Specifies a 'run path option'; i.e., an option to use when linking an executable or a shared library to indicate the path (Rpath) where to look for other libraries. The value of this attribute is a string list. When linking an executable or a shared library, the search path is concatenated with the last string in the list, which may be an empty string. Example: .. code-block:: gpr for Run_Path_Option use ("-Wl,-rpath,"); * Run_Path_Origin Specifies the string to be used in an Rpath to indicate the directory of the executable, allowing then to have Rpaths specified as relative paths. Example: .. code-block:: gpr for Run_Path_Origin use "$ORIGIN"; * Toolchain_Version () Specifies a version for a toolchain, as a single string. This toolchain version is passed to the library builder. Example: .. code-block:: gpr for Toolchain_Version ("Ada") use "GNAT 6.1"; This attribute is used by GPRbind to decide on the names of the shared GNAT runtime libraries. * Toolchain_Description () Specifies as a single string a description of a toolchain. This attribute is not directly used by GPRbuild or its auxiliary tools (GPRbind and GPRlib) but may be used by other tools, for example GPS. Example: .. code-block:: gpr for Toolchain_Description ("C") use "gcc version 4.1.3 20070425"; .. _General_Library_Related_Attributes: General Library Related Attributes ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ * Library_Support Specifies the level of support for library project. If this attribute is not specified, then library projects are not supported. The only potential values for this attribute are `none`, `static_only` and `full`. Example: .. code-block:: gpr for Library_Support use "full"; * Library_Builder Specifies the name of the executable for the library builder. Example: .. code-block:: gpr for Library_Builder use "/.../gprlib"; .. _Archive_Related_Attributes: Archive Related Attributes ^^^^^^^^^^^^^^^^^^^^^^^^^^ * Archive_Builder Specifies the name of the executable of the archive builder with the minimum options, if any. Example: .. code-block:: gpr for Archive_Builder use ("ar", "cr"); * Archive_Indexer Specifies the name of the executable of the archive indexer with the minimum options, if any. If this attribute is not specified, then there is no archive indexer. Example: .. code-block:: gpr for Archive_Indexer use ("ranlib"); * Archive_Suffix Specifies the suffix of the archives. If this attribute is not specified, then the suffix of the archives is defaulted to :file:`.a`. Example: .. code-block:: gpr for Archive_Suffix use ".olb"; -- for VMS * Library_Partial_Linker Specifies the name of the executable of the partial linker with the options to be used, if any. If this attribute is not specified, then there is no partial linking. Example: .. code-block:: gpr for Library_Partial_Linker use ("gcc", "-nostdlib", "-Wl,-r", "-o"); .. _Shared_Library_Related_Attributes: Shared Library Related Attributes ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ * Shared_Library_Prefix Specifies the prefix of the file names of shared libraries. When this attribute is not specified, the prefix is `lib`. Example: .. code-block:: gpr for Shared_Library_Prefix use ""; -- for Windows, if needed * Shared_Library_Suffix Specifies the suffix of the file names of shared libraries. When this attribute is not specified, the suffix is :file:`.so`. Example: .. code-block:: gpr for Shared_Library_Suffix use ".dll"; -- for Windows * Symbolic_Link_Supported Specifies if symbolic links are supported by the platforms. The possible values of this attribute are `"false"` (the default) and `"true"`. When this attribute is not specified, symbolic links are not supported. .. code-block:: gpr for Symbolic_Link_Supported use "true"; * Library_Major_Minor_ID_Supported Specifies if major and minor IDs are supported for shared libraries. The possible values of this attribute are `"false"` (the default) and `"true"`. When this attribute is not specified, major and minor IDs are not supported. .. code-block:: gpr for Library_Major_Minor_ID_Supported use "True"; * Library_Auto_Init_Supported Specifies if library auto initialization is supported. The possible values of this attribute are `"false"` (the default) and `"true"`. When this attribute is not specified, library auto initialization is not supported. .. code-block:: gpr for Library_Auto_Init_Supported use "true"; * Shared_Library_Minimum_Switches Specifies the minimum options to be used when building a shared library. These options are put in the appropriate section in the library exchange file when the library builder is invoked. Example: .. code-block:: gpr for Shared_Library_Minimum_Switches use ("-shared"); * Library_Version_Switches Specifies the option or options to be used when a library version is used. These options are put in the appropriate section in the library exchange file when the library builder is invoked. Example: .. code-block:: gpr for Library_Version_Switches use ("-Wl,-soname,"); * Runtime_Library_Dir () Specifies the directory for the runtime libraries for the language. Example: .. code-block:: gpr for Runtime_Library_Dir ("Ada") use "/path/to/adalib"; This attribute is used by GPRlib to link shared libraries with Ada code. * Object_Lister Specifies the name of the executable of the object lister with the minimum options, if any. This tool is used to list symbols out of object code to create a list of the symbols to export. Example: .. code-block:: gpr for Object_Lister use ("nm", "-g", "--demangle"); * Object_Lister_Matcher A regular expression pattern for matching symbols out of the output of Object_Lister tool. Example: .. code-block:: gpr for Object_Lister_Matcher use " T (.*)"; * Export_File_Format The export file format to generate, this is either DEF (Windows), Flat or GNU. Example: .. code-block:: gpr for Export_File_Format use "GNU"; * Export_File_Switch The required switch to pass the export file to the linker. Example: .. code-block:: gpr for Export_File_Switch use "-Wl,--version-script="; .. _Package_Naming: Package Naming -------------- Attributes in package `Naming` of a configuration file specify defaults. These attributes may be used in user project files to replace these defaults. The following attributes usually appear in package `Naming` of a configuration file: * Spec_Suffix () Specifies the default suffix for a 'spec' or header file. Examples: .. code-block:: gpr for Spec_Suffix ("Ada") use ".ads"; for Spec_Suffix ("C") use ".h"; for Spec_Suffix ("C++") use ".hh"; * Body_Suffix () Specifies the default suffix for a 'body' or a source file. Examples: .. code-block:: gpr for Body_Suffix ("Ada") use ".adb"; for Body_Suffix ("C") use ".c"; for Body_Suffix ("C++") use ".cpp"; * Separate_Suffix Specifies the suffix for a subunit source file (separate) in Ada. If attribute `Separate_Suffix` is not specified, then the default suffix of subunit source files is the same as the default suffix for body source files. Example: .. code-block:: gpr for Separate_Suffix use ".sep"; * Casing Specifies the casing of spec and body files in a unit based language (such as Ada) to know how to map a unit name to its file name. The values for this attribute may only be `"lowercase"`, `"UPPERCASE"` and `"Mixedcase"`. The default, when attribute `Casing` is not specified is lower case. This attribute rarely needs to be specified, since on platforms where file names are not case sensitive (such as Windows or VMS) the default (lower case) will suffice. * Dot_Replacement Specifies the string to replace a dot ('.') in unit names of a unit based language (such as Ada) to obtain its file name. If there is any unit based language in the configuration, attribute `Dot_Replacement` must be declared. Example: .. code-block:: gpr for Dot_Replacement use "-"; .. _Package_Builder: Package Builder --------------- * Executable_Suffix Specifies the default executable suffix. If no attribute `Executable_Suffix` is declared, then the default executable suffix for the host platform is used. Example: .. code-block:: gpr for Executable_Suffix use ".exe"; .. _Package_Compiler: Package Compiler ---------------- .. _General_Compilation_Attributes: General Compilation Attributes ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ * Driver () Specifies the name of the executable for the compiler of a language. The single string value of this attribute may be an absolute path or a relative path. If relative, then the execution path is searched. Specifying the empty string for this attribute indicates that there is no compiler for the language. Examples: .. code-block:: gpr for Driver ("C++") use "g++"; for Driver ("Ada") use "/.../bin/gcc"; for Driver ("Project file") use ""; * Required_Switches () Specifies the minimum options that must be used when invoking the compiler of a language. Examples: .. code-block:: gpr for Required_Switches ("C") use ("-c", "-x", "c"); for Required_Switches ("Ada") use ("-c", "-x", "ada", "-gnatA"); * PIC_Option () Specifies the option or options that must be used when compiling a source of a language to be put in a shared library. Example: .. code-block:: gpr for PIC_Option ("C") use ("-fPIC"); .. _Mapping_File_Related_Attributes: Mapping File Related Attributes ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ * Mapping_File_Switches () Specifies the switch or switches to be used to specify a mapping file to the compiler. When attribute `Mapping_File_Switches` is not declared, then no mapping file is specified to the compiler. The value of this attribute is a string list. The path name of the mapping file is concatenated with the last string in the string list, which may be empty. Example: .. code-block:: gpr for Mapping_File_Switches ("Ada") use ("-gnatem="); * Mapping_Spec_Suffix () Specifies, for unit based languages that support mapping files, the suffix in the mapping file that needs to be added to the unit name for specs. Example: .. code-block:: gpr for Mapping_Spec_Suffix ("Ada") use "%s"; * Mapping_Body_Suffix () Specifies, for unit based languages that support mapping files, the suffix in the mapping file that needs to be added to the unit name for bodies. Example: .. code-block:: gpr for Mapping_Spec_Suffix ("Ada") use "%b"; .. _Config_File_Related_Attributes: Config File Related Attributes ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ In the value of config file attributes defined below, there are some placeholders that GPRbuild will replace. These placeholders are: =========== ===================== Placeholder Interpretation ----------- --------------------- :samp:`%u` unit name :samp:`%f` source file name :samp:`%s` spec suffix :samp:`%b` body suffix :samp:`%c` casing :samp:`%d` dot replacement string =========== ===================== Attributes: * Config_File_Switches () Specifies the switch or switches to be used to specify a configuration file to the compiler. When attribute `Config_File_Switches` is not declared, then no config file is specified to the compiler. The value of this attribute is a string list. The path name of the config file is concatenated with the last string in the string list, which may be empty. Example: .. code-block:: gpr for Config_File_Switches ("Ada") use ("-gnatec="); * Config_Body_File_Name () Specifies the line to be put in a config file to indicate the file name of a body. Example: .. code-block:: gpr for Config_Body_File_Name ("Ada") use "pragma Source_File_Name_Project (%u, Body_File_Name => ""%f"");"; * Config_Spec_File_Name () Specifies the line to be put in a config file to indicate the file name of a spec. Example: .. code-block:: gpr for Config_Spec_File_Name ("Ada") use "pragma Source_File_Name_Project (%u, Spec_File_Name => ""%f"");"; * Config_Body_File_Name_Pattern () Specifies the line to be put in a config file to indicate a body file name pattern. Example: .. code-block:: gpr for Config_Body_File_Name_Pattern ("Ada") use "pragma Source_File_Name_Project " & " (Body_File_Name => ""*%b""," & " Casing => %c," & " Dot_Replacement => ""%d"");"; * Config_Spec_File_Name_Pattern () Specifies the line to be put in a config file to indicate a spec file name pattern. Example: .. code-block:: gpr for Config_Spec_File_Name_Pattern ("Ada") use "pragma Source_File_Name_Project " & " (Spec_File_Name => ""*%s""," & " Casing => %c," & " Dot_Replacement => ""%d"");"; * Config_File_Unique () Specifies, for languages that support config files, if several config files may be indicated to the compiler, or not. This attribute may have only two values: `"true"` or `"false"` (case insensitive). The default, when this attribute is not specified, is `"false"`. When the value `"true"` is specified for this attribute, GPRbuild will concatenate the config files, if there are more than one. Example: .. code-block:: gpr for Config_File_Unique ("Ada") use "True"; .. _Dependency_Related_Attributes: Dependency Related Attributes ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ There are two dependency-related attributes: `Dependency_Switches` and `Dependency_Driver`. If neither of these two attributes are specified for a language other than Ada, then the source needs to be (re)compiled if the object file does not exist or the source file is more recent than the object file or the switch file. * Dependency_Switches () For languages other than Ada, attribute `Dependency_Switches` specifies the option or options to add to the compiler invocation so that it creates the dependency file at the same time. The value of attribute `Dependency_Option` is a string list. The name of the dependency file is added to the last string in the list, which may be empty. Example: .. code-block:: gpr for Dependency_Switches ("C") use ("-Wp,-MD,"); With these `Dependency_Switches`, when compiling :file:`file.c` the compiler will be invoked with the option :samp:`-Wp,-MD,file.d`. * Dependency_Driver () Specifies the command and options to create a dependency file for a source. The full path name of the source is appended to the last string of the string list value. Example: .. code-block:: gpr for Dependency_Driver ("C") use ("gcc", "-E", "-Wp,-M", ""); Usually, attributes `Dependency_Switches` and `Dependency_Driver` are not both specified. .. _Search_Path_Related_Attributes: Search Path Related Attributes ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ * Include_Switches () Specifies the option or options to use when invoking the compiler to indicate that a directory is part of the source search path. The value of this attribute is a string list. The full path name of the directory is concatenated with the last string in the string list, which may be empty. Example: .. code-block:: gpr for Include_Switches ("C") use ("-I"); Attribute `Include_Switches` is ignored if either one of the attributes `Include_Path` or `Include_Path_File` are specified. * Include_Path () Specifies the name of an environment variable that is used by the compiler to get the source search path. The value of the environment variable is the source search path to be used by the compiler. Example: .. code-block:: gpr for Include_Path ("C") use "CPATH"; for Include_Path ("Ada") use "ADA_INCLUDE_PATH"; Attribute `Include_Path` is ignored if attribute `Include_Path_File` is declared for the language. * Include_Path_File () Specifies the name of an environment variable that is used by the compiler to get the source search path. The value of the environment variable is the path name of a text file that contains the path names of the directories of the source search path. Example: .. code-block:: gpr for Include_Path_File ("Ada") use "ADA_PRJ_INCLUDE_FILE"; .. _Package_Binder: Package Binder -------------- * Driver () Specifies the name of the executable of the binder driver. When this attribute is not specified, there is no binder for the language. Example: .. code-block:: gpr for Driver ("Ada") use "/.../gprbind"; * Required_Switches () Specifies the minimum options to be used when invoking the binder driver. These options are put in the appropriate section in the binder exchange file, one option per line. Example: .. code-block:: gpr for Required_Switches ("Ada") use ("--prefix="); * Prefix () Specifies the prefix to be used in the name of the binder exchange file. Example: .. code-block:: gpr for Prefix ("C++") use ("c__"); * Objects_Path () Specifies the name of an environment variable that is used by the compiler to get the object search path. The value of the environment variable is the object search path to be used by the compiler. Example: .. code-block:: gpr for Objects_Path ("Ada") use "ADA_OBJECTS_PATH"; * Objects_Path_File () Specifies the name of an environment variable that is used by the compiler to get the object search path. The value of the environment variable is the path name of a text file that contains the path names of the directories of the object search path. Example: .. code-block:: gpr for Objects_Path_File ("Ada") use "ADA_PRJ_OBJECTS_FILE"; .. _Package_Linker: Package Linker -------------- * Driver Specifies the name of the executable of the linker. Example: .. code-block:: gpr for Driver use "g++"; * Required_Switches Specifies the minimum options to be used when invoking the linker. Those options are happened at the end of the link command so that potentially conflicting user options take precedence. * Map_File_Option Specifies the option to be used when the linker is asked to produce a map file. .. code-block:: gpr for Map_File_Option use "-Wl,-Map,"; * Max_Command_Line_Length Specifies the maximum length of the command line to invoke the linker. If this maximum length is reached, a response file will be used to shorten the length of the command line. This is only taken into account when attribute Response_File_Format is specified. .. code-block:: gpr for Max_Command_Line_Length use "8000"; * Response_File_Format Specifies the format of the response file to be generated when the maximum length of the command line to invoke the linker is reached. This is only taken into account when attribute Max_Command_Line_Length is specified. The allowed case-insensitive values are: * "GNU" Used when the underlying linker is gnu ld. * "Object_List" Used when the response file is a list of object files, one per line. * "GCC_GNU" Used with recent version of gcc when the underlined linker is gnu ld. * "GCC_Object_List" Used with recent version of gcc when the underlying linker is not gnu ld. .. code-block:: gpr for Response_File_Format use "GCC_GNU"; * Response_File_Switches Specifies the option(s) that must precede the response file name when when invoking the linker. This is only taken into account when both attributes Max_Command_Line_Length and Response_File_Format are specified. .. code-block:: gpr for Response_File_Switches use ("-Wl,-f,"); .. _Cleaning_up_with_GPRclean: Cleaning up with GPRclean ========================= The GPRclean tool removes the files created by GPRbuild. At a minimum, to invoke GPRclean you must specify a main project file in a command such as `gprclean proj.gpr` or `gprclean -P proj.gpr`. Examples of invocation of GPRclean: .. code-block:: gpr gprclean -r prj1.gpr gprclean -c -P prj2.gpr .. _Switches_for_GPRclean: Switches for GPRclean --------------------- The switches for GPRclean are: * :samp:`--no-project` This switch cannot be used if a project file is specified on the command line. When this switch is specified, it indicates to gprclean that the project files in the current directory should not be considered and that the default project file in /share/gpr is to be used. It is usually used with one or several mains specified on the command line. * :samp:`--distributed` Also clean-up the sources on build slaves, see :ref:`Distributed_compilation`. * :samp:`--slave-env={name}` Use `name` as the slave's environment directory instead of the default one. This options is only used in distributed mode. * :samp:`--config={config project file name}` Specify the configuration project file name. * :samp:`--autoconf={config project file name}` This specifies a configuration project file name that already exists or will be created automatically. Option :samp:`--autoconf=` cannot be specified more than once. If the configuration project file specified with :samp:`--autoconf=` exists, then it is used. Otherwise, GPRconfig is invoked to create it automatically. * :samp:`--target={targetname}` Specify a target for cross platforms. * :samp:`--db {dir}` Parse `dir` as an additional knowledge base. * :samp:`--db-` Do not parse the standard knowledge base. * :samp:`--RTS={runtime}` Use runtime `runtime` for language Ada. * :samp:`--RTS:{lang}={runtime}` Use runtime `runtime` for language `lang`. * :samp:`--subdirs={dir}` This indicates that the object, library and executable directories specified in the project file will be suffixed with {subdir}. If needed, those subdirectories are created except for externally built projects: in this case if the subdirectories already exist they are used, otherwise the base directories are used. * :samp:`--src-subdirs={subdir}` This adds the given subdirectory (relative to each object directory of the project tree) to the list of source directories of the project, one directory per object directory. GPRclean will remove the project source files found in these subdirectories. This option may be combined with :samp:`--subdirs`. * :samp:`--relocate-build-tree[={dir}]` With this option it is possible to achieve out-of-tree build. That is, real object, library or exec directories are relocated to the current working directory or dir if specified. * :samp:`--root-dir={dir}` This option is to be used with --relocate-build-tree above and cannot be specified alone. This option specifies the root directory for artifacts for proper relocation. The default value is the main project directory. This may not be suitable for relocation if for example some artifact directories are in parent directory of the main project. The specified directory must be a parent of all artifact directories. * :samp:`--unchecked-shared-lib-imports` Shared library projects may import any project. * :samp:`-aP{dir}` Add directory `dir` to the project search path. * :samp:`-c` Only delete compiler-generated files. Do not delete executables and libraries. * :samp:`-eL` Follow symbolic links when processing project files. * :samp:`-f` Force deletions of unwritable files. * :samp:`-F` Display full project path name in brief error messages. * :samp:`-h` Display the usage. * :samp:`-n` Do not delete files, only list files that would be deleted. * :samp:`-P{proj}` Use Project File `proj`. * :samp:`-q` Be quiet/terse. There is no output, except to report problems. * :samp:`-r` Recursive. Clean all projects referenced by the main project directly or indirectly. Without this switch, GPRclean only cleans the main project. * :samp:`-v` Verbose mode. * :samp:`-vP{x}` Specify verbosity when parsing Project Files. `x` = 0 (default), 1 or 2. * :samp:`-Xnm={val}` Specify an external reference for Project Files. .. _Installing_with_GPRinstall: Installing with GPRinstall ========================== The GPRinstall tool installs projects. With GPRinstall it is not needed to create complex `makefiles` to install the components. This also removes the need for OS specific commands (like `cp`, `mkdir` on UNIXs) and so makes the installation process easier on all supported platforms. After building a project it is often necessary to install the project to make it accessible to other projects. GPRinstall installs only what is necessary and nothing more. That is, for a library project the library itself is installed with the corresponding ALI files for Ada sources, but the object code is not installed as it not needed. Also if the Ada specs are installed the bodies are not, because they are not needed in most cases. The cases where the bodies are required (if the spec has inline routines or is a generic) are properly detected by GPRinstall. Furthermore, we can note that GPRinstall handles the preprocessed sources. So it installs the correct variant of the source after resolving the preprocessing directives. The parts of a project that can be installed are: * sources of a project * a static or shared library built from a library project * objects built from a standard project * executables built from a standard project Moreover, GPRinstall will create, when needed, a project to use the installed sources, objects or library. By default, this project file is installed in the GPRbuild's default path location so that it can be "with"ed easily without further configuration. The installation process keeps record of every file installed for easy and safe removal. GPRinstall supports all kinds of project: * standard projects The object files, executable and source files are considered for installation. * library and aggregate library projects The library itself and the source files are considered for installation. * aggregate projects All aggregated projects are considered for installation. Projects that won't be installed are: * Project explicitly disabled for installation A project with the Active attribute set to False in the project's Install package. * Projects with no sources Both abstract projects and standard projects without any sources At a minimum, to invoke GPRinstall you must specify a main project file in a command such as ``gprinstall proj.gpr`` or ``gprinstall -P proj.gpr`` (in installing mode) or the install name (in uninstalling mode) ``gprinstall --uninstall proj``. Examples of invocation of GPRinstall: :: gprinstall prj1.gpr gprinstall -r --prefix=/my/root/install -P prj2.gpr GPRinstall will record the installation under the *install name* which is by default the name of the project without the extension. That is above the project install names are ``prj1`` and ``prj2``. The installation name can be specified with the option ``--install-name``. This makes it possible to record the installation of multiple projects under the same name. This is handy if an application comes with a library and a set of tools built with multiple projects. In this case we may want to record the installation under the same name. The install name is also used as a suffix to group include and library directories. Examples of installation under the same name: :: gprinstall --install-name=myapp lib.gpr gprinstall --install-name=myapp --mode=usage tools/tools.gpr Note the ``--mode=usage`` option above. This tells GPRinstall to only install the executable built as part of the project. It is possible to uninstall a project by using the ``--uninstall`` option. In this case we just pass the install name to GPRinstall: :: gprinstall --uninstall prj1 gprinstall --uninstall prj2 And both ``lib.gpr`` and ``tools.gpr`` above will be uninstalled with: :: gprinstall --uninstall myapp Note that GPRinstall does not deal with dependencies between projects. Also GPRinstall in uninstall mode does not need nor use information in the installed project. This is because the project may not be present anymore and many different project scenario may have been installed. So when uninstalling GPRinstall just use the manifest file (whose name is the install name) information. .. _Switches_for_GPRinstall: Switches for GPRinstall ----------------------- The switches for GPRinstall are: * :samp:`--config={main config project file name}` Specify the configuration project file name * :samp:`--autoconf={config project file name}` This specifies a configuration project file name that already exists or will be created automatically. Option :samp:`--autoconf=` cannot be specified more than once. If the configuration project file specified with :samp:`--autoconf=` exists, then it is used. Otherwise, GPRconfig is invoked to create it automatically. * :samp:`--build-name` Specify under which name the current project build must be installed. The default value is `default`. Using this option it is possible to install different builds (using different configuration, options, etc...) of the same project. The given name will be used by client to select which build they want to use (link against). * :samp:`--build-var` Specify the name of the build variable in the installed project. If this options is not used, the default build variable used is ``_BUILD``. It is possible to specify multiple variables in --build-var option. In this case, if the first build variable is not found, the second one will be checked, and so on. This makes it possible to have a project specific variable to select the corresponding build and a more generic build variable shared by multiple projects. :: $ gprinstall -Pproject1 \ --build-var=PROJECT1_BUILD,LIBRARY_TYPE ^ Scenario variable to control specifically this project ^ Scenario variable to control the default for a set of projects $ gprinstall -Pproject2 \ --build-var=PROJECT2_BUILD,LIBRARY_TYPE * :samp:`--no-build-var` Specify that no build/scenario variable should be generated. This option can be use for a project where there is single configuration, so a single installation. This option cannot be used with :samp:`--build-var`. * :samp:`--dry-run` Install nothing, just display the actions that would have been done. * :samp:`-a` Install all the sources (default). Cannot be used with ``-m`` below. * :samp:`-m` Install only the interface sources (minimal set of sources). Cannot be used with ``-a`` above. * :samp:`-f` Force overwriting of existing files * :samp:`-h` Display this message * :samp:`--mode=[dev/usage]` Specify the installation mode. * dev This is the default mode. The installation is done in developer mode. All files to use the project are copied to install prefix. For a library this means that the specs, the corresponding ALI files for Ada units and the library itself (static or relocatable) are installed. For a standard project the object files are installed instead of the library. * usage The installation is done in usage mode. This means that only the library or the executable is installed. In this installation mode there is no project generated, nor specs or ALI files installed. ======== ================================================================ Mode Interpretation -------- ---------------------------------------------------------------- `dev` For this mode the binaries (built libraries and executable) are installed together with the sources to use them. `usage` For this mode only the binaries are installed and no project are created. ======== ================================================================ * :samp:`-p`, :samp:`--create-missing-dirs` Create missing directories in the installation location. * :samp:`-P{proj}` Specify the project file to install. * :samp:`--prefix={path}` Specify the location of the installation. If not specified, the default location for the current compiler is used. That is, ``path`` corresponds to parent directory where ``gprinstall`` is found. * :samp:`--install-name={name}` Specify the name to use for recording the installation. The default is the project name without the extension. If set this option is also used as include or library directories' suffix to group all related installations under a common directory. * :samp:`--sources-subdir={path}` Specify the value for the sources installation directory if an absolute path. Otherwise it is appended to the prefix above. The default is ``include/[.]`` * :samp:`--lib-subdir={path}` Specify the value for the library and object installation directory if an absolute path. Otherwise it is appended to the prefix above. The default is ``lib/[.]`` * :samp:`--link-lib-subdir={path}` Specify the value for the library symlink directory if an absolute path. Otherwise it is appended to the prefix above. * :samp:`---exec-subdir={path}` Specify the value for the executables installation directory if an absolute path. Otherwise it is appended to the prefix above. The default is ``bin``. * :samp:`--project-subdir={path}` Specify the value for the project installation directory if an absolute path. Otherwise it is appended to the prefix above. The default is ``share/gpr``. * :samp:`--no-project` Specify that no project is to be generated and installed. * :samp:`--target={targetname}` Specify a target for cross platforms. * :samp:`--no-lib-link` Disable copy of shared libraries into the executable directory on Windows or creation of symlink in the lib directory on UNIX. This is done by default to place the shared libraries into a directory where application will look for them. * :samp:`--sources-only` Copy only sources part of the project, the object, library or executable files are never copied. When this switch is used the installed project is not set as externally built. * :samp:`--side-debug` Write debug symbols out of executables and libraries into a separate file. The separate file is named after the main file with an added ``.debug`` extension. That is, if the executable to be installed is named ``main``, then a file ``main.debug`` is also created in the same location, containing only the debug information. The debug information is then removed from the ``main`` executable. * :samp:`--subdirs={subdir}` This indicates that the object, library and executable directories specified in the project file will be suffixed with {subdir}. If needed, those subdirectories are created except for externally built projects: in this case if the subdirectories already exist they are used, otherwise the base directories are used. * :samp:`--relocate-build-tree[={dir}]` With this option it is possible to achieve out-of-tree build. That is, real object, library or exec directories are relocated to the current working directory or dir if specified. * :samp:`--root-dir={dir}` This option is to be used with --relocate-build-tree above and cannot be specified alone. This option specifies the root directory for artifacts for proper relocation. The default value is the main project directory. This may not be suitable for relocation if for example some artifact directories are in parent directory of the main project. The specified directory must be a parent of all artifact directories. * :samp:`-q` Be quiet/terse. There is no output, except to report problems. * :samp:`-r` (Recursive.) Install all projects referenced by the main project directly or indirectly. Without this switch, GPRinstall only installs the main project. * :samp:`--no-manifest` Prevent the manifest file from being created. Note that using this option will make it impossible to uninstall the project using GPRinstall. See option `--uninstall`. * :samp:`--uninstall` Uninstall mode, files installed for a given project or install name will be removed. A check is done that no manual changes have been applied to the files before removing. Deletion of the files can be forced in this case by using the :samp:`-f` option. Note that the parameter in this case is not the project name but the install name which corresponds to the manifest file. * :samp:`--list` List mode, displays all the installed packaged. * :samp:`--stat` Apply to list mode above, displays also some statistics about the installed packages : number of files, total size used on disk, and whether there is some files missing. * :samp:`-v` Verbose mode * :samp:`-Xnm={val}` Specify an external reference for Project Files. .. _Specifying_a_Naming_Scheme_with_GPRname: Specifying a Naming Scheme with GPRname ======================================= When the Ada source file names do not follow a regular naming scheme, the mapping of Ada units to source file names must be indicated in package Naming with attributes Spec and Body. To help maintain the correspondence between compilation unit names and source file names within the compiler, the tool `gprname` may be used to generate automatically these attributes. .. _Running_gprname: Running `gprname` ----------------- The usual form of the `gprname` command is: .. code-block:: sh $ gprname [`switches`] `naming_pattern` [`naming_patterns`] [--and [`switches`] `naming_pattern` [`naming_patterns`]] Most of the arguments are optional: switch *-P* must be specified to indicate the project file and at least one Naming Pattern. `gprname` will attempt to find all the compilation units in files that follow at least one of the naming patterns. To find Ada compilation units, `gprname` will use the GNAT compiler in syntax-check-only mode on all regular files. One or several Naming Patterns may be given as arguments to `gprname`. Each Naming Pattern is enclosed between double quotes (or single quotes on Windows). A Naming Pattern is a regular expression similar to the wildcard patterns used in file names by the Unix shells or the DOS prompt. `gprname` may be called with several sections of directories/patterns. Sections are separated by switch `--and`. In each section, there must be at least one pattern. If no directory is specified in a section, the project directory is implied. The options other that the directory switches and the patterns apply globally even if they are in different sections. Examples of Naming Patterns are:: "*.[12].ada" "*.ad[sb]*" "body_*" "spec_*" For a more complete description of the syntax of Naming Patterns, see the second kind of regular expressions described in :file:`g-regexp.ads` (the 'Glob' regular expressions). .. _Switches_for_pgprname: Switches for GPRname --------------------- Switches for `gprname` must precede any specified Naming Pattern. You may specify any of the following switches to `gprname`: .. index:: --version (gprname) * :samp:`--version` Display Copyright and version, then exit disregarding all other options. .. index:: --target= (gprname) * :samp:`--target=` Indicates the target of the GNAT compiler. This may be needed if there is no native compiler available. .. index:: --help (gprname) * :samp:`--help` If *--version* was not used, display usage, then exit disregarding all other options. * :samp:`--subdirs={dir}` This indicates that the object, library and executable directories specified in the project file will be suffixed with {subdir}. If needed, those subdirectories are created except for externally built projects: in this case if the subdirectories already exist they are used, otherwise the base directories are used. * :samp:`--no-backup` Do not create a backup copy of the project file if it already exists. * :samp:`--ignore-duplicate-files` Ignore files with the same basename, and take the first one found into account only. By default when encountering a duplicate file, a warning is emitted, and duplicate entries in the `Naming` package will be generated, needing manual editing to resolve the conflict. With this switch, gprname assumes that only the first file should be used and others should be ignored. * :samp:`--ignore-predefined-units` Ignore predefined units (children of System, Interfaces and Ada packages). * :samp:`--and` Start another section of directories/patterns. .. index:: -d (gprname) * :samp:`-d{dir}` Look for source files in directory :file:`dir`. There may be zero, one or more spaces between *-d* and :file:`dir`. :file:`dir` may end with `/**`, that is it may be of the form `root_dir/**`. In this case, the directory `root_dir` and all of its subdirectories, recursively, have to be searched for sources. When a switch *-d* is specified, the current working directory will not be searched for source files, unless it is explicitly specified with a *-d* or *-D* switch. Several switches *-d* may be specified. If :file:`dir` is a relative path, it is relative to the directory of the project file specified with switch *-P*. The directory specified with switch *-d* must exist and be readable. .. index:: -D (gprname) * :samp:`-D{filename}` Look for source files in all directories listed in text file :file:`filename`. There may be zero, one or more spaces between *-D* and :file:`filename`. :file:`filename` must be an existing, readable text file. Each nonempty line in :file:`filename` must be a directory. Specifying switch *-D* is equivalent to specifying as many switches *-d* as there are nonempty lines in :file:`file`. * :samp:`-eL` Follow symbolic links when processing project files. .. index:: -f (gprname) * :samp:`-f{pattern}` Foreign C language patterns. Using this switch, it is possible to add sources of language C to the list of sources of a project file. For example, .. code-block:: sh gprname -P prj.gpr -f"*.c" "*.ada" -f "*.clang" will look for Ada units in all files with the :file:`.ada` extension, and will add to the list of file for project :file:`prj.gpr` the C files with extensions :file:`.c` and :file:`.clang`. Attribute Languages will be declared with the list of languages with sources. In the above example, it will be ("Ada", "C") if Ada and C sources have been found. * :samp:`-f:{} {pattern}` Foreign language {} patterns. Using this switch, it is possible to add sources of language to the list of sources of a project file. For example, .. code-block:: sh gprname -P prj.gpr "*.ada" -f:C++ "*.cpp" -f:C++ "*.CPP" Files with extensions :file:`.cpp` and :file:`*.CPP` are C++ sources. Attribute Languages will have value ("Ada", "C++") if Ada and C++ sources are found. .. index:: -h (gprname) * :samp:`-h` Output usage (help) information. The output is written to :file:`stdout`. .. index:: -P (gprname) * :samp:`-P{proj}` Create or update project file :file:`proj`. There may be zero, one or more space between *-P* and :file:`proj`. :file:`proj` may include directory information. :file:`proj` must be writable. There must be only one switch *-P*. If switch *--no-backup* is not specified, a backup copy of the project file is created in the project directory with file name .gpr.saved_x. 'x' is the first non negative number that makes this backup copy a new file. .. index:: -v (gprname) * :samp:`-v` Verbose mode. Output detailed explanation of behavior to :file:`stdout`. This includes name of the file written, the name of the directories to search and, for each file in those directories whose name matches at least one of the Naming Patterns, an indication of whether the file contains a unit, and if so the name of the unit. .. index:: -v -v (gprname) * :samp:`-v -v` Very Verbose mode. In addition to the output produced in verbose mode, for each file in the searched directories whose name matches none of the Naming Patterns, an indication is given that there is no match. .. index:: -x (gprname) * :samp:`-x{pattern}` Excluded patterns. Using this switch, it is possible to exclude some files that would match the name patterns. For example, .. code-block:: sh gprname -P prj.gpr -x "*_nt.ada" "*.ada" will look for Ada units in all files with the :file:`.ada` extension, except those whose names end with :file:`_nt.ada`. .. _Example_of_gprname_Usage: Example of `gprname` Usage -------------------------- .. code-block:: sh $ gprname -P/home/me/proj.gpr -x "*_nt_body.ada" -dsources -dsources/plus -Dcommon_dirs.txt "body_*" "spec_*" Note that several switches *-d* may be used, even in conjunction with one or several switches *-D*. Several Naming Patterns and one excluded pattern are used in this example. .. _The_Library_Browser_gprls: The Library Browser GPRls ========================= .. index:: Library browser .. index:: ! gprls `gprls` is a tool that outputs information about compiled sources. It gives the relationship between objects, unit names and source files. It can also be used to check source dependencies as well as various characteristics. .. _Running_gprls: Running `gprls` ---------------- The `gprls` command has the form :: $ gprls switches `object_or_dependency_files` The main argument is the list of object files or :file:`ali` files for Ada sources for which information is requested. `gprls` uses a project file, either specified through a single switch -P, or the default project file. If no `object_or_dependency_files` is specified then all the object files corresponding to the sources of the project are deemed to be specified. If `object_or_dependency_files` is specified for an aggregate project and there is more than one such file in different aggregated projects then the file found first is used to show the information. In normal mode, without option other that -P , `gprls` produces information for each object/dependency file: the full path of the object, the name of the principal unit in this object if the source is in Ada, the status of the source and the full path of the source. Here is a simple example of use: :: $ gprls -P prj.gpr /my_path/obj/pkg.o pkg DIF pkg.adb /my_path/obj/main.o main MOK main.adb The first three lines can be interpreted as follows: the main unit which is contained in object file :file:`pkg.o` is pkg, whose main source is in :file:`pkg.adb`. Furthermore, the version of the source used for the compilation of pkg has been modified (DIF). Each source file has a status qualifier which can be: *OK (unchanged)* The version of the source file used for the compilation of the specified unit corresponds exactly to the actual source file. *MOK (slightly modified)* The version of the source file used for the compilation of the specified unit differs from the actual source file but not enough to require recompilation. If you use `gprbuild` with the qualifier *-m (minimal recompilation)*, a file marked MOK will not be recompiled. *DIF (modified)* The source used to build this object has been modified and need to be recompiled. *??? (dependency file not found)* The object/dependency file cannot be found. .. _Switches_for_gprls: Switches for GPRls ------------------ `gprls` recognizes the following switches: .. index:: --version (gprls) :samp:`--version` Display Copyright and version, then exit disregarding all other options. .. index:: --help (gprls) :samp:`--help` If *--version* was not used, display usage, then exit disregarding all other options. .. index:: --closure (gprls) :samp:`--closure` Display the Ada closures of the mains specified on the command line or in attribute Main of the main project. The absolute paths of the units in the closures are listed, but no status is checked. If all the ALI files are found, then the list is preceded with the line "Closure:" or "Closures:". Otherwise, it is preceded with the line "Incomplete Closure:" or "Incomplete closures:". .. index:: -P (gprls) :samp:`-P ` Use this project file. This switch may only be specified once. .. index:: -a (gprls) :samp:`-a` Consider all units, including those of the predefined Ada library. Especially useful with *-d*. .. index:: -d (gprls) :samp:`-d` List sources from which specified units depend on. .. index:: -h (gprls) :samp:`-h` Output the list of options. .. index:: -o (gprls) :samp:`-o` Only output information about object files. .. index:: -s (gprls) :samp:`-s` Only output information about source files. .. index:: -u (gprls) :samp:`-u` Only output information about compilation units. .. index:: -U (gprls) :samp:`-U` If no object/dependency file is specified, list information for the sources of all the projects in the project tree. .. index:: -files (gprls) :samp:`-files={file}` Take as arguments the files listed in text file `file`. Text file `file` may contain empty lines that are ignored. Each nonempty line should contain the name of an existing object/dependency file. Several such switches may be specified simultaneously. .. index:: -aP (gprls) :samp:`-aP{dir}` Add `dir` at the beginning of the project search dir. .. index:: --RTS (gprls) :samp:`--RTS={rts-path}`` Specifies the default location of the Ada runtime library. Same meaning as the equivalent *gprbuild* switch. .. index:: -v (gprls) :samp:`-v` Verbose mode. Output the complete source, object and project paths. For each Ada source, include special characteristics such as: * *Preelaborable*: The unit is preelaborable in the Ada sense. * *No_Elab_Code*: No elaboration code has been produced by the compiler for this unit. * *Pure*: The unit is pure in the Ada sense. * *Elaborate_Body*: The unit contains a pragma Elaborate_Body. * *Remote_Types*: The unit contains a pragma Remote_Types. * *Shared_Passive*: The unit contains a pragma Shared_Passive. * *Predefined*: This unit is part of the predefined environment and cannot be modified by the user. * *Remote_Call_Interface*: The unit contains a pragma Remote_Call_Interface. .. _Example_of_gprls_Usage: Examples of `gprls` Usage ------------------------- :: $ gprls -v -P prj.gpr 5 lines: No errors gprconfig --batch -o /my_path/obj/auto.cgpr --target=x86_64-linux --config=ada,, Creating configuration file: /my_path/obj/auto.cgpr Checking configuration /my_path/obj/auto.cgpr GPRLS Pro 17.0 (20161010) (x86_64-unknown-linux-gnu) Copyright (C) 2015-2023, AdaCore Source Search Path: /my_path/local/lib/gcc/x86_64-pc-linux-gnu/4.9.4//adainclude/ Object Search Path: /my_path/local/lib/gcc/x86_64-pc-linux-gnu/4.9.4//adalib/ Project Search Path: /my_path/local/x86_64-unknown-linux-gnu/lib/gnat /my_path/local/x86_64-unknown-linux-gnu/share/gpr /my_path/local/share/gpr /my_path/local/lib/gnat /my_path/obj/pkg.o Unit => Name => pkg Kind => package body Flags => No_Elab_Code Source => pkg.adb unchanged Unit => Name => pkg Kind => package spec Flags => No_Elab_Code Source => pkg.ads unchanged /my_path/obj/main.o Unit => Name => main Kind => subprogram body Flags => No_Elab_Code Source => main.adb slightly modified $ gprls -d -P prj.gpr main.o /my_path/obj/main.o main MOK main.adb OK pkg.ads $ gprls -s -P prj.gpr main.o main main.adb gprbuild-25.0.0/doc/gprbuild_ug/figures_gnat_project_manager_6in_x_4in.pptx000066400000000000000000002232021470075373400271600ustar00rootroot00000000000000PK!Ì»~á')[Content_Types].xml ¢( ̘ÛrÛ †ï;“wÐp›±°Ó6I;–sÑÃU™IòTZÛ´ÀnüöEø ¢Q*Û ±ovT…ä<Ðê¼@<ìÜ‹G;Π|Õª×Hýo@Ë¿…®³šîƒÞ9ò'홼!sÚ4Œñ“HN.³ùÿÿPK!ˆQ¿ÛÙÎ ppt/slides/_rels/slide1.xml.rels¬‘ÁjÃ0 †ïƒ½ƒÑ}vÒÃVF^Æ °S×=€±•Ä4±ŒåŽæíçvéM¿„>} Ýþ:Oâ{ ZÙ€À`Éù0hø:½?mAp6Á™‰jXaß=>ìŽ8™\–xô‘E¡Ö0æ_•b;âlXRÄP&=¥ÙäÓ ¢±g3 Ú4ͳJ5ºSœ†tp§%–Ëÿ³©ï½Å7²—C¾qBÊÈŸ“wX¨& ˜5HYµ¹ª[YÜAÝÖjï©Å¿Ff¡K^yU}VUxù3S«/t?ÿÿPK![SLÙÎ ppt/slides/_rels/slide2.xml.rels¬‘ÁjÃ0 †ïƒ½ƒÑ½všC7F^J¡°ÓÖ=€±•Ä4±ŒåŽåíçvÙM¿„>} ýákžÄ'&ö4leƒ%çàáãrÚ<ƒàl‚3Ô° á{|Ø¿ádrYâÑG…XØs|QŠíˆ³aIC™ô”f“KLƒŠÆ^Í€ªmšJ5ºSœ†tv-ˆËËå¿ÙÔ÷Þâ‘ìmÆïœP2òûäªIf RVm®êVwP÷µ¶ÿ©Å?F¯f¡[^yU}VUxú5S«/tßÿÿPK!¼½ú¸ÙÎ ppt/slides/_rels/slide4.xml.rels¬‘ÁjÃ0 †ïƒ½ƒÑ½vZÊ6F^F¡ÐÓÖ=€±•Ä,±Œå–æíçvÙM¿„>} Ýþ6⊉= kÙ€À`ÉùÐkø<V/ 8›àÌH5ÌÈ°ovï8š\–xð‘E¡Ö0ä_•b;àdXRÄP&¥ÉäS¯¢±_¦Gµiš'•j´ ¦8: éè6 Îs,—ÿfS×y‹od/†|ç„ ”‘?Fï°PMê1k²jsUoequ_kýŸZüct23]ò«곪Âó¯™Z|¡ýÿÿPK!Ës7L}ppt/_rels/presentation.xml.rels ¢( ¼•ËNÃ0E÷HüCä=q’>x¨N7© $åL2yˆÄ¶<¦¿ÇJ!u«Êl,6‰æZ¹s4㙬Ö_}í@c+#iœD!ËVÔŒ¼n®nH„†‹’wR# Yç—«g踱aÓ*Œ¬‹@FcÔ¥X4ÐsŒ¥aO*©{nl¨kªxñÎk Y’,©v=H~ämJFô¦´ù·ƒ²™ÿö–UÕp/‹„9“‚* ø¤¥BkÊu †‘IŠ-)¡ç!f!!°kK8Œ!Òñ•ù ®CBi9ÐGDê©+ ‰å©" qZ›‘l/þ4kx±–Á±ÍrïÍÂ× 4hq ëàÅ ]Ó9¢dñOå˜û R»âÂmc73ÌcHǧ÷bÌC2x†fæ«ÄmHˆ] Ÿ'«u’~!èÑO#ÿÿÿPK!2wŽ|ÙÎ ppt/slides/_rels/slide5.xml.rels¬‘ÁjÃ0 †ïƒ½ƒÑ½vZè6F^F¡ÐÓÖ=€±•Ä,±Œå–æíçvÙM¿„>} Ýþ6⊉= kÙ€À`ÉùÐkø<V/ 8›àÌH5ÌÈ°ovï8š\–xð‘E¡Ö0ä_•b;àdXRÄP&¥ÉäS¯¢±_¦Gµiš'•j´ ¦8: éè6 Îs,—ÿfS×y‹od/†|ç„ ”‘?Fï°PMê1k²jsUoequ_kýŸZüct23]ò«곪Âó¯™Z|¡ýÿÿPK!ÕÂ'ˆÙÎ ppt/slides/_rels/slide3.xml.rels¬‘ÁjÃ0 †ïƒ½ƒÑ½vÚÂ6F^F¡ÐÓÖ=€±•Ä,±Œå–æíçvÙM¿„>} Ýþ6⊉= kÙ€À`ÉùÐkø<V/ 8›àÌH5ÌÈ°ovï8š\–xð‘E¡Ö0ä_•b;àdXRÄP&¥ÉäS¯¢±_¦Gµiš'•j´ ¦8: éè6 Îs,—ÿfS×y‹od/†|ç„ ”‘?Fï°PMê1k²jsUoequ_kýŸZüct23]ò«곪Âó¯™Z|¡ýÿÿPK!QcdyM ppt/presentation.xmlì—Ýn›0Çï'ío§0Æ|(¤Ò6UªÔIQ“>€ Nƒj ²,éÓïœB“]ô¸Ã>_ÿó˱å,îŽð\麕 oäqY¶U-_ ô¼¹¿I‘§ “­ä:qî–ß¿-º¼S\si˜PÒH³íŒérß×åŽ7L߶—`Û¶ªa–êÕ¯û éáã  ~Ãj‰\¼úJ|»ÝÖ%ÿÝ–ûÊI½½«;}ÎÖ}%Û´‹Ï’4;ðõþEssßJ£ZBÛZT˜6\=TÚ\ìxuU ’„¤%ÀNåv|Cä/þÿÂek¸¾HùioL’¸$ŸÌ£Š©¢‡jÐÓ‰lã{ ædbŽ®Ìæá£reŽ³‰9¾6OPkLu®ß½òX ˜¤”P­<(¢qBaÑ‹í{u^4Óàì•…"œWÅ·l/̆ÍÚœ_.X{«•r_O+å f§šË›çu/fê""ìÀ§aê±@ „‰W8yfÃ^Öï c’ÚžŒè]8{”?Õ› Èmjé–½ƒR0䫽,Í09}1«BC¦°ïâ+{èàÀd±\·¢®îk!ú…=@ü—PÞA5s諯ê™Sí—p<4òFÛË9»0p6J}a(õˆÂÏÄrÇÃ&‚O<¢Á4Ä„Ì|(ŽO4ò9ÉI%žçç ,Ç'ù„!Y·ö<@–ŠD'€¢€b<ßÐp-[*P2Ó„ÐùŠ@–Š”N¥8Mx»ÌGÌRq€²Ò,‹£ÐAX*ý»õú… Ù鿇å?ÿÿPK!ÆLF”²•8ppt/slides/slide5.xmlì[YsÛ6~ïLÿ‡/y²E‚·&rÆVâ¶3M≓çCB;¼ ¶<þ÷î.xè–"¹iœðŦ@`qðÃß/_ͳT»ç¢JŠ|¤›ç†®ñ<*â$ŸŽôO¯Ï|]«d˜ÇaZä|¤?òJuñóO/Ëa•Æ´Î«a8ÒgR–ÃÁ Šf< «ó¢ä9¼›" %üÓA,š¥fî “\¯Û‹CÚ“Iñ×Et—ñ\*!‚§¡„‘W³¤¬iå!ÒJÁ+C­—†t3‹nÓÿWåGÁ9>å÷¿ˆò¶¼ôúÝýÐ’ÖK×ò0ƒeÑõ‹ºýÌ¡< VšOIáp>ÙÅËpsÓæ#ÿÿB£pÈçR‹TaÔ•F³÷êF³7jš`m§8+5£õé°f:ïïÃT3ÛIa͵5Í+Z•¦«v.̳Ϧ Ùža™Þò¬™®§k87×´€*´C‡¥¨ä/¼È4|éN…séaÁ綩yz—½-bUî9†A ²¼Ø„$/HƒõS³„ÿò1D„Ã4ÿÀ'øBŒ¤¶­;4Õ«YsUŒÝmî¢ä Ì •] Ø4ú>0ìº>6å“ dÛØØ50µ~m ê¹È»ÆY’b“€T¶=«úñzaÊ¡œ_ñ#Šû ÿa£™Ž ø€î0fìöH ‡´’·¸¢„xÀ%|Ph¦SPFm%åÊÓµÏÏ>ÝêÚgÚ~q"$í­Êä8å!4¬§½ Ÿ§Í¿2u‚}É‹p:5ϧ¥xq#Š?aIÿ¸ å ñ& 4"žÇ7¡?ì \èef ÛÆÒ‰W@§Un—‰Ûxûf¶–63;i3[–Á| $ÂR÷»¹ßÍÏo7³g¾›f7mj0åš}Ò–ö\pÔÃazs•UêÜÓp]+ ¶jc §eÅ@ ™‹Ö¹7¡‹ÞÈ7jB¹Û >í¢)%Ë,/JÜ?Ç@…0î€/°_î:â“oy¾c˜ ÝC¾÷É#Ýù¿¾:ä!Rád§äÝ“ o:Ì®•<ól«Öá½’o£ÀýPqÒÄ‹¯Žx`—VO<p0ïî¡Lpdæ¨ä{È÷Jž”üF¼8_ñfcvìžÿÆAŠæùmMØñq‚¬«-t+E˜LgR»¢xÐÆEžƒK^-hmH-<2ä$;vrAò:ÏdA`3؆o&…)q™ ô!±y®çúd·¶ U=ÖvŠçÚ: צ=€ÏÆ<ØØû蔓ˆ>àwÂ$}“Çš|,Ö q%ë°'ÍɃÝE@Ömfù0@_{+ËyC‘MÖY>ðä[\¶ùýŒ@}/FyË*o¨I]‘ÎoEO&á‰ØÑÚ@.›7àÍÓ›.K8âÚhå_1êA`Õ<¼m™¾ÝD ›À1Rô5&Sm½6? Ò!ݱG›Öèbf¶gÁÇñ<Ï5).îTqøFP+ã=¤M¯‡k½Ú¨2/ßR¶åéôpëko×Ãï]ëáC=…jÔõbÑg€’ÀØáÔ5¤I•:–…‘ªâŠ¶0Œ§uÆø³ì9d³uô*2ëZÊ!m„OÐÿª EB|ëæÚàâôŽ’»*/ú%ŽÛ﹚Oäº:- ² ‡¾åSȈ&½Ç!æµq|7Šq{Š”µ®éG8mqUÌ5Öy¢jiÈWC†¿.] ™šHlK¼ä†ëÆEÝg¨|Br§û0Ò6ø ˆ9f»Lu¼=`Ú]9&ÃÜihHù6cÿ B8D£Td—½'ÓX^ÞÉâ:©O_¨ ?¾XOäO/†æÔÁŽ¬½œSi!Ÿ¿àh6•IVBV+}—Hßy€àØÞ;ñ”ûâ<ÕÊklA¸œ¬?„€ ,` âwǵɾw t™å0¿c~•Ó$ûq™Gé]ÌŸ0Ûp¦f½œ¦mƒAŒ­"˜™Ía¨ÿCc>Od¶§!Zd.†8^e2`6}d2AgºŽí+±õ÷¯2{âéE iˆvöðï¬MÚn «Y—Ä}Š°Úô™ßÄÕfà›ëY]0õ éKt.û˜ú‰eÀš®¸‘ôéÛLê :Ñ1Ü2:äG"§¬9}0CméÜÔ±áÄ3fZ’±µÌ§xšÏhÚpK ©Ÿö üþÐåY†ÔÓ*]ؤb~›yA®ÛX¨Ô+6¡á ë” —% ¨žˆ(n®è(Ò°f²-Ëa5Õ}<“Ç’¦Ô ÒËKŒÇZÞ­K,ó"ÓýÕ•Ž»îN§¶DXG~yu¥#‡–¸'ø°€T9žÍµ3ÜtBX"ÔîD2Òÿ¾º \6ö¯Î®LûúÌ~xg—×®svíX¶=¾ò/ÇÖ›thcÚÃHpºáö[sS ×nÇeI$Šª˜Èó¨È€w¸f7(‹.Ê"¡›v¦Q_×£«TÌóLNúʵ¤±‘ÃÜŒ“õ º(oÃòý=p1Pr÷« ¨„«€¸ Pµ«‚s‡›wÿÿÿPK!}¿òiD Ëgppt/slides/slide4.xmlì]koÛ8ý¾ÀþÁßÓèýšš´™`§S4ý:Pd9ñB– IMS,ö¿ïá¥(êi)¶œÇV_Û’HŠ¼<<÷ÜKéí/›H¹ÓlÄç íºPÂ8H–ëøö|ñç׫w¡d¹/ý(‰ÃóÅ0[üòîï{»=Ë¢¥‚«ãìÌ?_Üåùöìô4 I¶aŒc«$Ýø9¾¦·§ËÔÿŽR7Ñ©®ªöéÆ_Ç‹âútÌõÉjµÂIðmÆ9/$ #?G˳»õ6¥mÇ”¶Mà ÅÐÕµ&½Ã×Ñ’ý϶_Ó0dŸâû_ÓíõösJ‡?ÝN•õýµPbƒnYœŠÓèkŒÓðá´qù­(É?{X¥›woý3Ü›òp¾@çÿ`q‘>äJÀ ä¯ÁÝçw;Î> e¥ì®øµoG÷Äý|  úm*º[Þ» uc¢”Œ:GÔXÞ’i9nº/ÇfŸj÷Æâ0»CÃÔ=•ŸQ¶Ü?Û¦Yþk˜löá|‘¢a Ö=þý?³œõ®<…ý'Wë(¢J¢˜ý%ÑzÉ~£/Ì<ÃË(Uîýè|‘?h¬=(¢r¾±+Ñgü–ð?ÿÁ Øï_£¢S#ÈÜey~À¦4~èÎ_†¼ wE7Î*- j©@Vò ,Ë. gòBDÙ¼½ÅùìÒpµBŸ”«»Æ/.¯ š“X^¼YÇIÚU@„»*jæçóâ³=Ë.’åVÜ þcr¤yt™ ‡1´~Ü%˜áAžòÁ²üš]ˆò0vôWøÑ-¨<)Œ—ŸýÔÿ‚# ñ|Æ'^mÀEQ)3é†-ìú+fÕEò ÐÝ`¢ºgö«°¢0¨Å¯Õy;`Þš«u,²oÝU5Ëä÷(&¯éšª‡Ã̾-Ýô§¸1óiÞ;­ØRÕB,¾èÛæ÷dÉw˜ýÕÖͯVÚðt&Ȇ¬ZA¿}W*hO+1~¥Ñ|O}`wŒuf¡D¿ÅÙùÂÖ4]Éé‹¡¾¤Õ#7µ#¥Ñ±fÛ÷ßr AÜ0©écì/eg¦ ëSnò—ë4'DV²M~…> ·˜v;ÀææVL¡z¯ VWþNQå ø Ÿùä`G™‘6fÈs´°Ö@ôϨN SÌ~¬”“v–ÿæv›îÕœI›ñÈ1ëAµ£Ø•¬KØÒã0Ólb¦Á0dÌÔmÍÐ 35ËÐÓªƒ&ðÄp R`a5^3h–‹Þ‹MirµEû‰Ì[àå¾Pyœºy!8UƒÊ¡¥åyÇñq0rÅ]0AíˆMS†êĩ㙶݀)ÓÕ4(É¸Ý Su—éEs»ç5ï SÁ SÜYêcéÒföcSN¦ì‰Ø”­z6ó‘BdÊ1<ÎŒRll;3J1Y ýÒ¶î‰RL3žj   âëB¾d[Â6…Óªë<õ×·w¹ò>M“ïÊeÇ“TñJ+J ï°ªUJæR*W‡•U´Þþ‹IL>(¤oÍs ×58ÛÒLÏTI)“2¸é:ÅLK·H•†åö¸„YÑê²¹¼²Ñ8Š•ïh‰M¬M¦Geërü³»Ð_~Œ—Jþc‹×±Pî&\BÏ !±O¤zæþ:’gæéš´ökEëì6luéÑ#4ãn±y„^üÔb³”åWm±ÞAi¼å‡ø¾bkuáRxöÄ­øctS3^MoZ/{ŽbèJ,×…ÌOã|GàoÐnägTêcþi‚8†Æ‚!L—¥ÙðÆlp]Õ®‡ Y£É&'ƒÙî-êŽe[±‰þépƒ°D9xèbž lÄkq—×<úcZËCÖ¦r‘mϲ,›c¶á@´#3”fjyž+ν1Zn7 pšÙP׳‘«KÀgª.¸*J–+²í€jéÈWKª/•v®h=$ò~ð³;®c/ñ©˜™?{t¦³¿¥,sa…)î‡Qk¦2*2{qŸ„—¾6–._°f4›6…ÚÛmòÀAÈÑײx1\DŽ—–L†ší‰Ô; ×Á+Èá±Ü¼é8ÓŒ­¼]i]Ö÷¤á‘YÅͶ?n^;~4ziˆ E°þ׃"ª¤B¶éÁdJ™sÒ".S_gÏ‹çVü쬦Ïá‘8(–ÉýXÍa|¦¯u%Ÿa9'=4½ >Øšºsn¸s‹ˆì⮥FvÜcØV_e]b8»XÏênç­Ä‚Ø2tÏ'¡'öÜÔãIÚ[oëÖtd"wÌ2uÛ¤â%§rm×cÞ åªÇW¢ƒ¦·7åFÇ«+Ê5h MgŒJà¾ä,î?±¸?85J· ™ÌÂ÷ÏÔÃK09#@hFõÕf„ÈsávY/‚m[–˜1‡DšX-™«#›¥™Û…¼*ÍÕÑ|L€Íõ\»‘'`ÚˆØò b˜T[šâ@·ž5¤9ò^£EmÅld#6¿2]\ì%…ANxº§™ºJÁ@é$Îæ×ù‘#ÿÿa~­TkªTì¦ñ.ÖSl&Àîúz‹£ªûL±ÞÖaýAFÝÒ‹]—Ç9ö´Ó¿ü(š*k{dÆäa »N|‹VUR (£)°¬WRÙ:ÃÔl, cÞ•ÿêŽ{T¿§;‘aöa^ƒè&£”òñaŒÒÐà];\ÕÒTh¼›\Òç¼ØF^lƒç 0ÏúªÑ&-Wþ}öÀ4Ô&žãÚ0 ¤Ú%ûìU£lIG+jªÇ7ÈPx„" $GM :±Þ(6çŽå¨:§º†è/h¥©;x4mGþºçy&çýîazÓŒ»â)”#v,S;b l‹*÷çûMZ&E&=KpL×ö aòvEå]cÙOd²0i[GB%ª>–ÍÎá´'§õ«Lˆ>58²Ó™1¶»º,óF7sñÀ×éó$ŽÂÊ|ˆãò€†‰´.ò@é$†éÒÓ—™aÎ;bÇfƒÎd•?ú³x²Û}0´²…NWn“¤±âÈ,¶SA@Æü5Èm˜ xº¨aèÍÐ)& {ª3‹?UB¨ ec$œfÊÎ:-ŸiÍ7”Ô“ž“þ:eµ—þ"mL*]%uGLa r’à™/Ü×#§pïl¶f²NU]ëôõpSÅörøyǤ̳›÷BܼŒ¥´p1ãO˜‚±Täµ™±ÌŒ…½ ¢?³˜ò:ÄËZü€wƒ°g•³×0|KAåþsqáÙú¥{qr¡™W'æÏ9ye['W–aš—îûKãã‘I¸Õ̳ é½0¿‰÷ÛàÇÖ;e6ë M²d•¿ ’Í)„2¼œæt›|Óm²¦÷Óhjñ’ò| ×2Ûu]<Ð^´ ÷Cÿ©µ Á‹÷ÎQú»¿ýãž'¼N'S¤òâ§-^ ÃD œ*OÁ7¼ŠçÝÿÿÿPK!Itj*s yNppt/slides/slide1.xmlì\[oÛ6}°ÿ è=±HݦC“6Û€]Š¦Ûë Ër,@–4JI ûï;$E],)v¯IQ½$Ö©‡çûÎG¾ùa»I´Ûˆq–žéäÔе( ³eœ^Ÿé|¾<ñt­(ƒt$Yé÷Q¡ÿðöûïÞäó"Yjx:-æÁ™¾.Ë|>›á:ÚÅi–G)®­2¶ J²ëÙ’w(u“̨a8³M§zõ<;äùlµŠÃè}Þl¢´”…°( J¼y±ŽóB•–RZ΢ň§;¯ô- ¯’%ÿ_äŸYñ_éí,¿Ê?2qù·ÛL‹—è/]Kƒ ºEŸUªÛÄaŠÛðc¶óøµ*)˜oWlóöM0G۴홎οçñP0¶¥Ê“as6\ÿ>po¸þ0p÷LU€7¨+å­’-ê7ÇRÍùŒÊϳ­fÖíâ7kå'y«{ÍSe¢‹T½uÃ,ÃsmÅ£!&!¾-ŠhÚèPêáœÆê×$¢ê÷æ9+Ê£l£ñg:‹ÂRçÜþR”¼›[øé"Kâåeœ$â€Ûdt‘0í6HÎô ñámñxr³ù5[ÊóxACU+̘?"Jî”–¤‡U@zðò÷V€†ððÅdWæsÞéË{^éÿñîXO1u-ù9-ÐeÔEÉZ)LbÚ8`í+‹Î•2¹ÈІxÃ"wSf—qÕ‹²^[R”Wå} c„É ‡Qy\'Â’I#Es†óIÀ#JOþ¸Òµ…˘•Âpµˆa„ãó›ò"‰PÕýÀgZ\ A´ºG¨Œ×Y¾ N¯sÆ?|)>’8¥Ë >í{¡c¼HS—4?ÑC¢;^®OVYv,‹©WxÔ–"{eñ´^á³e8èÂɘöÍcZe1¼9 c±½‹ÅÖ‘°˜Ûs|s‹]Ó3€¿s{™°˜O™c6^°à/† á8òeºìÃæqŽiÍ…çî—‚?gþì#ÁŸE,Ï5]@B϶v¸(hpÂ?Áj¾&ü;Тÿßaõº8òb“£ìÇ`Èõô u¨Rº[úëe¿ããXpD”Çì ¦lÏ´AáAQP2Çü¯q™- õä2e4íeÍ[½WåʇLÉÔÑnlFÅSâvaÊ=LQâXŽ¶4S.u âO05±©üȾy¿N˜zÍ^nÓ‡¯ÒŸtÈ;9žíñà7îœauä×ô!.L4Ð×@\3¨Ò1¨R¸M¯*ô‚ÿì »@‰WW% âëu©½c,»Ó.²4…ø˜1ͯ¬.â@‰! Ãu‹—K…„*Âmê œ6qEê[P›»­KàRq#·N«Ôó×Á|‡Ž!üÏÆK„Öj œ/áO‰JuÞU‹ª¥u¥„9"±&©vÈÊc?HÈ®µàzyÙ>Û’÷A±–_T¨,¼×Q°ü.µò>‡¸.¥NÔ¶‰–<#è‡ü—€ù2ˆ“æÎ’ÅÐ!£Cw÷Å‚ œüí“ôS´RŸE4§«òHÑX)’ân~× ßúÁJÓ|èÁê~þh´ZÁŽópý„¨9K›‡7qš1}àµË­z啼³D'Ùjü Õ0¨¤m[„eÂO‰u¦Ãèxš}Ûœñ²gm•ÄùŸ\!æM¨r!,Ó÷| Ú€‰ÿ©£R•è ²lŸº‚Kàë~Ã~èëvdÂÉ„[ÙÊ _Ô„é^H'â=lÂP2¸sL ›§¸t¸i¥2Ø&õLA['®Q‚ÁŽØþÍÃ0fú=´„Їy \¡^‚Xö1y‰á½MÃrMSÐ¥1¡Ž‹ÐÑDLøךˆÉêÉÄlZŽˆÉ¢ÃÏI“¼Xóè6A‡q s¬¸CÐu—³V{:8”а IŠ¶Åy/0žÓ›ŸDÜÑ!àÐðÏg Ûò*i™!¨O\Ë•3± ×¢jxV¾°Ç“šÔáPLBß›FÅ·;*Æ‹I/g…+i…PÇsÙ‚ÊÔ¥;þ.Ö)€áHô¦}ÈÉd4póœeÃRúÞeÅß7Cü}ñEɸ*·0À[1'ÕWñ&ÏXùÄ…biÇiw¼ð±Ú R¸4ˆ¯?.KÀ4$mQÙT°UDD ’Ç蟾‰`I’¨$±ð R§vLÓö}O¥S½RÓ”aðÉ0Ç—výo†ÙS¯aªÇ1L“¹{ÇõkRÎ.fN†9º¬lBLZË”5b6²äóÓ"Rã%b"Da»®Ød˜“aVz_?ŠíLå0Õã fÛ0©iÑ^ÆÏd˜“aŽf­*Ä”®‰=1Mj»—40•cV±wÉÔÆež±?QLD³@üá™üd’¶óƒµˆpEŽæüXýs½Zk{µe6RÞ³-Ó0ùþ Üò|â9æÎ\>™æ!ó@Û¨ýò×lšûr€h-µÕ9@µÌ¤ÁzÕô^ÅRÅá#³ÙZKÓ-ßw¥—ÕˆÆí¥é{’Ù’Ûcð@Ƥ¯áPRoqø”LVåTî5¤Zž2¤žBõCjï73dHíýf&CzµY‰ãAl %C…ŸE)r>5ÚÈ9|ºì™òR ‘íÛU¡ÃÃ/2cSh÷]ö7Ãõ ¼úfš6å«PǸȲ/zb×$AI:±\tå÷&“³ñÝY =„A2`§<¥ ŠXï:XF2w|¢áœ×²´¾´u%¥Rr^›-Xê픚€ª¤á:ÃVE¡ÚÞè =â×Yy#mc0Îspë­Å@ °‡Ï,Á/í†Ågú?çç¾C/¼ó“sb]žXï}÷äÝ¥cŸ\Ú¦e]œ{ï.Ìÿbzˉ5Y$v1ûYíƆ“½Ð6qȲ"[•§a¶™ÁⱕÚ,Ïî"–g±ØMÕ–l"mrß·¡ÅË\ñn"œ¯Þ–'W»¤… û5È¿eÜ–°ù[1ä~ãTŽíÞx/àÖæÞvì®öÿÿPK!¸{Tºx ÷\ppt/slides/slide2.xmlì\Ùnã8} ÿAð{b‘ÚJ5*©JOÓÝ…Jõ¼6dYŽÈ’@©² 1ÿ>‡¤¨Å’l'QeéÒKb-EêðòÞ{ùîç»m¬Ý„,ÒälFNõ™&AºŠ’ë³ÙŸ_/OÜ™–~²òã4 Ïf÷a>ûùýOÿz—-òx¥¡t’/ü³Ù¦(²Å|ž›pëç§i&¸¶NÙÖ/pÈ®ç+æßâ©ÛxNuÝžoý(™•åÙ1åÓõ: Âiðm&…| c¿À›ç›(ËÕÓ²cž–±0ÇcDéÖ+½GË‚«xÅÿçÙW†üWró Ë®²ÏL\þýæ3Ó¢úk¦%þÝ2›—ÊÛÄa‚Ûðc¾SüZ=É_Ü­Ùöý;¶iwg3tþ=ÿ‹Bþ"¼+´@ž ê³Áæž{ƒÍ§ž»çª¼AU)o•lQ·9T5ç+*?Oï4Rµ‹ß¬w8É[ÝižzV.ºHÕ[5ÌÔ 1tS4Z–¥;í6Ú”º:“7Ô&ŽADTïï/2–¿„éVã?Îf, Šï$ÿæ?yÁû¸¾…ŸÎÓ8Z]Fq,8&˘i7~|6óƒÞÅãoÛßÒ•<ïXº®ª0æEÄ“[O‹“ã* øóV€†ððÅdWf Þé«{^éÿñn™ˆ'Ž3-þ5ÉÑeÔÁ“µBÄ°pÀšW–­+E|‘¢#tñ†yöá[‘^Fe/Ê:xmq^\÷q(ÀÈ ‡Q¹_ÃN“ä/ÎÇ>7aròçÕL[Š‘±ŠX!€«… #Ÿ7ßqèãeÝ{>ÓòZÀ ýÑè~¡2^gñÞ?½Îÿð…øHâl˜¬>ûÌÿrè…Æx‘º. ?ÑC¢;^®OÖizê¯ò©WxTH‘½²|\¯ðÙ@ Úæd§]x`L«±,†7·ÂöØصÅt$[LuÇö {Ð;†«ÃþN¶˜ãe²Å|ÊÂx5Âü¿à0LöX8£YžQ¦Ë®Â<ÎmZ}aïÜýRæ¾¢ô¬•+jŒdþLÝ¡–áóG,“˜žð3jn,àdÿ„Wó–ìß‘ˆþ¾ÃêuùÈË›|œË>†‡\MZËõ‚”á·-=ýõ²ßña^šµk¦ÌÑÌ”K‰…Ç#‚¢¶K©¹“0]BLXÉ)d~cnÚËÂ[½WÊ“™’9¨!G»ÆŒÊ5<ÌL!Úk{SÖHfŠê.õ ä ‡Ì”Cmx“™š¼©=qdÞ¯ÓL½æ(·îÃWÏ!àj[ {$ dëžÍ“ß0@½áœcx &4 ·o€8g:¹Jc¸JÁ]rUÒ üç.± ƒ!ÍÕUÁüèzShKoµ‹4IÀ=¦L &¨âßoª€(p ˜a¤ï£¸R‘¶Ù6uÎ’¸"é­ö8S\sÆÕƒØáU©‹ü•)sù–m[u.‹Ï6¬Òú)îQ‘Î;œj^¶´j¢d0Ö8ÑnaqñØͲëeÅ·^^6yÏ&ãÇ_ࣟoä$ ŸüÅ&ôWŸ’•VÜgàÖ%Ó‰Ú¶á Œgúÿw~×w, ƒí»»'æœßäÆÉ—p­>‹hN›ä‘œ±"$ÅÝü®5¾UÁ’ÒÜW°¼Ÿ ×kàè!…«¢æ4© o£$e³ž×.îÔ+¯åý˜€%Ùjü Ô(¨~$5š2&røÃÁ­¦óµøEÌÞOª|Q-8í³g‚?DURÜ©¹®Zcæ«T%Ñ6KYñH±³0}ÍdÔN´1T{M³<Ž‰%Å:>.©k:TW–¼\2sp…ÂLƒ¶c0Ç ˜:õ(>çètÛ†¾¼NÀœ€Y²1]*†t¨c@i‹Ù&HbðÈ* œ,æ˜K¨†&Ó7>•W$¡Ò¨ªãÓ `? ©jès1mݦ *O M.&ò'õZÃý3ù1)À¦  ßh>æ‘Õ?Ùɬøº ™5?÷´à§‰Ì^'s‚æ#çò#±QÙÌ× ÍC|2íÒqUÖR“do3õ*Œê•UŽ¦‰|gfo®r< Œˆ#¬´æñâ™Ôþx½³Îp&”òœƒ@ê’b5€25— ÏG©¹uAš[L@zµ\Òp¦”ÊNà+vÂ=m²¤„¸¦…L$|-×±!Åk~ǶLÏ)SÚÅoá@Ó;‡R… 6rˆcQ…hy•;]4rh%ìCîù¾øo¨_ºîÙKÈÕ‡Þ®r–Ï(Wz™Á®ª/ì•«?h±æñ/Ñ·zæàTSkƒú ÉÎ>ÆséUÁQ°¿&×®sóáZ:Ò³e>ä …ex€e˜ä¥ÀEdþ÷ñÛ?MF;4‹&kFŠHg8:öi¡wŠ§H±– (á¾nÃÀUÓê «–/pO ~I(¶ï?÷lzសœóòÄüè9'.mëäÒ2LóâÜýpa|ú±Œ˜‹€…bí_Õ^à8ÙÙ{,ÍÓuq¤Û9¼çYz²,Ä^ÞD/7ŽÒJF+ˆ‘­{*adÑM‹ÿªüÊ(Oùê=+oÊk&‹?­®™‘Ę/ÓÈI†i1uA]M¾æ¨†‡ÁFó…–DÆë9ËÎÞ1Æf¬'&&ÿ^ü¢Ó57"õ1j¿FËÏÔ–—Ôè AÓ©•Ñöpì‘ÏaÑ)5ì°›h°50-¥’“£{l†äz–[Ž+ðÅSolªÅb„Žk†ªF£9—¬âïi‘âab2(fŠé!«¿+.f·­">çÅU’¦²“4ª"MbñM¾xÒiÊŒI'&_[BˆèÔ›h‰9SCÂ?¿Oñý cá±*¶TB½•G¢˜²TÑ’ÄTuãaTrà¢#­ìV ’çP°‘] Ð5•-[é[×Mé|Ž9iSL5nZÈž‹¼mœ%yÁbTuϪ¾š 51嘯/Šø^ˆ›áÆÁx:-0ÃXZ’GËq¦?­øhyX;ùƒ$]€€šJ4¯ #_P’ˆ“æ'ßnjÐË£;•+% ý°5®¿Âª.Šµ!GCÿ´ø5„(,jýµk·OÀÛñ‘ëƒ~‡n¸ðÐŽ<…oÏvGAPA[þ3áÝÁiK]„xrùÒÛìc«ïÀ_Ým~=iO›‹† X²n»ñÝé`Û¬ôú5 ¹cÜcŸ1ôC^MLß ºÁå‹c9^X·dÖ+i@'4¬Êó[6¨IBSª¾þ˜¨É6ÐgÌ$åÇ ã’‘*ãÓ”·6»GÈf¶Ð&ÔŸt"úâg†!˜ˆKbÀ'<+㥤ò+4ì)ˆùÙk’(ƒõÃD:YätQ²©sP5ž¹f;Xí‡àªíKcéyœ ÖR¾æLWpÈA8œèø’3m?´mwÓ+-ËuiúVàXš½Ž¤Ùlz¯’4[Èõ6íŸoÍ—/¥ÊÂSÑ+á©U>µµüÚu|M'ú4匦àpX8þb«Ž' °=˜ÁíqÂúìr¤©þ‘éUûv¿Þ¯’¦fGšR‡¥]^z‹™—ySÁ&Mù¢) ÇÎQÚES3²Ä‘!–#MiJGÚ£*Ümx¿JšAã#S‚©¢u~Sǧâq+² FQ~Õ g$Y,¹qÎXqgL‹X¢¢v,o?) (ŽBÀ›€Šçüø+æxúzòÆvJ2È’ÊJ‰N6 >/o/; Öq)x¯$2Ñ©|~:~`ÏßdÛN[â«HË uN(µU‹·‰Ò(ýJ­ÌÀš†j^}ñiž¦5ÓPÎj’³``ÎÂ÷¿ŒÚwþ¿¶ªë®ÂWU]”îN jûNà;ÕÕù²Ü4è$ÉtÞN»ÄóÞ—­bÊV!Ù6¦l’eù’4ç¯Îò6Coß,äX”ñè­ÊC²lÉ€•3+bÊŠ`fqC ¦¶‰™Ú&˜šëã=­Y²­cÒÖ!Ù>¦lÿ'£³ßoù ÿÿPK!ÕÑ’ñ¾7,ppt/slideLayouts/_rels/slideLayout9.xml.rels„Á Â0Dï‚ÿönÒz‘¦^DðàEô–dÛÛ$d£èß›cÁãì0ovšýkÅ“»à5Ô²AÞë|¯áv=®¶ 8£·8OÞÄ°o—‹æB#æâÁE…âYÃsÜ)Åf  Y†H¾8]Hæ"S¯"š;ö¤ÖUµQi΀ö‹)NVC:ÙÄõKóvè:gèÌc"ŸT(¥3r¦T°˜zʤœßy.jYÞÕ6êknûÿÿPK!ÕÑ’ñ¾7-ppt/slideLayouts/_rels/slideLayout10.xml.rels„Á Â0Dï‚ÿönÒz‘¦^DðàEô–dÛÛ$d£èß›cÁãì0ovšýkÅ“»à5Ô²AÞë|¯áv=®¶ 8£·8OÞÄ°o—‹æB#æâÁE…âYÃsÜ)Åf  Y†H¾8]Hæ"S¯"š;ö¤ÖUµQi΀ö‹)NVC:ÙÄõKóvè:gèÌc"ŸT(¥3r¦T°˜zʤœßy.jYÞÕ6êknûÿÿPK!ÕÑ’ñ¾7-ppt/slideLayouts/_rels/slideLayout11.xml.rels„Á Â0Dï‚ÿönÒz‘¦^DðàEô–dÛÛ$d£èß›cÁãì0ovšýkÅ“»à5Ô²AÞë|¯áv=®¶ 8£·8OÞÄ°o—‹æB#æâÁE…âYÃsÜ)Åf  Y†H¾8]Hæ"S¯"š;ö¤ÖUµQi΀ö‹)NVC:ÙÄõKóvè:gèÌc"ŸT(¥3r¦T°˜zʤœßy.jYÞÕ6êknûÿÿPK!¨Kõ/à0!ppt/slideMasters/slideMaster1.xmlì[[nãFý0{ 8Ÿµø~-–º•4àtŒØY@‰,YS$S,9v‚½‡ÙÁìbfþf)½’9·X¤([ê‘a7`ÇFR±êò²êžû¦úí·×«Ü¸â¢ÎÊblÚo,ÓàER¦Yq16>Ÿ "Ó¨%+R–—›7¼6¿=úË7o«Q§?°Zra€GQØØ\JY†Ã:Yò«ß”/°¶(ÅŠI\Š‹a*دà½Ê‡ŽeÃË Sß/¹¿\,²„¿+“õŠ²a"xÎ$ö_/³ªn¹U‡p«¯ÁFݽµ¥#œ/9ËSúž_4Ÿ?ñ…‘¥×’eÙæÑ[6RçäÓ\W,›ó Û½Ò- Ö#º¹®Îç4*®¾ÕYu*è"ùxu*À,M£`+È—¨M¦. 5Œ·n¿h9±ÑõB¬hGÅúÄMlį¥‘4“Éf6Yþ¸ƒ6Y¾ßA=l€£u¥S5'º{§=Îy&snœæ,áË2O¡+JDê„ÍmbuR&—µQ”83‰¢9*„Ó2¦óÓ£ª¥!o*HI[M×,bgEG_+ù¶›î¤â„žë4¢±½À ½mùx±†ÖIJ–`wx6ªD-¿ãåÊ ÁØ<‘JØÕI-i×~³j$¯'ezCXÌñ Èap¸YŠßL#ÿPÔcÓw/6 ©.œÀv<Óý•ù֊̧%4›eE>c3‘Bí¥€±¯e¹ÈôŽšGÒÃóZžÉ›œ+­vl©âÊÙ;/?ŸÁÞWršs 5HMó,¹4dið4“†6{…¼XÒÑ¥€bÉ‹ô” öÓ-ÎZDJ6­L\£GûµÉí´‰T¹¯L!øPe"™Ú²¢S‘ïzÞ-›ÛÒ)dzÝÈ Õ36Êù•Š´â^z{3ò+¥J¹¨W³R«zK¯È¼hkÍGûHå/î¡Êg<)‹ÔÈùÏ`¯TììÏ—™8œ»Û¸ ƒå5+×B.Þ¼öp‡³Ï;¹#ˆ<ªEù5áî“ÛáA ä¡J8±ßà`Y¾Ð–­`TA‚BÉ=£…ëÆ–åß ¶Yv.ìØ ]µ÷g.”©¶A &l“)³üÎ?7i.å rã$Α¦ê2ÏÒY–çê‚r½M$¯›ÔHf…l²¢Ð·º@Ú%L*Tôø@j̓ԂÞG3ÖA‹ž¥ ‘§*eúݬÙÌ›…ƒ‰ë¼p &¡,7°&ÇÓÈ›Á©*cH¡h2[ñYv±üÇu¸ }’LüÙÁÆY` ´Çµ ¿µ‰YYRRÝsJõj d Ç_ÖLà Ú2­¥ôéPË°£Ðóu"µÛ4B7M&õg46ÙzrÆñ¸*´*yƒçÆÇõj~K1ýÇHÀPH‚õ.ÝTz/¯íÆ®Q7ÿìn»)žœfvnû]8›3çý`æpÛ±ç b{b[QèN&Çï;·]“âPò·‡xëÏŸþõ×ÏŸþý¾Z&mÙŽŒ%Õ”›®E66ŸLâÀ™FìÜ› ¼wq88žþ`FuÀtO]÷ØÞ(\5>¤ºÙÉ; ŠU–ˆ².òMR®†M§cX•¿rQ•§„,Ý1QýÛŠÝÈ"'Ðe ö¦r›v·8BÛÄHrñ« ´(Ø%Ú Ôc3½Äh~áÐjvyQz‰KôE@¡í Ö›™ŽÆmgP¥5K8˜´3~;ƒ×,í \Ì2ÏŠKƒ¾LcQæß7í¨q1p'ì¦\Ë©F¢7£ÇFI¹ÕÑbD]ñ!Õí†}´>‚TG««É½´UG«óÔ½´OG«£÷^ZH®£Õu/-µÚ³)ØU®•Ì–|H»£UUçhCGÝ‘ø6ß°GÿZ´;¾¶*Ž¿°‰-àÚ>POxy­Ú5™£êA¨KòÛ ,EiŽðœÍϾR‹%¢ýȦsÂÙI1Ð<àJ ÄB_B%–h‡ Kyº.IëÄ»®’ 5õÔè4ÑÙmÛ"Ú¬Î×Ñ)U¹uÏ ;È‚Mã’ ê²¢õyP" &HŒ{i2NHU9í=µ±ù·Õß¹$²[ œ5 I}k!©ia_Ò½-Ut3Ñ ¹#â'8JìǨ{Œ¬€›†¨íD[B|mùC”›ê¢Ch¾ž•¨?(õoÄt,2–›FÅŠ²†Ô,ÇšXåá»ýê2™,gl•åhº˜H–LÔÇÒ]ùzŠ5=6?úg#ÝÊvôµP.ö¡\ ö \ ¾ˆ²2‡ª½IÏAN¯µA2pæòüÇ]$©ûûUìõ‘$ø´Ûs7H¾kÃÕöt­€ } Hî°Iï Iði$½ ’±í¹h;½L$wØ$^¼=y›$ø4’þIÛ}?†7ݸ×c”ÿýÏ]ïú$ø4’AIÏ "o+P¾$w¦<ÏJÂOCö  â‡i”ÏJÂOCõ Tu ¹è_Ÿ-”„Ÿ†2Þ@é8Žå‡è]¼B©ÞÖ —úYá§Z½^A5*å’‹®s€:ù´\WÌýtíMÒvršâxüâ¥_·Sá©W{ôjV›K¯nW¿Bð*ŸÝÕpÛõ{•Ïî3Œð®ö«4ž›}í©Ü,Ï‹C´Ç_hOA¤ÊŸWˆµ§Ìðƒ?7}Õ «|Oò9QháåÏ«‰íI‰­(Ž}zÁª˜õxoUž›“îÍ~n‰÷Ü›w‚ôÞ¾ýŸ GÿÿÿPK!J¯u9Ô¿*ppt/notesSlides/_rels/notesSlide1.xml.rels¬ÁjÃ0 †ïƒ½ƒÑ}VÒãN/cÐC/¥{a+‰ibËíÛ×P vÙIüúô¡íî2Oꇳø ´ºÅÁFçÃ`àëôùòJ GS làÊ»îùi{ä‰J]’Ñ'Q•ÄÀXJzG;òL¢câP'}Ì3•ó€‰ì™ÆMÓ¼b^2 [1ÕÞÈ{·uº¦zùovì{où#Úï™CypeòŽ+òÀÅ€Ö÷ŽÜK««,àcö?=B,,’Âye³è .¯®ÞÞÝÿÿPK!ÕÑ’ñ¾7,ppt/slideLayouts/_rels/slideLayout1.xml.rels„Á Â0Dï‚ÿönÒz‘¦^DðàEô–dÛÛ$d£èß›cÁãì0ovšýkÅ“»à5Ô²AÞë|¯áv=®¶ 8£·8OÞÄ°o—‹æB#æâÁE…âYÃsÜ)Åf  Y†H¾8]Hæ"S¯"š;ö¤ÖUµQi΀ö‹)NVC:ÙÄõKóvè:gèÌc"ŸT(¥3r¦T°˜zʤœßy.jYÞÕ6êknûÿÿPK!ÕÑ’ñ¾7,ppt/slideLayouts/_rels/slideLayout6.xml.rels„Á Â0Dï‚ÿönÒz‘¦^DðàEô–dÛÛ$d£èß›cÁãì0ovšýkÅ“»à5Ô²AÞë|¯áv=®¶ 8£·8OÞÄ°o—‹æB#æâÁE…âYÃsÜ)Åf  Y†H¾8]Hæ"S¯"š;ö¤ÖUµQi΀ö‹)NVC:ÙÄõKóvè:gèÌc"ŸT(¥3r¦T°˜zʤœßy.jYÞÕ6êknûÿÿPK!ÕÑ’ñ¾7,ppt/slideLayouts/_rels/slideLayout5.xml.rels„Á Â0Dï‚ÿönÒz‘¦^DðàEô–dÛÛ$d£èß›cÁãì0ovšýkÅ“»à5Ô²AÞë|¯áv=®¶ 8£·8OÞÄ°o—‹æB#æâÁE…âYÃsÜ)Åf  Y†H¾8]Hæ"S¯"š;ö¤ÖUµQi΀ö‹)NVC:ÙÄõKóvè:gèÌc"ŸT(¥3r¦T°˜zʤœßy.jYÞÕ6êknûÿÿPK!ÕÑ’ñ¾7,ppt/slideLayouts/_rels/slideLayout4.xml.rels„Á Â0Dï‚ÿönÒz‘¦^DðàEô–dÛÛ$d£èß›cÁãì0ovšýkÅ“»à5Ô²AÞë|¯áv=®¶ 8£·8OÞÄ°o—‹æB#æâÁE…âYÃsÜ)Åf  Y†H¾8]Hæ"S¯"š;ö¤ÖUµQi΀ö‹)NVC:ÙÄõKóvè:gèÌc"ŸT(¥3r¦T°˜zʤœßy.jYÞÕ6êknûÿÿPK!ÕÑ’ñ¾7,ppt/slideLayouts/_rels/slideLayout3.xml.rels„Á Â0Dï‚ÿönÒz‘¦^DðàEô–dÛÛ$d£èß›cÁãì0ovšýkÅ“»à5Ô²AÞë|¯áv=®¶ 8£·8OÞÄ°o—‹æB#æâÁE…âYÃsÜ)Åf  Y†H¾8]Hæ"S¯"š;ö¤ÖUµQi΀ö‹)NVC:ÙÄõKóvè:gèÌc"ŸT(¥3r¦T°˜zʤœßy.jYÞÕ6êknûÿÿPK!ÕÑ’ñ¾7,ppt/slideLayouts/_rels/slideLayout2.xml.rels„Á Â0Dï‚ÿönÒz‘¦^DðàEô–dÛÛ$d£èß›cÁãì0ovšýkÅ“»à5Ô²AÞë|¯áv=®¶ 8£·8OÞÄ°o—‹æB#æâÁE…âYÃsÜ)Åf  Y†H¾8]Hæ"S¯"š;ö¤ÖUµQi΀ö‹)NVC:ÙÄõKóvè:gèÌc"ŸT(¥3r¦T°˜zʤœßy.jYÞÕ6êknûÿÿPK!ÕÑ’ñ¾7,ppt/slideLayouts/_rels/slideLayout8.xml.rels„Á Â0Dï‚ÿönÒz‘¦^DðàEô–dÛÛ$d£èß›cÁãì0ovšýkÅ“»à5Ô²AÞë|¯áv=®¶ 8£·8OÞÄ°o—‹æB#æâÁE…âYÃsÜ)Åf  Y†H¾8]Hæ"S¯"š;ö¤ÖUµQi΀ö‹)NVC:ÙÄõKóvè:gèÌc"ŸT(¥3r¦T°˜zʤœßy.jYÞÕ6êknûÿÿPK!X¤MÓK1 ppt/notesSlides/notesSlide5.xml¬VÝNÛ0¾Ÿ´w°|µ]¤iúODŠšŽNH¬TÀ8n›Í±=Û-í²½O²':ÄMëØ>ç|çç;Çû댣Ó&•"ÂA­ŽT&©˜Gøüläõ02–ˆ„p)X„7ÌàƒþÇû*Ò2ƒ@^˜Dxa­ }ßÐˈ©IŜͤΈ…O=÷M.AoÆýF½Þñ3’ \Êë]äål–RöEÒeÆ„-”hƉìf‘*SiS»hSšPã¤ÿÔßè”'ù¿Qgš±|%V_µšª‰vÇãÕD£4ˆa$HÁ~yP^sŸ®ÁÂ$>¯4‘p=ÓYŸ„àZG¿ÉAˆ„lm-6éý.]œl¹K‡[nû•@pg4÷ªðè©;Ê)O†Ž22gh e ɦQpçg!L@Ù±¤? ÅèÂÅó‚ÆÓœ‡P(Iª­+ d2;äŒËʱýé>äÞBè*…۵ÚMåì¦ug fG˜Û2 8½%¢JÌßênÁ5K9CŸno~Ó¥ÖÐÐqÔ•‚onoþ|ß`åÅÊRZ~2{д7KçKÍjOÃÃD2!šœ>.å;í9Ã\Ñq*rÀò5Z·*Z=j¼Ì. 1=dwó=Ø }TC)üŠðÏ%Ñ–éŠìŽeïÃöOܹGÝ^Ï â8ðZÝfìÅA3ð:ÍQ·ÝŽ½V½}ïz$tg趲zK‘´ïK,æRÏdç…œ¸ÔTãfÓ±þ¢Ü”Zê4ÂWq¼×i {9ðÖÈk}ÙëzƒQ§íÚÍVk÷Ãæá5@VA+¤š¹É{””/Ø|2µ³”jiäÌÖ¨ÌübüûJ^2­dê^A½|F¬p£ìÕë{½F·€ÒM -¸PMvÊõ7¢NV®ÝƒÒ;t[ ž(eï¿¿’';"ý¿ÿÿPK!*ÖøÈZ: ppt/notesSlides/notesSlide4.xml¬VÝnÓ0¾Gâ,_ÁE–fM×-š²¢I°M®+ÏqÛ€cÛíZ/·'áØI¶±Ö¡Ý´ŽísÎw~¾s|x´)9Z3m )Ríu0b‚ʼ‹ü0 KDN¸,Å[fðÑðù³C•i™A /LBR¼´V%ahè’•ÄìIŜͥ.‰…O½sM.AoÉÃýNç ,I!p-¯w‘—óyAÙkIW%¶R¢'°›e¡L£Mí¢Mif@—þÒ|£Sž»£>hÆÜJ¬ßh5UçÚŸ®Ï5*rˆF‚”Öõ5ÿ)à,Â;â‹FI6s]I¾¡MŠ!ü[÷ B$a‹hµIovéò¬å.]·Ü€àÚ¨óªòè¾;û;S^ä ”dÁÐ9'”-%Ï™FѵŸ•0eo%ýlàyù^Úz5^±`#£õ[U4è麱íBäШ%²[4²fh7•:ÚMëÎ@ÍŽ0Û2 8ÝQ%O Í ÎЋ«?éJkèEÈxÖIÁ·7Õùêǯ—ÉÄ£EUQ*©-tïÌ‚™ÒòzŠ 7:fób±ÒlïA˜îZd"?'š¼¿[Ó×ì¨æ«Ô°–ñ;nø]5«ÓUyê6Í»OAshH jâkŠ¿¬ˆ¶L7¬÷t{ÚÏyîÊ·ñññxÒ ‚(Ë¢ îw³ ‹ºQpÐô{½l4ˆ;½ïøºYB›€®•Þ-yŒo ,:©¿dç9ñ©iæ"”À[FùqµÒEŠ¿eÙ«ƒýñÀ'AüúU?MzÁ¤×ãq6»Çß²Šâ„jæGðI^?`óÞø. ª¥‘s»GeVï€PÉK¦•,üS êÔï‰5á)3QÔýA=G¥# Zp¡ñ”ëwD­}ß…— ¤wì·T{=n®¸d»i2ü ÿÿPK!¶H•â!ppt/slideLayouts/slideLayout5.xmlìY[nã6ý/Ð=ê·ÇzK6’ "gTÈ$AãY#ѱ:’¨J´“´(0Ûj—3+é!%Úò«£8ù G&/ïƒ÷ðêòäýcžiKZÕ)+Nuó¡k´ˆY’÷§ú§i4t­æ¤HHÆ zª?ÑZöã'å¸Î’KòÄ\FQÉ©>缇u<§9©ß±’˜›±*'_«ûaR‘`çÙÐ2 o˜“´ÐÛõUŸõl6KczÁâEN Þ€T4#ú×ó´¬ZÙ­¬h ¹zS%þTÂZþÀ¦Óv}÷›®Iáj‰aS?ƒýñm–hÉ10ayIª´f…œ©ËiE©)–?WåmySÉWË›JKÐ.Ô‡íD+&¿ÃÃpkù½B"ãÇY•Ÿ1¼¡=žêÚ“øÄ"2¦\‹›Áx=ϯ÷ÈÆó{¤‡ê ÁêGï²±h×K™3MyF5seU#J°ô’ÅŸk­`°S˜ß˜_-˜°YÀ—s­u½€jåšIé%_çÒYü1dÉ“0üÿå g5¿åOB€çefÊqBg¿6®í ÃÚ®8Œ$c¨‚+#"h1øt‹<Èù$£yÒºšŸM²4þ¬q¦Ñ$åÚGRsZi\z¡ œ#”-$-’R(±,¼AÆøe˜¨ìÁcãðÃn·Wn1¿ÉHLç,K õþÔ±]±—TÀBxkkKZ¾c[; ÌÀ·|¡ÑzsZŽå˜& [ÔvLËðd¬Ž´¾ÙÊ!*À)â9YÜ5Ý൱ÖrR]Ê´H‹ù-ůß-®@bR‘f+hõ0Î1 è²²³5䣅ÍÓZži9|ÒÕÜEPB¨i¯Q]ËrÐl/TcU@µ¨ÎÕlßFböAí‚ ¤Ô]ƒš†ãŒ|ïhTÕ¢zTÛð,±YŽÔU@µ¨~Õõ|Çë­=P-jÐA ¬À7FGë* ZÔÑÕ2‚ÑÈE:é%9¤› ’ÉÄo`»­(KþøñÌ&ˆF[½ÁlÇ°"£Ï‚#I7Ì~‰´ž“l‡ ú’t(é&q®vÏÃôešîhdK…ð—e¾í:} LòO7P;'Ôš–š“¡#€GÅ"] d³’UUÜЕ²’UU)ß‘i±UóUy|HTÍCT%ç!Q5Q•q‡DÕ'6¯ëô—ÜfiBµ«E~·å—àeGp³_qƒè½®ùFËä9®YmÛ ?Š¼Èú0ˆÛväXƒÁƒÐ M#ðí0<ÿ°Ú¶µ°¼€v}wë×/ÿôõË?¯°WeóYÝààL¸¬ÑÂ/åÅÊ¢J‘a8ò¬IBs'8#pyî rmÇ™„ÁùĆ!Xc:㸢òzé—¤½æÂàÎÕTžÆ«ÙŒ¿‹Y>l%{ UÉRyÍeí]Ù’ ™çžïÙ®‡f4"}¡¥ú/µÅ¸ž’UZV}$åõdMƸ•C†MäP‰{¸fu¼¶«{½³ÿÿPK!T_é}i!ppt/slideLayouts/slideLayout4.xmlìX]nã6~/Ð;ê³bëÇ’,Ä^DNTÈ&ÁÚ{F¢cu)Q%iÇÞ¢À^«=Ξd‡”˜u¼Jm7~*$¶L}Î|óÃ!Ïß­KŠV„‹‚U#Ë9ë[ˆTË‹êad}œ¥vd!!q•cÊ*2²6DXïÆ?ÿt^Ç‚æ×xÖŒJÄxd-¤¬ã^Od RbqÆjRÁ»9ã%–ð“?ôrŽAvI{n¿ôJ\TV;Ÿ2ŸÍçEF.Y¶,I%!œP,A±(ja¤Õ‡H«9 FÏ~®’ÜÔ`­|d·÷¿[Hãø Fk ¦gSš£ —00{dhÂ* bô+QÏ8! T­~åõ´¾ãzÆÍꎣ"WÚ™V¯}ÑÂôÏ `ðÐÛ™þ`$áx=çåøÇÀZ,pØF}Â$“µDY3˜}Í·ØlqÕî™@ƒ§EÁ×ucÑæ¸ÆœY!)AΓU ÃÔk–}¨b`§2¿1/»YaÊf%¾^ –v%ªÅ5/5/€SM–\',ß(Ãïá[☠9•J4! 6ŽA8|ý«¨&•ýq Q]Ê %¢¾%OŽ'´È>!ÉÉ ‰Þc! GRÛ%”Ès`G‚sZ‘¤Êï0Çv$+ûp +ƒÒFCxl(|™HÏÙFº£8# FsPÂ}­â3d¦s "ÂÃøàn];Q憾ç6¡ <ß߉7×w='€÷*ê\ßñ"?Ôþ3‚´ý— %NSKÓutÖà8'sÅ®RÄëEÚ-<ºXk€õ:°Î6Öëw`ûÛXì`ÖìÃ`Ã}Xl´k€îÃ6Åu›MÊ1:™`& OYóÊäRKç–x–\Mí.©ãöˆ|ž’ŒU9¢dEèâu’!~¶(øáÒ=•GHOÙ’ËÅÁÊûÇŠ/æÒa9iYóÿ­¬iN`;5{Á‘»ÅNYÓþÓ;…ª4úa{Ëè,kQ4|«kP·jë[];*O»›†·ºöR“õ?©kS×.±$Ïz5]‰ÿ{QkZà\B‡ºÓµ59ªNõ혖xçuùsôÓÔOC;ñ¶&‘„nh÷½ Ÿ\L"Ym_žƒ©²(IZ<,9¹]ªìh;ýoWgíÃI þœàû6 *¨Ù§Ýmã•”1Õ¼o÷Ѓ×õÐ_æ’7Žùc‰9¬`:ê=-õ1¾9-#¡adJ‹œ ›ey¿ÃKp ^à2DwR³g[>†š§°½ Ó4HÝ+;õÛ¡ïÚC8„؉“8ý(ô’äâê)l…²¼íÖ¯_þþåë—N«úÜc.`O¸p~¬õ9}É È¿$î$J@s?µýËah_¤ÁÀNÕ)k’D 9Žgœè›ŠßòöƸå(‹Œ3Áæò,ce¯¹.éÕì‘ðšúÆÄé·×.+ m¼;ý Œà_…è Zšo­- ©ë¥vFù{\ß® »Â1\ð@üOôP W:Íì-ˆ²Ý\¿ÿÿPK!ceVçR!ppt/slideLayouts/slideLayout3.xmlÌXÛnã6}/ÐÔgǺPI‘µ²IÐd?€‘èXXêRŠö&- ìoµŸ³_Ò3”d;»ÙÖ Œ €!K9IïJòL,j‰µ`yä$Ëæ Ø·±j éA7/ÒƒŽ÷ŸzˆÇE ž«‡Ûïë¡äêÜ,ϢʱÏÐ-…ôvyÍóâ2ת ÌïK®0Ûÿ©Áž›ý2‚TÕÈP= ëbYÞ~ÅK°^pê…é'©1å®9¥ìO¶§Qš†©w6JYÙN˜7šx¸$nâ:qä'ÉÉÙZ¶-y^Ý®jýòù|þgZ5ç„áÔ‹Ýç¼Åy£1‡Ñ¥*°þ’dz³8r–ŽØé$¤a0JÈfI|2óáƸlš)aŽä¿æý§4~sœ/‹LÕm=×Y]Ž»ïã¦þ$TS£8¦EèôßLåÌ<Åâ„ù1Éxrø7hÑDÇzsb‘ê=o.WfÆ— èE5š|»èFg›.äûð-äø_ÿÿPK!ø³a´™ !ppt/slideLayouts/slideLayout2.xml¬Ván£Fþ_©ï°¢¿ cl£Ø'ㄪR.‰êÜl`è-,Ý]ûìV•îµÚǹ'é· ä.9WrjK†eæcæ›ÙoçòÝ®âdˤ*E=sü‹CX‰¼¬Ÿf·‡Ô8DiZ甋šÍœ=Sλù?\6±âù Ý‹&À¨ULgN¡u{žÊ VQu!VãÝZÈŠj<Ê'/—ô°+îƒAäU´¬Î_ã/Öë2cW"ÛT¬Ö-ˆdœjįŠ²Q=Zs Z#™Œõ~’Þ7ÈV<þæk$·xô9òÎV<'5­°ðPjÎØ!KQk YÕ`íõ@ÏE¹›6£ïÓ útZ:üç¬ZS ב}T¤ÈӤߦ—Ýn{0“³o Ò2¯ ³]ûÒòÑÛ+pjÉÒ»Dä{“ø#þí"¹Ò+½çÌ‚°i p\@?§¦±Yí~X¡±+½äŒ¢ñ;òô|ÉËì#Ñ‚°¼Ôä=UšIbƒÁ6ä%ØÑ(NÉêüžJúë+d“ñeÝGˆÛ–Âÿ&rØÙu¹ç4c…à9‚N£µÌÑ=óg` |ËŸ©;‘aÓ¶–`õ‚á–EK%.ý'mo(êŠe{”³-ãGÀ[¦ßÿP”òxô¡©ãÐS±‘º8:øð­ðåú :”䬽ö½}E5{ÑØ–Èj¯ÿK/ríü4Ÿòµ‘5Ín7µ• #.'éÇ’o”ûÏQ4HÓ0»Ép´pÃq2q“q0vÃh,–“pE9ˆåHU—K˧dws< ò¯Äâ …8Ùðó£¯íŠŒ÷y«2ê«’ a”î[Á±tj]ÖZ¶…ù}C%¾Ð×æŒJt^F¢ž‘/sFn7Õã+^F§ q{¾axôAj¬üœ¹m¯Æi¥Áµ›†Úvî4À%ñ0“dqýܶÊd^#ºc»õËç¿úòùŸ3ôª=$ûé gÂÂaÛØ¡f#Kì¿$™FÁr’ ò0uëéØ]¤ÑÈMGÃ0\&“ÅrˆDàã‡q&™ì~É» ‹ßM…U™I¡ÄZ_d¢òÚñÒkÄ'&QÚ Ótcê–â¸óƒiDÓÈŸ˜6@¼ˆ²ÿ·ÑbÉLˆ&ìŒË÷´¹ÛB}hŒý¿´K FàÖû“{?RÏÿÿÿPK!%5…tª!ppt/slideLayouts/slideLayout1.xmlÌXmnã6ý_ wÔßZK­/$YDNTÈ&A=#ѱ°ÔG)Úk·(°×j³'é#%ÅÞlŠu[£085½™7$ßèìí¦֚ˮlêsÛ{ãÚ¯ó¦(ë§sûýCæD¶Õ)VL45?··¼³ß^|ÿÝY›t¢¸aÛf¥,ø¨»„ÛK¥Úd2éò%¯X÷¦iyg‹FVLáV>M É>Âw%&ÄuƒIÅÊÚæËCæ7‹E™ó«&_U¼V½ÉSÀß-˶½µ‡xk%ïàÆÌþ’Ú¶ˆV•JpÛ2frϾ@äù\VÍ* ‰1Ø/ÒƒøÒ$‰µðP5VÅäY6e]`é›K&žÀÊK„¯n±Õ _€=Ø5XâY)„¹ÑûŸ i­™À.±ÑÛø+kÕ„SסšÍPîöü ŒÑ?.|Ú.É* ¾7nRI‹stà[eA&S4±7J5©ëJ¼!5’'¼! ¾•\ÔHÁ«X»…@w»¦này±[£ŠÙ]¼xK[ó–l Ò˜è¿KR‡ÐÞPÄnm˸‰|{ ÈñŠC52㡲¹„èÛ}ͪY ã{±[ «*tlc»Ý‡Îͼ2pƒ…û,|ÝgBé¾õtŒR ÀÚOlPê Ÿ„R²WnøÉŠ7—¯øâÍÙ+Þn¿Tð¸©FÕ"z 'èá,"Ö’"L6œDXþ#À6 A–sŽo¥Å8@ÖL´HñŮϫáëšÕR_(h¼o "¢¥ ü8߀5 ig³èã%ÐmxTûŒÍÉ ü#J©T+u ÄpˆPZ‚‚Z”ïƒØËó(Oœ,Ìœ(ɆN–‰ã…±—ÍæÃhÇ?ì¾(€ªªšäÕz+ÈåVA; T€ÀÐp`s®WPw­æ” 8P#ѱVIÔ(ÚM: èkmÓ'Ù!%:ŽëÔr›G–îï¹W|óö¡*­mÁëcÛ=rl‹ÕÏ‹úþØ~›ŽbÛj%­sZòšÛ¬µßžüüÓ›fÚ–ù}äKi£n§ôØ^HÙLÇã6[°Š¶G¼a5~›sQQ‰¯â~œ úÜU9ö'W´¨í~½²žÏçEÆÎx¶¬X-;ÁJ*a»(šÖ°5CØÁZÐèÕÏM’ ¼åwÜ>Ø–†‰n¸ö <ÏnÊܪi…3^K0X ¹°f´QvhLÛÜ Æº^ý*š›æZ襗«ka¹¢ê)ìqÿCÓ_kÀp1ÞZ~o˜èôa.ª“7tŠˆXÇ6÷¨>±ˆNÙƒ´²îföt7[\íÀf‹óè±y,X?9o:¾vÇ3îܲd–»öªƒR,½àÙ‡Öª9üTîwîe—+C¦|VôÍÂêÂ/Uë~Ôñ0øVÇÔºŽ„ßëÂá’ ô¢ç1qc‡Lblk™ÐD¡Ú¦Ãq3• ÏU@ïðy£u¶àاweÙÊùX"ËtZ®JöX´¼G!•Øtš³ùï¸Õ~‚»®“îŒßklØUCXia],?XSJRuIµÏjª«]<ø0Ô÷€2¾a¯s«d+V ×µuýí¢ÃÙýNÜÇ+åKæ7Ôxr(}1ßÉŽ.÷ªjFŒšÝªToJ™È÷KY×ËT„£,h9·1@àt"uOSïÀæ…«¹yãNÖBÐÍ ZÖ»6k”Þt·—ôͪ¨¸ÐFQç˜uÔ¥Ò¼»å%FB½jCÒ¾¥~=“ºA¸‡ÐEkûQË[ÙÓžGT?B÷Lo·4´§‹b?ò1Í ¡ 6­Û’ÙžÎuÁŒñ|[RløÐÂ<5Þlß–\¾ ŒH80ÏüÝ’tÃ{qäL¾Ã¾-Ùïù<'žLŒûûÿh (8ShºöÔPôòH:£’=!-›?*B¹üJ‚ÜnPPï;5õýäÁN©Ð  ÇÖ9^‹Ô«Í_Aè¤)I£Qâ§#%ñ(‰¼häø¡“œÎb2 ÿí~ÊÏáª,*–÷KÁ®–R«Ëé—àýnøÔ3a‚Ò¦×m ¨Þîm/å\ Ø›Í!PíìGó2—¢KÌŸK*ðìv=ÿî€ÉÍëF$2¹)‹œY—Ëên+.ákÄG  Þš=­óЬ·íY”¦aêRbÛNˆ7šxøHÜÄuâÈO’Óóõ¶m•ç5¬ú®öåó?¿|ùüï+ìU-$æxÓÊE‹w¼F¿õ/EúK’IèÍâ–“tDÎ&Ñè4 ƒQø„Ì’øtæìqÉ4LŸü–÷ç0¸ùÕÙIUd‚·|.2^»C˜qÃ?2ÑðBŸÃ¸N˜³¢˜¹]“8 ˆ§e öÂJ=àkqK¢èÒ)Å;Ú\­„ $Ž°ÿgúVƒƒ"äQAŸ ÊwsðtòÿÿPK! à¿dVÿppt/notesSlides/notesSlide3.xml¬VÑn;}Gâ,?ÁÃv³Ù¤ «nP64¨·Tž#×;I¼¶±\„ćÀÏñ%Œ½ÙJ Aô%qlÏøœ™939}º©Yƒ±•’9MŽ:”€äª¬ä"§o^O¢%Ö1Y2¡$ät –>>|pª3©X‚öÒf,§KçtÇ–/¡föHix6W¦fšE\öýÖ"îv:ÇqÍ*Iwöæ{5ŸWž)¾ªAºÆ‰Áb·ËJÛÖ›>Ä›6`ÑM°þ Ò¹ñ©(ý·Õ¯ €_Éõs£§úÒ„ã‹õ¥!U‰£D²CãÝÁîZø)ñ.â[æ‹ÖË6sSOY†ÜÈ&§þ­ÿD#–ÁÆÞlò›]¾|¹ç._ží¹· ‚ëG=«†Ñ¯tº-©¨J ç5[¹ŒÃR‰ I®y6Æ ½Pü%R!ó& ê•r»ÕxÉäFV[M4øź}ۇȣÑKâ¶iEy^/ü3!lþ4,Z‹9h¿'“¶d.B¥þH£{7»‘^©rK± 0E!,Ä«3·)ÐÀ'Ö,ÖMÝV¾Æ2L Ë/~`y Œ\NAFo¦”\…x^1 ¢ò:ÄB)+ãBY[»±†ÞUŽNO1÷C×:Üïõ`l ä0— tt˜×ƒÚaîw;jzODµ\Ü3T2¯Gß>á+c°T§¤Ø~ûüõqöOTöP¨j­ŒÃ<Æ>ÓF½EUΰ̀ôý6¯+³ô¹Þ~dyÉ {u»0¯«Ðë%”0Ê -u\Þ%Ò^+Ò¦ã\¬ê+l3?j5½­bWAטØÿsú~ÅŒÓJ7hæ~´;e˜ ÇggãÉÉ`%E‘D½“´ˆŠ$M¢ãtrÒï£A¯ÓÿD¯;öZ‰èöjtOÓ›BĽÕo²ó‡œ„Ô´Ã Kà…Ån¡ÃÌY™*§‹âÉqw<ðÀ{“¨÷ìÉI4š÷£I?íõÆÅ`4NÏ>!dô2n ÌÑór7Ïqó—\WÜ(«æ:n†y¬Õ0ZUaž'ÝŸ‚59í¦ýA7é:¡Y#^DfA‹·Ú9Í…ùé—ëÐ<ñï¦w¶4Vû®“ß\ñÉö#aøÿÿPK!˜0çíYÿppt/notesSlides/notesSlide2.xml¬VÍn7¾È;<¥‡õJZýyáU U¬Â@êQrhîHÚ–K²$¥H äAÚ—Ë“tÈݵSG‰Ä‰"9Ãï›™oF/ö• ;0¶T2£Ý³% ¹*J¹Îè»·óhL‰uLL( =€¥/&Ï~¹Ð©T,A{iS–Ñs:cË7P1{¦4H<[)S1‡?Í:. {~+÷:a\±RÒÆÞœb¯V«’ÃKÅ·HW;1 ˜CìvSjÛzÓ§xÓ,º Öÿƒ4An|! ÿmõ[àWr÷›Ñ }cÂñõîƲÀˆQ"Y…¡qsÐ\ ?%^ÃEüÀ|Ýzbé~eªÉK‘ÙgÃðŸhÄRØ;ÂëM~¿Ë7¯Üå›Ë#·ãöDp÷¨gU3úšN¯¥³eäªbk 7‚qØ(Q€!Ý;žµ1Cg¯ÿÓ©yõF¹f5Û0¹†©ÕÀÃV ~½kßö!òhô†¸ƒÆ@ZQ\UkÿL›? ‹ÖÀbêÚƷÉ$-™ëP©_Òè=Nãq¤·ª8P¬LQËwñêÔís4ð‰õ†K…u w€¯±ÓÂRä‹X^#—QÑ»%·!ž·Ì‚(½±PŠÒ¸PÄVn&€¡€›Êq“ÅæÞaèZ‡Ç½žì퀜æòNOóz2P{"ÌãÁ`'BM‰¨–ë'†JV¥òüó§øÖìEÄÕ))Ÿ?ýûkúSTŽP(+­ŒÃ¼Ä†¾ÔFýª\b›éûÿrU®·–½3äúðmÅ 3ìÍü«B¯—PÂ(ƒ¶Ôqù˜Hû­HëŽs½­n±Í|©Õä)´Š]]cbÿÎè_[f˜VºA3O£Ý•(ÂTø0»¼œÍGãqÔÍónÔ%y”w“n4Læ£Á ŸŽûÁGz×ñ°×JDwT£GòØ»/D|Ñ[}#;ßÉIHM;Ü°^Yì:Ìœ­)3ú!Ïχ½ÙØïÏ£þËóQ4Ñ|ôû³|<%—²îöSn ÌÑ«¢™ç¸ùÕ ®Jn”U+wÆU×Ã<Öê=­Ê0Ï»æOÁŽ‰Œ&Ép˜ŒÏG£óf Ê0 Z´H¡Ó\˜ß™~½ Íÿ~`zgaKcµ7üþŠO¶ “ÿÿÿPK!LžIN°ppt/notesSlides/notesSlide1.xml¬VÁn1½#ñ–OpØn¶Ù¤aÕeCƒ*A©=G®w’,xmc;!¡ªÄ‡ÀÏñ%Œ½Ù¶”@ƒÔKâØžñ{3ofrür] ²cK%û49hQ’«¢”ó>½ø0Žz”XÇdÁ„’Ч°ôåàé“cIåÀ´—6c}ºpNgqlù*f”‰g3e*æð§™Ç…a_Ðo%âÃV«W¬”tkoö±W³YÉá•âË ¤«Ì!v»(µm¼é}¼iÝëß ŸˆÂ[ýÁø•\½6z¢ÏM8>[R1J$«004Þl¯…Ÿ¯á"¾g>o<±l=3Õà˜eȬûÿñŸhÄ2X;ÂëM~»ËïvÜå‹“·ãæDpó¨gU3ú“ÎaCg"ÊÈiÅæ@Îã°P¢C’žµ1Cgoÿd‰Tȼˆz¯Üv5Z09‡¡ÕÀÃV ~¶jÞö!òhô‚¸Æ@ZQœVsÿL›? ‹ÆÀbêÚÆßÉ´2gA©wi>Lãa¤—ªØPT¦(„åŸxuæÖ9øÄzÃ@‚eº‰ÛÀ×X†iaòÅ”—ÀÈõ)ÈèbBÉeˆç%³ J_‡(”¢4.È‚ØÊ0,à­rÜ`rŒ¹wºÆán¯{ûc+ û¹üO Ãý¼î Ôî s·C0؉°¦wDTËù#C%³RyöóÛw¾4{±¡ê”›Ÿß~<ÏHYieöÌ)và©6ê#–ÑûHß°§³r¾40MÜ}Þ ‹sfØûûJº‘xÐê¶Ñ&.ªª´©ªºEœ-«Kì w‹«ýÅ…m]c&¾öéç%3LSkAäSl3Q„6~5:9z½(Éó$JÚy”'í$ê¶ÇGN>쥭Î5½iQØ%¢ÛYT;´“Ü*_ôVÉÎ?rRÓL#”À‹å­ÃXš²O¯òüE÷pÔóÀÓq”¾zq ÇÝN4î´Ót”÷†£öÉ5BÖIšqaðÛŒ› ͪäFY5s\Uq=}c­¾€Ñª 8im§øŠ ¬›nš¶;I·Ó$Q†æÝ E Í`å¼eúÝ*t;ü¿€é…-j߶ÞÛ+>Ù¾‡~ÿÿPK!™ö™®Õ¿*ppt/notesSlides/_rels/notesSlide2.xml.rels¬ÁjÃ0 †ïƒ½ƒÑ}V’ãN/cÐÃ.£{c+‰ibK-ëÛÏP vÙIüúô¡Ýþ{™Õ… ‡ ´ºEÑ%âhàëøþôŠÅFoçÉÀ•öýãÃî“f+u‰§YUJd“H~Ed7ÑbY§L±N†T+5–³u';vMóŒeÍ€~ÃTo |êxÍõòßì4 ÁÑ[rç…¢Ü9<OhËHb@ë[‡o¥ÓUð¾GûŸ1 ñ‡e¡²±YõW¡ý5ÃÍÛûÿÿPK!îÄÝ¡¯ "ppt/slideLayouts/slideLayout11.xml´WmoÛ6þ>`ÿÐ>+²^,ÉBìÂr¢a@šµ»ï¬DÇD)Q#i×î0 kû9ý%=R¢Ó8.æ,`ȶt|x÷$Aùƒžu¬FpàÃÇÓ\ЫϫÊЪRp®î÷ÏdÒkuY*Ñ óÇ ØÁjó/ ï%Úœ—‘Ø22g´"èv]8àexŽ“fJ€>Ji?gNÛ«¤(â"¸v‹(†´E; à’û¹?H“0ϧ×û´•:ò¼;5[¿~ùû—¯_þ9C®š³ÚÎp&ÜH8ó[3Ú­…úËóQÌÒ< 7º%î´ˆ‡n1„Af–§ÓYÀ?ÊJAÌÀû[ÕÞpóÙ°\ÓRpÉ—ê¢äµ×MÝ^Ë?ÑrjoÐOï Ç] U9 ý(5c’qÍôë,D ‡e3+0ñ·wh>8ƒ×Hÿ™¹Õ‹d¸6}4Ñ¡ÛÉ7ÿÿPK!îT ‰ËÐ "ppt/slideLayouts/slideLayout10.xml¬VÑnÛ6}° ´gE¶,ËŽ»°œh&Áìî¥è˜(%jíÚô·¶Ïé—ì’Ò9u§1`È6uïá½ç^Þ«7»B’-×µPåÄë_ô<ÂK¦rQ>N¼wËÌ{¤6´Ì©T%Ÿx{^{o¦?ÿtU%µÌoé^m FY'tâ­©’ ¨Ùš´¾P/ñn¥tA þêÇ ×ô#° „½^T”^ë¯OñW«•`üZ±MÁKÓ€h.©AüõZTu‡V‚Vi^Æy†dö²1f¹óˆ³Ó[¬ô½)Rg ™“’XX #9Aä F%YòqfuµÔœ[‡rû«®ÕƒvÞwÛMDnÑZ/h_´fîo 3üž¹?vH4Ù­t1½¢ X!»‰‡âííN4A„5‹ìë*[ß±eë›#ÖA·"xÚu¯šŒ¾M'ìÒiHé?eÕ˜R¸Þ*ö¡&¥Bž6ý&=v·íÀlξZ“¦ÆòÛÚ5/} NYf—ª|oo·HY›…ÙKîAØ48 _RÛá¼ôß-Ðá…™KNqZòÌt.û@Œ"<†¼¥µáš¸`pyv ŠÓBò2 šþþ ÙæG쌠»ñ³¡ðûD:"zŠoU†]U2¥¬.þ_˜\'½¶.+£›Âü¹¡;tµù]úŽ—‘¸cd!EÎÉݦxÿŒ—á93 RãäçÌm{=ʲ8 oü,ŠÑ¶—Qè_†x¤ý´ßi:»yjÛÚf^"ºS»õËç~ùòùß3ôª»R»Y wÂm«¹r#ÐF œ¿4½ŒÃù8EäQæG×—#–ÅC?¢hžŽgóO?J˜æn ü-oS,~3L‚iU«•¹`ªš©4¨ÔG®+%Ü`ÚïµÓí–⺠ãh0ŽF½ÐµâE”N\ºh±d§J6“ú-­î·Pš`ŽFÿÏÝR…ÉÙN&6÷nŸþÿÿPK!#•îƒ/!ppt/slideLayouts/slideLayout9.xml¬Xmnã6ý_ wÔߎ%ê[H²ˆœ¨(M‚:{F¢caõU‰öÚ- ìµÚãìIúHI¶”x»Ž£ p™|œy3ó†äù‡M–*kVÕI‘_¨ú™¦*,Š8ÉŸ/ÔOáÄU•šÓ<¦i‘³ uËjõÃåÏ?—~Æ·t[¬¸Œ¼öé…ºä¼ô§Ó:Z²ŒÖgEÉr|·(ªŒrü[=OãŠ~v–N‰¦ÙÓŒ&¹ÚίŽ™_,IÄ®‹h•±œ7 K)‡ýõ2)ë­<­¬X 9{hß–ð¶L¢ÇªÈaÕ/tõžGó4VršáÅCñUÅ”/ _*3Z ;䘺|¬£óõ¯U9/*9õnýP)I, ZuÚ~Ñ“ÿ憇é‹éÏõ7‹*»<§>Q6*·Ÿ˜D}¶áJÔ¼Œöo£åý±ÑòæÀèi·,Ø-Š˜—G¯Ý!; O™¢ï¼j†RL½-¢Ïµ’ðS¸ß¸Ý­;0á³€/—JC?Pí¸æKÉG7¾–œv†î˜Ð5Ç2CòA,[3È V âé® Â7†Fˆ-ô]n KŸo‚"Þ JŸð‘£y´,©O ÑiÍç|›"ÎÔOש‹š>£”Rdõc¶ø¯ê?á°®aɧÎóÝxÏ=PL}LM©¨D–O>ÍQ‰Ÿ¥Œ¾u‰_ÎÒ$ú¬ðBaq•´æ¬R$q¨[X&й\CB²<~ Fõ‘E,¨•Apç3›p?è yX)زHcAÆHT ŠrA.w sZ"Ävu£ ZWƒ< ºg"Yd¶u)%hr²#¥KYfý¨uÑÏhu+«1ÉcH‹x¡|ZÝA?å¬~N¸È‰†ûv¾‹G"©"¶NL$ƒg÷ñH‹gìñ,BLª~žÙÇ -ž¹Çs\ªÿ(P ´€vÐÐl 8ÁBÒ:=@ËvLûØ \(- Ût‰ëhÞ) ”ÐÛÍõ< Õùö ”Ã’4®t€¾F:E9öuCV)šl×NjB®¡—ÐÝ%M BHˆT$ÙB¤¢·Î¥»Bé_tÕA/qmb¹­ðÔ“xoè%ãHÈÈ âô ôý2У÷ë‡Õ·nùà ¼Äc€7‚v ðFŽÞ÷•CšÚn×"ëôͨ=¹·©››S60V§B×”³ ™¢O½W…bþJƒô¦ í9(BrÕÿÝmHݛĎ!â(ñ6.ah†Î$0¬«‰éî$pˆ3Ñ [ ®f®9³í¿ÕvWÃUžd,Lžqr¹_qU4cÂaâ¼…_ÝÞóÄìq{šÓ¢ÛÙ~w°ÆˆË‚WM`þXÑ +´ýAÿÁó-±—§cdž&1SîVÙÓ ^ì1xÁ‘ЩùAï| 5»´½vÂÐÉÍ$4m¤­g’‰Gð讹ŽW7»´­…ç9¬;6[¿}ýç—o_ÿ!Wå9 ;ÎC}nkœ¨JyÊ^U ê/<›ÌÜ–›áļöœÉUh[“Ð2Ls¸W3Ž`ŽnúQÅä}Ãoq{ï—¯î*²$ªŠºXð³¨È¦Í¥Ç´,¾°ª,yï¡kíåÉšBX ÝÒLbàGn¯¥mò0×Y Ä­…”´´úHËûµTa\Ó ÿgòU‰‹ÄQ ݾw=—ÿÿÿPK!ÕÑ’ñ¾7,ppt/slideLayouts/_rels/slideLayout7.xml.rels„Á Â0Dï‚ÿönÒz‘¦^DðàEô–dÛÛ$d£èß›cÁãì0ovšýkÅ“»à5Ô²AÞë|¯áv=®¶ 8£·8OÞÄ°o—‹æB#æâÁE…âYÃsÜ)Åf  Y†H¾8]Hæ"S¯"š;ö¤ÖUµQi΀ö‹)NVC:ÙÄõKóvè:gèÌc"ŸT(¥3r¦T°˜zʤœßy.jYÞÕ6êknûÿÿPK!+ÆÆáFÌ!ppt/notesMasters/notesMaster1.xmlìYënÛ6þ?`ï h?×–u±bÄ)b'n¤mP§@K´-„ºŒ¤Ó¤E¾Öö8}’}‡’,;I[»Í†n5Ø4/‡<¿sáéáÓ›TX×\ª$϶ó¤c[<‹ò8ÉæûÍå¸Ú–Ò,‹™È3>°o¹²ŸýúËaÑÏrÍÕ ¦4—¤dªÏöBë¢ßn«hÁS¦žäÏ06ËeÊ4~Êy;–ì-¤§¢Ýít‚vÊ’Ì®ÖËmÖç³Yñ“0»]oÕV›’V¥F÷ÕéÖê<ç,A.‹ø"Ô6Ëu€±8Ï£+ee9”&,J]N-™ ½Š…¥o À´ˆ%˜ùn`ÿ±d¬–”ópÊlµT¬k¾ŒP÷ ç„€G8y~5‚›Õ…TúÏS‹[òH&°ës¥éج_O1×_î^ôõÍ0oé6¦øÆ¥Ãè°~‘Ëw¶%Î25°ÏÃÖÚü0›Û–\™nŒh1ÊÁ¹êŽ…Ò}+@1Ö×ÂÒsµ0ç‹ùì5º1§ÑªšiŽ½.÷ Údñ“Œ– Fþ€g­7“ ÌʵVh–\ø<#Üš'Ló >tIä÷ò!Öve›;3Á C/pp¾Æ6j‹ù?òA~+f"6®êýÐëŸtF½ÖØóOZ^§×kwƒÓÖqà†à°ï¹'îÙjŒëÖIÊÇÉ|)ù«ei.ò©,•ê‘à |­­<8wü9•6ÅŸ™^Í̉Hbn¥l¾IP÷ë…ëzÞÉç£Ì…«Îa;o¦D|–Î+{0.Œ|žiÔnð3¾,„§òK—„>9° ¿ï;žë×^Íõºïsk ±œa6™õ–|J2énTi”~+l¢#bÀ•±ÎY¸\‘=ÿ_i±,‚ÏØ‘6!{WŽÓ(óø=¿f×KÊ—6Ÿ÷u^áT À—!…“ÍHXúACÚXTQ‡Ü çâß=ya@ept¯"Ú*9hBß›K¦øˆè·r7°4ÖßÆ+D]Y:·xœh«Ê5 EñW5ΊŒ;0õ–&¿ÁnÛn9áQžÅ–à×\l!ÞøÄ_.¹½të¤ó¥Ô‹­olbñÉìAé¾µsØñfBë?†Ïà6ÚÒŒ ;™qBXsIaü:Y¹ìi©Lí°Éz~ÈL·WS¥Ì'^.ÓéÂAä ýg wâÌz ü32çûsâÑééhÜ Ã–3:-¯ç[CÇuZ;îùþð8ô:þ*'V”hf¸¼m#À§þöéã_óÿæD´hjð ç ™uaJK™ ì÷ÃáAÐ…t|oÜòNÜ¿5ö]Ï Ãã‘{ú/¯In*'gqUÁA罪KšD2WùL?‰ò´]–oÚEþ–Ë"OLÇéTe SDAêÑs|€‘•à¼8eýmN‹®º2 ù‚ê.xçj$ßú­ø ­é¼K}(Dè´â+´X¡ØƒU£îÁxÙ³šãÖ=x–CP¬jÔ=~݃¯ êD‹…H²+€A_¶5ËÅó²£n•.ÀÑî=ÜS&Ï)3Y½à-<ß/Ùt‚×»©`Hj“¼XœgC‰ 3UÁ²ê'¦Ð3¥¶‹eV¾CˆmwëÖ—Tù£šo¤ïwÊ[×\ÉYfWóÚ›¡È3°O³–Ð4A˜ÝଈÔHU²ËšÜiUž0ž¾K9[ MUšÙã#P¹ >5Iê ÐÏË¥ÂÇkðqàbzÊì"T*€ü5€Ânh ¡{€•   ¨Û A =ƒàw•  Þ@=Ï¥ ²71A¨T… @„Ž)§ìMŒP©:X(ð{{'mB;¡bràõ|‘^xÍÿÁý ÿÿPK!¹îs–°ppt/theme/theme1.xmlìYOoÛ6¿Øw toc'vuŠØ±›­MÄn‡i‰–XS¢@ÒI}Úã€úa—»í0l+лtŸ&[‡­úöHJ²ËHÒ۰ŇD"|ÿßã#uýÆ£˜¡C"$åIÛ«_­yˆ$>h¶½{Ãþ• I…“3ž¶7#Ò»±õþ{×ñ¦ŠHL¬Oä&n{‘RéæÊŠôaË«<% ̹ˆ±‚W®ݘ­¬Öjë+1¦‰‡Ù»ã1õ j’ÞVN¼Çà5QRøL 4iâ¬0Ø`R×9“]&Ð!fmøühH)1,L´½šùy+[×Wðf¶ˆ©%kKëúæ—­Ë“UÃS„£‚i½ßh]Û)èS‹¸^¯×íÕ z€}4µ²”i6úõNN³²‹´»µf­áâKô×dnu:f+“Å5 ûØXÀoÔÖÛ«Þ€,¾¹€ot¶»Ýuo@¿¾€ï_k­7\¼EŒ&“´vh¿ŸQ/ cÎv+áߨeð9 ¢¡ˆ.Íb̵,Öbü‹>4aE¤f)c¢¸‹ ªàM‚K3vÈ— Cš’¾ ©j{¦2bNïÍËïß¼|ŽÞ¼|vüøÅñ㟎Ÿ<9~ü£¥å,ÜÅIX^øúÛÏþüúcôÇóo^?ý¢/Ëø_øä—Ÿ?¯BÍ%zõå³ß^<{õÕ§¿÷´¾-ð¨ Ò˜Ht‡¡ƒnÆ0®äd$ηbaZ^±„'Xs© ßS‘ƒ¾3à Wà:ĵà}¤ xsúÐx‰©Ê\îhv+Šàç¬ÃE¥ni^%3§IXÍ\L˸Œ«xwqâø·7M¡tÒ*’݈8bî3œ(’„(¤çø„ {= Ô±ëõ—|¬ÐŠ:˜VšdHGN4ÍíÒü2«üíØfï>êpV¥õ9t‘˜U?$Ì1ãM½Ü£¡#Ò<@ôÌTTøò&áNüflŒ‰)5P×rÓä²vŸ¹vo Z™<»'*ö2ÜÉ:Ýå" ÿþ2½ƒ§É>ÌXÜ«.«ôe•öþóUzY>_|mž—c¨Ôºw²M·iÁã¥ø˜26P3FnKÓ„KØ„‚> êuæôIŠYÁ£Îd`ààBÍ$¸úˆªháøº§‰„2#J”r G3\I[ãá ì±³©$¶rH¬öx`‡×ôp~î(È©Bs¸Í­ige¶v-# º½ ³ºêÌÜêF4Sn…ÊÚÄæ€&/TƒÁšÐÝ è‰ÀÊëpþ׬áàƒ ´Ý­r·/\¤‹d„’ùHë½è£ºqR+ Šh=l0èCä)V+qki²ïÀí,N*³k,a—{ï]¼”GðÜK@íd:²¤œœ,AGm¯Õ\mzÈÇiÛÙã¼.uC‰YO¾6ìOMf“åso¶rÅÜ$¨Ã5ˆµû‚ÂNH…T;XF64ÌT,Ñœ¬ü«M0ëE)PQÎ&ÅÚÃ?&ØÑu-‰¯ÊÎ.hÛÙ׬”ò©"bGhĦâƒûu¨‚>•põa*‚~{:mm3åç,éÊ·cgÇ1K#œ•[¢y&[¸)H… æ­$èV)»Qîüª˜”¿ UÊaü?SEï'p ±høpM,0Ò™Òö¸P‡*”FÔï hLí€h»^˜† ‚Ëjó_Cýß朥aÒN“ꀆHPØT$Ù‡²d¢ïbõlï²$YFÈDTI\™Z±Gä°¡®ëzo÷P¡nªIV îdü¹ïYBÝä”óÍ©dÅÞksàïî|l2ƒRn6 MnÿBÄ¢=˜ïªv½Yžï½eEôļÍjäYÌJ[A+Kû·áœ[­­X ¯6sáÀ‹‹Ã`Ñ¥p™„ôØÿ¨ð™ýò¡7Ô!?€ÚŠàC†&aQ}Å6HH;8‚ÆÉÚ`Ò¤¬i³ÖI[-߬/¸Ó-øž0¶–ì,þ>§±‹æÌeçäâE;³°ck;¶ÔÔàÙ“) Cãü cc>™•¿jñÑCpô|?˜2%M0Á7+¡‡˜<€ä·ÍÒ­¿ÿÿPK!´ÏX»$,ppt/notesMasters/_rels/notesMaster1.xml.rels„Á Â0Dï‚ÿönÒö "Mz¡W©Òml“D±o  ‚—…™eßÌÖÍ{žÈ C4Îr(i­r½±šÃ½»N@b’¶—“³ÈaÁØïêN2å£8I¦ØÈaLÉŸ‹jÄYFê<Ú¼\˜eÊ2hæ¥zH¬*Š# ß &i{¡íK Ýâsò¶£ðâÔsF›~D°”{aÊ 1q tuÖYÑܘ¨Ùæ7ñÿÿPK !;Q§¸TTdocProps/thumbnail.jpegÿØÿàJFIF``ÿÛCÿÛCÿÀ«"ÿÄ ÿĵ}!1AQa"q2‘¡#B±ÁRÑð$3br‚ %&'()*456789:CDEFGHIJSTUVWXYZcdefghijstuvwxyzƒ„…†‡ˆ‰Š’“”•–—˜™š¢£¤¥¦§¨©ª²³´µ¶·¸¹ºÂÃÄÅÆÇÈÉÊÒÓÔÕÖ×ØÙÚáâãäåæçèéêñòóôõö÷øùúÿÄ ÿĵw!1AQaq"2B‘¡±Á #3RðbrÑ $4á%ñ&'()*56789:CDEFGHIJSTUVWXYZcdefghijstuvwxyz‚ƒ„…†‡ˆ‰Š’“”•–—˜™š¢£¤¥¦§¨©ª²³´µ¶·¸¹ºÂÃÄÅÆÇÈÉÊÒÓÔÕÖ×ØÙÚâãäåæçèéêòóôõö÷øùúÿÚ ?þþ(¢Šá~%üPøið_Àú÷Äߌ_< ðŸá·…a´¸ñGĉ~-Ð< à Ûßê6zEŒú÷‹ xvügø¥ðëá„îu[m ÛÅümáŸøvã[¼·¼¼³ÑàÖüW©é:lº­Ý¦¨][iñܵÜöö7“Å Em;'€ÿÃÃÿ`ú>_Øóÿgà¯ÿ6Õ½<.&´yéa«Õ…Úæ§F¤ãuk®hÅ««««õFSÄP§.Z•©B[òΤ#+=¤ÓÔàÿáì_ðK/úIgìÿ‰‘û:ÿóÆ£þÅÿ²ÿ¤–~Àø™³¯ÿkZü¼É^×W¶×]Ñ¥:ÔªßÙU§S–ÜÞÎq¯{_•»^Î×Þϱðü=‹þ eÿI,ý€?ñ2?g_þxÔÃØ¿à–_ô’ÏØÿ#öuÿç_ÑYÃØ¿à–_ô’ÏØÿ#öuÿçGü=‹þ eÿI,ý€?ñ2?g_þxÕ÷ýðü=‹þ eÿI,ý€?ñ2?g_þxÔÃØ¿à–_ô’ÏØÿ#öuÿç_ÖV»®èžÑ5x›XÒ¼;áÏéZ†»âkº…¦‘¢hZ&‘i6¡ªëÆ«¨Moa¦iZe…¼÷º†¡{<–VMss4pÆî­&ÚI6Û²I]¶öIul²mè–­½KvÙð¯ü=‹þ eÿI,ý€?ñ2?g_þxÔÃØ¿à–_ô’ÏØÿ#öuÿç]çüøSûHüø‰ãbßGÓ®u}^}/Â~ñž±¯jéZM•æ§©Kia2XéÖ—7·-´ÊŸ\×À¶GüœWüwþÏÿâ7þºËþ Y_×9°QEQEðü³þM×áÏýŸÿüwÿ^›û×ßõðü³þM×áÏýŸÿüwÿ^›û×ßôQEQ_5Ùþкþ».¹/ƒ?gŽ^7ÐtOøßÁ+âUýôÍVÖ>øÇ\ð‰¤Ó,üeñû¾&[oxsW²¶›Uðþ—-äVËy Öx%“ؼâoÅšMÆ£¯|9ñ—ÃÈul£Ð|q}ðûPÕ®í£¶´5{y¾xï℺uÄ·3YEÞµk«-Í…ÛÏ¥Ãföw½ØŒ»„Œ¥_êÑp—$éG©‰§;Ù¦–&xšsƒN5#:Q•)'Š-4rPÆÐÄIF·’”y£Qá1p¡8ÚêPÄT¡Œ“N…Fª&œ“¹ÙQ_š7¿ðS‡zÄo‰ßuÿƒŸ|Ï…¾3øá]{Æ^†Z·ƒ¿ÃÛßÙM©í¯ˆžñ§Ú5+ˆ^±þβðV£ ž¥âhÐj—šF‘¯kšg¢ÁcgoO‘ðëáßÅ߈>*¼ðÝ/Ã>Õÿg«‹»ù|1w¨AªYÇ~~=e¶•ö;ÕôßÚÝÞ|2ñ%¬×Z7„‡ Ô§ŠÇà0¾æ&Œq'NXŒM8WJ3…U*2© ÁÉ®xÝQÍ°8Œ5^u±zò¯ u0ø4ð<®ü3ð™ðºÎÚHôvËÅÿü ðó âË]ì o é_<[ª^éw'TƒI´š½¾‘öïü‹ã_‹þ)þÏ toüø§ðzþÛÚ—c¬xò_Üi)‰?gÚeTé¾ñ.³íìy”߶‡&½á‹S·‡Å·wþeœ_Mñ¯þ ÕâÛØ5ÿ~Ͼ/Ñusw£G>à I¤xV-HðÌ^šÈYèß´ƒ–ðjQÚÚjð\‹-7Äöž;7þ5ñ_Œ¾#hZ„ß +ö>¡eœ54”½¥,v#%—ÑÃæ³æ¦°U¨Ñœ¨f¸zœ>2’©F…ju½•*ÐúÅ ’„ååÃyŸÒ©˜ûZÜ9€ÁÁæ¹…|’³ÄãóŠ±4]\‡0­…Åeî”êSÅV¥^—´©FØLÔ½Êÿþ ëðwÃÞ&ð¼výµþ h¿ØÞ>*MCàOÇYÂA{§][xÊ8ïôÏÙ—Å:ž›¡kƒL¾ÒàÒì¼Mý§¢]kqG®Ïá½!|}©ðËþ M¦Þü%ðŸŽþ)è?,µ}OÄ^9ƒÄ–žÐ|kcu¢ø{@¼KO¼? oÿgü[–û\ƒí†™zþû6´ðŧͧxjÒé<@Ÿ$|#øƒÿøðw…¼'¾|QñïÄ=Çšþ±¨ø£Pð²ÏáÍsÁ¬Ð?†4=oÁŸ´~…¥jÚ›C9–[i4&)¯-_]Ó¼u¥éwÚ‰<öšñŸÀŸxçIñÀOê~Ðçð½”^*Ò/t; YOâôÔ5Gº¾Ò4;OxúÊÎÕô™4{[‰´ÛÿéZ†¡iw§ø/Ã\7÷^=¯_€†gœÐúÄ¡|Ò®]IaèÇ’½nL$a˜CÙEJ2¦êÔ¥*±©,=)ƵBTÿ>–?ƒ°x<>mS álSÁ?g ‡ žÖ©ŽÄÚ­(:Øêµr*ÔñRJ¤§N´iU£ EZr£R”¡W[öŽý‰>? ø£¢üý—¿k?x5|/­iÞ¿ÖþüO¼×¼C3xnH&¼[H>xj{í=Q§m?GmÝÙC$2^j“Fo®½êÿ4߈£?¼v ƒ|N áAÑ/¹;C6SµIÇ@OýÿÿÃFüaÿ£ý¬ÿð±ý…ú4«óÏq2Ë¿ÕºXÚ¸œd,ÉB®(̱|/Œçˆž8Új¥FÔ­j âpƒŽþ‹ú-d8³Ç¬†–C“R£še^Û žñÏd4áíèc¥F–]Oˆó ƒˆ¡Btç:o0œvñX…V§5_¬è¯“?á£~0ÿуþÖøXþ¿ýTïÚ_ö‰ø‰ð3]ø;¢øöoø‘ñÞ‰ºÿ‰ôŸøƒÁVÚüºÂ};Aðëê¶Zÿ%ð߃|qª%ž·«Ig¥ZA’“Ëlš½Æ—ý¯­Ùiž×­žåø|<ñUÖ>b08Vêdù¼'*ù–.– teUª©âkR§R¥*s§†ŒÕ\TèÑN¢þ®ÂxeÅy†u–pö\ø[2ͳzÆ'C-ãþÌ({,‹-­›æ/Áñ5|¿,œp+TÁÒ̱XJ¹­jrÁåPÆãWÕϬh¯ËþÝŸ´ÿ„!RûeôoñfTpøˆå|3:¬ž¶{Bt¼Fðê´¥—áé¹U”°ôxª¦*•hÖK¨V¡N£ÄÔ¥:ÔªOôú¾Ný½tmcÄ°Çí¡áïi:–½¯ëß²wí£hzcuªkαª|ñŽ™¥iZeŒSÞê:–£{<v66pMuwu4VöñI,ˆ‡Ö>(üFñÃÿì?øDþüZøáý­ý§öÿøUÚÏÀ­'þ°gý—ûsþWÆŸ„hþÚûmÏögü#_ðù_Ù:‡öÏöO™¥iþ\þÞßµÅGöuýªþjß°·í9àÝÆ?±í[«jüEªüÕü1à×ÓþxºÙÄ× ~4|BÑ,4Éâ–Y#KÛøÆþhZøÄGyyeïRÍ°xLÓB²ÆÂsÌpxTŽUšWÃ:ØšôcF?Z¡„ž§*Œ¥íÔ)Ëš5' òþu—ø{ÄœC‘æ®W>­†Ãd¹Þo_ ‰ãÎË3zy~K†ÅVÌk<‡3â,&x§JŽµj8u–¼N6’§WCN½ Tþr|3ûþÔwž$ðý§‰?f?ÚGMðíÖ·¥[ëÚŠüø¯Xh³ßÁ©z²Ù|?ñ äfÖŧœIi k—(St>§([)¿Eü+ÿ«ð |~þÄÒ?hû¯…Ó|-uð‚ëÄžñŸÂŸøŽM^ö =têöÿ~h6~(ŸAXuã£xOLÓn®4ãe<·–—²G¦ÝüKðŸâ¿ìv¿ ¼5àOŽ¿õíK]ðÔ:’O|=ðý­¿Š¼C¨x¯PŽm6çQñS|RðÇÛ/ë> ñƒ¼=iðÛÃZ>sáyüã›?ìäñ±o{}ûJxÆøøW[mFx4¯jŸ®ìäÕ£·†ò(ô¤šÿú§S:«V¥:u1øiÑÂæP§S•F®ÍŠÁ•GÏš©ýsÙáå,½JxhS¡‹Å¼D¥?f©—ù=ÃaiÖ­G&Ì!‰ÅåêÒÍ8Ž¦1À¸á3/m‡‚¥Ã’¤ðxº_Ú·¡‹©SƒËþ©S§ˆ^«ö’ýƒüSàýkGÑÿg¿µ·ÄU/_ÅZî­ðƒâµö‹kv‰c ¾• Iðá…þ«7I©Üµ„vº¥¬ÖQÁ¤iæÕîõ?¬ÿàŒß³ÿÇŸ…Ÿ·&¯â_‰ß¾.ü9ðåÏì£ñ‹C¶×üyðÛÆ^Ñ.5»Ï‹ß³Eý¦«â O±—Uº±ÒµKÛm>9Úî{M6þæ(Z;‡ó—öŸñ×ì›ã]/Á û:|7ñ'€üI¦Ü_ÛxÞçRðõdž´oG·ðÿ…4¿ H¸øÙñ~k+«;Ý+Ä7Úœ—··zΫ>¶/u¯ë×ÊÒ/׿ðB¿ù?ý{þÌóã_þ®¯Ùb¼\åfOs­W¯'e™`]Æ£Ué{ÕeKV„[ºiÆœ—*´—´æ‘ö|,‰xÇ‘¬· ƒ¦ªbq“ÃË"ÍV+$¢žSç…*uòl..£º›—5xF3štT0Ñ¥‡‡ô ûdÉÅÁ'ìÿþ#묿ॕ÷ý|ûdÉÅÁ'ìÿþ#묿ॕ÷ý<Û¡EPEPÀðRÏù7_‡?öÿðIßýzoìo_×ÀðRÏù7_‡?öÿðIßýzoìo_ÐEPÏ?³ü“oÿÙÃ~×_úÕÿkèjùçöaÿ’mâ_û8oÚëÿZ¿ãM} ^žuÿ#œÛþÆxÿýJªpe_ò+Ëìÿ¨ôÊzŽ§ë}þ‘«ØYêšV©gu§jzf£köŸ¨é÷Ð=µí…ý•ÊKmygym,¶÷V·IÄxVÇ@Ö5¸´ïøšZx*ÃÁz\×–¯;ZºÜZCaú!ÿóüCÿ£ßðgþ"F¹ÿÑ]^ñgþ»â„ž0ø#àíWö¿°Ö®þ6|@ŸÀzuî‡ûø¦úÏ]iµ}b[_ÚŽæ$¶[‹;8&·–kG‡F“]ñ9•´Ï êË_и~ à|ÃW긬UL^&†>U#B9ízRSÌqõ#Nš§N5%ìg‰©VœcYÊã.nTÿŠ'áÇŒ8 •z4pxJ™|(^ü2[5ñ>xÂç^¹Öo~3üK7ÆÌü5·ÓàÓ"Ò¬Zk©5ôT¶›À蛃¿ÕœÏ(ɱsSÄQ‚£BT39)TÕà’«‹§%ÝPïR1”£)»Ôœ¥/±àÿüL¥âCÅ\W‡ÁT¥€x˜bq41E9ÆŒð8úT—Õ²øÐGØ¥ªnq§h_ÙÒ„côßí‘ÿ'ÿÿ³ÿøÿ®²ÿ‚–Wßõðí‘ÿ'ÿÿ³ÿøÿ®²ÿ‚–Wßõø‰ýXQEQE|ÿ,ÿ“uøsÿgÿÿÿצþÆõ÷ý|ÿ,ÿ“uøsÿgÿÿÿצþÆõ÷ýQE|óû0ÿÉ6ñ/ýœ7íuÿ­_ñ¦¾†¯žfù&Þ%ÿ³†ý®¿õ«þ4×ÐÕéç_ò9Í¿ìgÿÔª§Uÿ"¼·þÀ0úL(¢Šóð¢Š(¢Š(¢Š(¢Š(¢Š(¢Š(¢Š(¯+ø…à}[Åž-ø¯i×t6 ~*jþ8×£½–æ;›½&ÿà—Æ/†ÐÛé ¥ÌWŠë¿´[¹b½šÂÙt›]Rt»{Èm,/xÚÀ?~!x7ÁÚgìùñ2…1Ò~(ø?_×|O=Ø€Ëà?í+?é6–W~ñ΃­j—šv %Ò4ŸøjÿÃ’j¶¶wwþSÙ[Ê¿ê¿ à­–W~ðÿ‡~?|;ñµ—‚#¸ñ—Ž|M}ðËÃ1ë>)Õ´{«mkEðõž‡û#x–âÏZÑ|E4—žñmÿ„ ð—…ô ]ø×ÀŸ5KßøjßÙÊð¾Ö5kÓÌòÌhÒÇÑtqõ+R•JËê*®”£B­':´ªÖ¡Bœ*O¡ Qœçy¹ogËNXn2’Yn'ŸSq¯<ÖTiÑpjs“ÃJ… f*PR…,gV£Œa6~·Q_”wÀÿø*m—ˆ¾ø¦ûö©ðN·q«à˜¾2xNkßé~—Âz?4]OÆzô›?Øò_ê~#ñ‡­µ=#þMSÅ~“GÔînSHµÓ­u ¿ þ¯×>7 :3Žc—ã]Z˜šr† ­j“£õiSŠ©QU¡FÔ± ¥ðóWu*Ï•S*•µÃc%‰­ˆ¤ðXÜ4(Ã8VÅS§Nž!WNhÒä«R^Ò„©¿kÆ<´êáäÚ«:´h|ûdÉÅÁ'ìÿþ#묿ॕ÷ý|ûdÉÅÁ'ìÿþ#묿ॕ÷ýyÇhQEQEðü³þM×áÏýŸÿüwÿ^›û×ßõðü³þM×áÏýŸÿüwÿ^›û×ßôQ_‡†?à¬?ðRÏøkÃÞ ¹ý°ý­<_£é·z÷Š|QsiÂ_Ù‚õfñüO«øÓÅÚ¡›Uøt’kž+×õ­n[H§M°—P{ ËMÒ-¬të]ïøzOü›þ#Æøf¿dïþ‡šíÌ|2â ^aŽÅRÄåJž'‰ÄSSÄb”Ô+WH)%‚’RQ’æJM&›Ñ¾Ò €0ø,&¤sÇ:\=¸å´œ\éR„$âÞ17ÅÙ´›[¥±ýÉÑ_‘ŸðF¯ÚSã¯í;û<ü_ñOíñçâw‹|ûGë¿´OÞøcÀ¾¾ƒàçÁ/Zé×zÿ ø;Ã×Zëž8ñÅ|4X蘆žÞÞæâàZÄÃõο4Ì°²¼v+/Ä:r¯„«*5eJR•78Úî”!'tn~GíÙ>k†Ï2¬»8Á*« ™àèc°Ê´:¾ÃN5i{HFSPŸ$—4T¥g¥ÂŠ(®#Ò (¢€ (¢€ (¢€ (¢€ (¢€ (¢€ ùçãOü”ŸÙþÎÄ¿úÊ´õ7ðPÿø(íÇð§öãý£¾|&ý£µÏ‡>kŸ ´ øWGøeð_†ÒàÂ?ëÇþøÇÄ—·W¾$ñŽµrMδöööïmiimo º«|1«ÿÁHà ºþ¡ám[Zý­<_¨j^×®,üfñSøßâ>½®|lÑõÿK¢øoók0øãçÅh?„4oxnÒê? ø_G¶º:N‹§[ÜÜC-Û[,ÓÊÍóüAÁy· á)c1õ°5)VÄG ákW©QT•*µS’©†£ZRM©7ÍeËguôü⇠ñÖ;€Èã™*øÐèúÄ^Ôü-{swi«iZV»¬Ûê–h‡†-5Hï!±ü§øqÿ$óÀö&x_ÿLv5Ù×õæ#˜ÖŠx<Êž/ J„ð0ÅrÕçæ©Y¹W¤äåK–•:zB›æ©?kÍÃüËŽ;!Âãñ‘Ͳ ù´ãã+Õ©K9­–û\7,p*0ÁâU7í£R¬ñJõeŠ”cOÙ©Ëî¯ÿÁ=¾9xÌxÉá¾ð¦‰ƒþ%Að¾Ö¬>'4ž0Ön­n5]SÁVºÃmr÷WÑo´›q«i_i¶ÓµÍjÎxSEÑ5 ï:Οþ<| ñ/ìõã†ø{ã sÂúLjíìÿQ‹ÂÒø†{m+λ¼¶·´½›_ðï‡\ÞÏ¢jUœWqÛÛ]ÛÛÞËkªG}§Yò^ø«ñCÂ~Õ<á_‰=ðÏ„u»Ïík¾ñ‡ˆto êú‡ÙÒÓíÚ¦‡§j6ÚeýçÙbŽÛíWv²ÏöxÒþZ*Ž Œ= Ú8©OÃÕÂFQötiá*U‡Ô°Ô¤êÔu²’Æɵ?h§ ð¦8SP91¸Îž]J–&ÆÐÌçJXÅ×Ì\=ßÚXšðxl†¬Ý_ZÑü?bú¦½ªéº&™öVÒê:½õ®›cÎ¥{o¦éÖïwy,6é=þ£wiaeH$º½º·µdžhão ÿ†aømÿC/í ÿ‰uûWÿó鮟ãçÁ_ ~Ñ_ð„âyžëNÐ>x[Âv:{Kwan‹¢êz®—}êGÃדžŠQUãN 9,ÝIQ•¹b%TãɈŒ)º*¬§*3U¢ùÔ¨GÎX¼åª û"„g:U']ÿjEÒ£R5`¡FXER·µ¢ç?iì©Æœâ©¸ÉK~¾Q^eâÿ„þñÕ—‡¬¼A¬|H¶µžÖÊü[ø¡ð¢kÁs„SÍ­¯Â_x×[—þ%Ð=¢êv×0iO-èÑàÓãÔ/£¸ñ¯~Æ¿ ¼wá{Â~0ý¡¬-uûÓç¼µíⶎI#v•4o|Nñ'…¯äPŸº‡]Ðum ñgÀØô_ë¾)Öõÿ-Οû*þÏ7Vº×ŠµKËjãS‚è,Ö×fíM—¾œ–v–¶–ðq¾ý³j/ ¿ŒfµøÏâírçÇÚ~‘¥ø®÷Ç­¦üMÔ5+þMSHŠ-Câ6Ÿâ›Ý)ì5 ì3èóØ\}¡ •åf··1ÿJå1ÇÇ Èÿ²ªa*SŽEFxèV¥í+:¨Ö’¡*®8ÒŽ-â(©JRœèFb£9¿óÿe‘¾<ã%ŸÓÍ!R\I)Áå3ÂÔöt"ñ¿ÚÖÕ(Î¥J³Á}Z½”a 8‡:2u!ð?>üOø+ý‡ÿ #DÒ´OøI"žãB3ðGŠŽ§eo •ÃjvÃÂ>#×Ki&¡n¶z»Ó/ç[»[»‹>þ+oë?þ¥ÿ(ÙøÿcŸí;ÿ­cñÆ¿¿|MøñSZ|Kñ׋|}®;LÃTñwˆ5O]·y²Ãk&§usö;bávZZˆm¢THâ‰#¯Oø"—ü£gà_ýŽ´ïþµÇøß>»þ¬e_Ú ñŸÚ”~±õ8ÕŽTúž6ꊯ)Up['6¤÷åŽÇê_GÇ•¾6âìXæË?±"°¿Ú“ÃÔÇ:Ú_{ð”éáã6þÅ5%§<·=SöÈÿ“Šÿ‚NÿÙÿüFÿ×YÁK+ïúøöÈÿ“Šÿ‚NÿÙÿüFÿ×YÁK+ïúü$þ¾ (¢€ (¢€>ÿ‚–ɺü9ÿ³ÿÿ‚NÿëÓczûþ¾ÿ‚–ɺü9ÿ³ÿÿ‚NÿëÓczûþ€?̇À~<ð5‡¼c}ã? YÞÙøSö—–w~"Ò-î­.­ô‹8n-®mæ¼I`¸‚Tx¦†TY"‘YU”ÕÿÂÇø{ÿCçƒ?ð¨Ðÿù:¿ÒΊý’>.N1Œ°#äfú$¿èÉÿK_æ‡ô—eÈ2,£$…yba”åø\¾‰ST¥Z8Z1£’¦¥5 MA7)$ÞŽÁEWš{EPÏ?´÷ü“o ÙÃ~È¿úÕÿ«èjùçöžÿ’má¯û8oÙÿZ¿àµ} ^_ù`?ìg›ê.JpSÿ‘¦3þÀ2ßýHÍBŠ(¯0ï (¢€ (¢€ (¢€?„ßø*ÿŠü/ ÁKlKMwÄš‹u?Šþ ÝÃm«kv›q5«~ʳü s7—É%»Oo<+2)ŒËцß…üþÿ…ð÷þ‡ÏáQ¢òu¥|×ñÓáŽü{ñ öc×¼%â¯h'ߌZ‡Š]‡Ÿ±XÜ]8Tå«Sha©Ô•iÊJ…)7ɺÿ>øXÿè|ðgþÿ'Wö·ÿKž ¯ø&—ÀK»Y¢¹µ»ñ_í/wks‰5½Í­ÏíYñ¾{k›y£-Ö÷IÐM4rÄé$lÈÀŸÕŠ+港ŽeÄø –,°ÅÃíV1â9¹hÖ£ìù¯í¹¹¹Ý¹yy]î¾Çï 0¾fXüÇâ37ŽÀ¬©VÁSÃ*ib)WU#8b*¹;Óååq_寧À¶GüœWüwþÏÿâ7þºËþ Y_×À¶GüœWüwþÏÿâ7þºËþ Y_×ÀŸ¯…Q@Q@ÁK?äÝ~ÿÙÿÿÁ'õ鿱½}ÿ_ÁK?äÝ~ÿÙÿÿÁ'õ鿱½}ÿ@Q@<þÌ?òM¼Kÿg û]ëWüi¯¡«çŸÙ‡þI·‰ìá¿k¯ýjÿ5ô5zy×üŽsoûãÿõ*©Á•ȯ-ÿ° þ£Ó (¢¼Ã¼(¢Š(¢Šùçöžÿ’má¯û8oÙÿZ¿àµ} _<þÓßòM¼5ÿg û"ÿëWü¯¡«Ó«ÿ"lýŒóoýEÉN ò4ÆØ[ÿ©¨QEæáEPEPEPÍ¿´ýçí'càß\~Ëšw‡µOŠ>¶ñ-¿ŠítkïCðÞ÷ûJËÅÚ¦§§ê¾)ðMÞ£Š·ÊiÞñV‹â]B{¬ôû£ ÷Ëñ«ñ»þ µ¤]ø_Ã~Í_ |_â ŸGâêþðÆ‘¦ø[BÔuêX¬4«Ï~Ø•­ø“Áž"h´QàK_ÉĤѯµ]SâÀÏø‹ÃÚõ~·W…|\Õõm7Çÿ²å–ªj6~ øëâ #^´²½¹µ¶Öô˜foÚ+^‡KÕà‚XâÔ´èµÝEÖ¢²½Y­£Õ´/QH…å…¤Ñ{yF%GÛae—嘵*–)ÏB¬êÇØ啪8Ó­BµPXwR„S´kÉÍïîùy¥5 ëÃNù^šÂU…:q—ö¿´–"TjS©NµlDqUÄʲœ'„¡‡¤©¥ Š¿ÂºwÄ_ø+Bx‹áNµ­|ø??†üMªø'Møà=@ðŠ]ü8Ð$ñæ‹gñ IJøóQý±õ¯Eà7Õõ h¾ð—‰t«{­Öº”Úµö•goâ¯Õú(®\v`±´èÁeùvØÔÅOÚ`pó£R¬q2§(ѬåZ¢©O Èã…n*¬cV¤jÕ¬½Ÿ&ølÃVÄVúæ7±ÃÇØâkF­u0ñöq9âãõ„ç(NT©Î0…IV•_€?lù8¯ø$ïýŸÿÄoýu—ü²¾ÿ¯€?lù8¯ø$ïýŸÿÄoýu—ü²¾ÿ¯8í (¢€ (¢€>ÿ‚–ɺü9ÿ³ÿÿ‚NÿëÓczûþ¾ÿ‚–ɺü9ÿ³ÿÿ‚NÿëÓczûþ€ (¢€>yý˜ä›x—þÎöºÿÖ¯øÓ_CWÃ_þ?üø{áøKÇü'á_i¿´íS=þ‡­êqØjV°k´ßÅÝoJškY‚ȱj:F£a©YÉ—W–÷ŠTcôþ8|"ø—«\h^ø‰áoëštºµÎ›¡êÞÝÁ¦Asig5ô‘Fw-¼wWöp<‡%ÌKÕÅ}w–æ+1ͱO/Ƭ+Çãk,KÂ×T)âjJUogìÝ9FQ”gÍÊÔ“M¦*Ç`ž.ìf×X<-7Ab):ʤhAJ›§ÏÏÏšqåæM4ÕÑê”Wç¿Äßø(g‚þ|zñ‡À}{áÅ_ê›Á/‹< ?Ûí /ÅŸüEñmO]µñŽü ­Xÿbh ñµõÕŸ‡´ÿÜÞXøx}ˆI®júW‡î|ŽÃþ û1k"±ðŽ…á/Šú÷Šu/ê~ ²Ð4›¿7׈,í,®¬,¬áŽQ-ûjRÜϦjgO{¶øg¬Ù.•ñ©~^ëž‹Ä8Qáüç u(`+V…l-lm7MÓ“–*µ¬§Ì¢®£d¥R¥éSSªœE|ß-ÃJ¼1ºte…­…¡ˆöŠpTjcTe†ö’qQ:‘”fë7ìiAóÕœ#©úÉE|?û$þÝŸ¿ko|FðNàŸøÇ? t¯ j¾6ð÷Šõß…>"ŽÄx·[ñ¾‰§éÖš§Ãˆþ=µŸWÓ%ð=éñEÒiç@»Ôl4‹‰fÕ£Ô­,=¯Wý§?gÝVÕ4-kâÿtÍcEÔot[M»Öíâ»Óõ=6æ[;û¨˜îŠâÒê`š3ÊI)äV52lÖ–&¦ à15qc •)᩼]©ÕIÒª§…öÔçJ¢iÓ« ÊœÓN2i¢¡šeó¤«}n:nn—5y}YûHÆ3•7G²’œc8ÉÅÅ4šº?"?àá‹;=OöQýŸtÍJÒÛPÓoÿkÿ Å}§ÞÁÝìP~Ï´¥ì1ÝÚN’Aq7¶¶·q$ѺÇumop€K n¿ÉÇü+‡¿ô!ø3ÿ }ÿkú^ÿ‚Ý~ÒŸ¾4|ø?àï†_txŸÁ¶†eñ`÷ uoc?ìÛûHµk?´A Z¶ŽdÔ,í¥Õt©/l­o§O»š ãözü^Ðÿgøçá÷‚¼Cð¥|Cñsâ‰n¼Q.½ð³áLJtßxÁðíüzlZν¢øoÅz¿Ä›d¿šk;‘¨|/Òü–Z®‘õMjâ÷DÓzà*3Êxj0ͨUÀOûBµã¡R„¡ ôèÕ£R¢«ºTg Tzœ´y\d攢ßñ·Ž˜ŒncÇt!‘bêâ`¸kUÃ.Æ^5%K0̨ÕTáFªöõã>Zr¥IT®ÜZäj—ä«oøÎFšÏÁž´•íîí[oéHÖ·ö³Xß[3Åf¬Ö÷–Wwp’c¸µžky•â•Ñ«ÿ¸ø{ÿBƒ?ð—Ðÿù¿S¯ÿc_€ñ7…ô­söÌøuâ]?TѼ'}®·€¥ør÷zF«â-:éµ=/<]ñÃÚE¹ð–½¦“®\ø†çB½K]gJÕ†‹­Ÿ‚õ>Á;¢ñŸÂ_ üZñwÆ};ÀZ‰¼Eã"]Kû+áö¹àMðMâi÷®¡ñ"ããW‡¼)ç\ÎÒ\¸Ëcmr4 KÄzÌi¢Éôµxƒ%¡C^µwK…œaR¤ðx¸ÃÚMÊ<´SÃóW’öW›¡Š1Š”šŠºüÎ ñÖ#…ÂaÖ&¶+:Tig˜)ÉAIA:§”ðïñ=L«4Êp¸éä¹vcÄT°UgCËJ®',¥Ž£MÔtê8/kjœ“pæ啾³¢¾Lÿ†Óø=ÿBwígÿˆûuô9W ü`ý¤þ üÕ~h?4þÖñ§ˆ­|¤^Ýüø¹¥hÐüCÔ5ï xzÃáέ«ø&Àé>7k¿i—šÖ‡{rx#Fx5ˆRøKOÖ<7>·”x‡!u††u”Ëñ´òÕ‡Ža„uÿ´jÆœèà}Š«í>·Z¨Î–ÇÚÕj2§F­7/f^ øÅ t«O¯aB¾y¥ Dø/ˆ¡‡­—R£Ïý“ýŸö¯íÏøR¿~ Â1æÿiÛfÂKý“ýµåêØßoþÉÕ~Åóÿ?oÏÞðw‹iƘ<εJ˜Œ6!¼eŒ†:ý·ö[BµÕèÝÂTý¤aQ¸M{:Š5)Ê1àÿlù8¯ø$ïýŸÿÄoýu—ü²¾ÿ¯€?lù8¯ø$ïýŸÿÄoýu—ü²¾ÿ¯ÅOê`¢Š(¢Š(àø)gü›¯ÃŸû?ÿø$ïþ½7ö7¯¿ëàø)gü›¯ÃŸû?ÿø$ïþ½7ö7¯¿è¢Š(¢Š(¬ÝFÑü;¥ÙhžÒtÝ FÓ`[m;HÑì-tÍ.ÂÙI+oeae–°)f+G$¼šÒ¢Ý­wfÓk£jövî®íÚï¸[[ÛUtµ³µÕüì¯è»QHÀOø/χ´öjø¨i&‘¥ßø‹öÐðÞ¥â í;M³²¼×5¿foÚ^Î+ýbêÚçÔï"³‚ H®odžhía†Ýa‰—ªþ¿à²ÿ³oÇoÚoözø;á_ÙûáÍçÅx3ö‘м®xrÃÄþðä>ƒàÏÇ]jj¼YàÏÜ›m{ÆÞ‚KõŸí »–æÚÒx­nZ?ç‹þmÿ&ÿ£7ñŸþ_Ù;ÿ¢¿{ð÷=Ê°|<¨æ¶ ˆúî"^Ï¡J·³å£ o–­E>NXòÃKrÆÑÑiüã§qF{Æx|fGÃÙžcƒ†E‚¡*ø,$êQXˆã3µióArûD«Bsëï¦õløJŠû·þmÿ&ÿ£7ñŸþ_Ù;ÿ¢øu·ü›þŒßÆøydïþˆjûŸõŸ‡?è}”áÇ ÿË|ÿ«3ñŸø†^ ÿÑŸá_ò?7þ#ÿÉ<ñçý‰ž(ÿÓõ¥ ¾*ÿ‚OÿÁKuÿ ø“B´ýüLŸAºøð×À.¼+6£sá{Ÿø7þ+ŸÃwÅŸöv­>ƒ6½§_ɣͪiÿ茺{[½íŸú-ËKÉ]ýùZ4«ÁBµ*u §Jª…XF¤Ja^E¦¹èÖ§Nµ)ÛšXB¤œb×ôž0Çåxªxܳ‹Ë±´£Z±xMl&*œ1ja«Æž#:uaøzµhVŒf•J5jRš”'(¿Õ¿f¿ÙÓ^Ôíõ­wàÁMkY´f{M[VøWà]GSµg´¾ÓÙ­ïï4)®¡f°Ôõ+&1ʤÚjÖÇ0ÝÜ$‘]þÌŸ³mÿŠÓÇwß³ßÀûÏG«éºü~2»øOà+Ǯ躤ºÞ­'ˆ¦ÐW]_IÖ§›WÓu%¼–:¤ÒßÚÍÜ)÷ +•e™j’šËð*kbšÂPRXÈRö0Å©*wX˜QýÔkßÚÆ—îÔ”t=Èq·ÓŒ#O‹¸žœiᧂ§gù¬c IÆ¥L$qiG :„çAZ”§ÊPn)¢£š®!–Þâ(ç‚xÞà™Xf†U)$RÆá’HäFdtu*êJ° ‘RQ]Ç̦ÓM6ši¦®škTÓ[4ögðÙÿIÿ”“~Ùö9üÿÖNýž«á*ý³ÿ‚†ÿÁ<¿nO‹·'í#ñcá?ìݯüDøoñ_øe«xOÅšOÄßÙÿ@·Ô-ôÙÿဵˆ¥Ñü{ñ{Â&±¸±ñ7„5Ë&[Ý®"‚Ë9®-n"•¾9ÿ‡[ÁI¿èÍügÿ‡—öNÿ膯é¾â,‚†C’ЯetkQÊ°ªÒ©ÃB¥:ÂÒŒá8Jª”' ^2Œ’qi¦´gðGˆñ¶eÆÜQÀp¾sŠÁⳜml6&Ž ¬éW¥:­Â¥9¥iBKXÉhÖ«Cá*þïàž?ò`°×ý™çìÍÿªWÁ5ü—ÿí¿à¤ßôfþ3ÿÃËû'ôCWöûxÅ¿ ÿd/ÙSág´±¡øëá§ìÝð7À4ÑVûNÕGñgƒ~ø_þ#ÒƧ£Ýßé:ˆÓõ6òÐ_iw׺u؇íWw6ÒE3ü?‰ù®Y˜àò˜åù† *XœLªG ‰£^Tã*TÔ\Õ)ÉÅ6šM¤›Mn~¹ô|á~"áÌOË=ɳ ª8ºBÃK‡]Щ˜ºª›’´5V›’Ý)£Älù8¯ø$ïýŸÿÄoýu—ü²¾ÿ¯€?lù8¯ø$ïýŸÿÄoýu—ü²¾ÿ¯Çé ¢Š(¢Š(ä/Û—àïÅŽ_!ð‡Á{ßüLð¿ÇïØû㧆t‰þ-ñ€¼ â'ý˜ÿkÏŸ´Ž«á]wƾðÅ=«â½áF§á½?]Óþø¼éº¶©aus¢ÜÙÇq·ÏácÿÁSèÍÿ`üYgíÿÒ¯¿è €?ácÿÁSèÍÿ`üYgíÿÒ£þ?ü7þŒßöÿÅ–~Ñ_ý)ÚûþŠøþ?ü7þŒßöÿÅ–~Ñ_ý)Ú?ácÿÁSèÍÿ`üYgíÿÒ¯¿è €?ácÿÁSèÍÿ`üYgíÿÒ£þ?ü7þŒßöÿÅ–~Ñ_ý)ÚûþŠøþ?ü7þŒßöÿÅ–~Ñ_ý)Ú?ácÿÁSèÍÿ`üYgíÿÒ¯¿è €?ácÿÁSèÍÿ`üYgíÿÒ£þ?ü7þŒßöÿÅ–~Ñ_ý)ÚûþŠøþ?ü7þŒßöÿÅ–~Ñ_ý)Ú?ácÿÁSèÍÿ`üYgíÿÒ¯¿è €?ácÿÁSèÍÿ`üYgíÿÒ£þ?ü7þŒßöÿÅ–~Ñ_ý)ÚûþŠøþ?ü7þŒßöÿÅ–~Ñ_ý)Ú?ácÿÁSèÍÿ`üYgíÿÒ¯¿è €?ácÿÁSèÍÿ`üYgíÿÒ£þ?ü7þŒßöÿÅ–~Ñ_ý)ÚûþŠøþ?ü7þŒßöÿÅ–~Ñ_ý)Ú?ácÿÁSèÍÿ`üYgíÿÒ¯¿è €?ácÿÁSèÍÿ`üYgíÿÒ£þ?ü7þŒßöÿÅ–~Ñ_ý)ÚûþŠøþ?ü7þŒßöÿÅ–~Ñ_ý)Ú?ácÿÁSèÍÿ`üYgíÿÒ¯¿è Ì-GÀ·¿Ç/ÿ±§‹þ6üý¾|3ý™¾?xÛ㧈µ…Ÿ¶ÆoŽþ:ñ#ë²íIû7hþÑ|âßØ?öyÐ W×?hM7Äšž»}ñ3c¤øjúÖ×EÔï5>Ïú{EQEÿÙPK!¹îs–°ppt/theme/theme2.xmlìYOoÛ6¿Øw toc'vuŠØ±›­MÄn‡i‰–XS¢@ÒI}Úã€úa—»í0l+лtŸ&[‡­úöHJ²ËHÒ۰ŇD"|ÿßã#uýÆ£˜¡C"$åIÛ«_­yˆ$>h¶½{Ãþ• I…“3ž¶7#Ò»±õþ{×ñ¦ŠHL¬Oä&n{‘RéæÊŠôaË«<% ̹ˆ±‚W®ݘ­¬Öjë+1¦‰‡Ù»ã1õ j’ÞVN¼Çà5QRøL 4iâ¬0Ø`R×9“]&Ð!fmøühH)1,L´½šùy+[×Wðf¶ˆ©%kKëúæ—­Ë“UÃS„£‚i½ßh]Û)èS‹¸^¯×íÕ z€}4µ²”i6úõNN³²‹´»µf­áâKô×dnu:f+“Å5 ûØXÀoÔÖÛ«Þ€,¾¹€ot¶»Ýuo@¿¾€ï_k­7\¼EŒ&“´vh¿ŸQ/ cÎv+áߨeð9 ¢¡ˆ.Íb̵,Öbü‹>4aE¤f)c¢¸‹ ªàM‚K3vÈ— Cš’¾ ©j{¦2bNïÍËïß¼|ŽÞ¼|vüøÅñ㟎Ÿ<9~ü£¥å,ÜÅIX^øúÛÏþüúcôÇóo^?ý¢/Ëø_øä—Ÿ?¯BÍ%zõå³ß^<{õÕ§¿÷´¾-ð¨ Ò˜Ht‡¡ƒnÆ0®äd$ηbaZ^±„'Xs© ßS‘ƒ¾3à Wà:ĵà}¤ xsúÐx‰©Ê\îhv+Šàç¬ÃE¥ni^%3§IXÍ\L˸Œ«xwqâø·7M¡tÒ*’݈8bî3œ(’„(¤çø„ {= Ô±ëõ—|¬ÐŠ:˜VšdHGN4ÍíÒü2«üíØfï>êpV¥õ9t‘˜U?$Ì1ãM½Ü£¡#Ò<@ôÌTTøò&áNüflŒ‰)5P×rÓä²vŸ¹vo Z™<»'*ö2ÜÉ:Ýå" ÿþ2½ƒ§É>ÌXÜ«.«ôe•öþóUzY>_|mž—c¨Ôºw²M·iÁã¥ø˜26P3FnKÓ„KØ„‚> êuæôIŠYÁ£Îd`ààBÍ$¸úˆªháøº§‰„2#J”r G3\I[ãá ì±³©$¶rH¬öx`‡×ôp~î(È©Bs¸Í­ige¶v-# º½ ³ºêÌÜêF4Sn…ÊÚÄæ€&/TƒÁšÐÝ è‰ÀÊëpþ׬áàƒ ´Ý­r·/\¤‹d„’ùHë½è£ºqR+ Šh=l0èCä)V+qki²ïÀí,N*³k,a—{ï]¼”GðÜK@íd:²¤œœ,AGm¯Õ\mzÈÇiÛÙã¼.uC‰YO¾6ìOMf“åso¶rÅÜ$¨Ã5ˆµû‚ÂNH…T;XF64ÌT,Ñœ¬ü«M0ëE)PQÎ&ÅÚÃ?&ØÑu-‰¯ÊÎ.hÛÙ׬”ò©"bGhĦâƒûu¨‚>•põa*‚~{:mm3åç,éÊ·cgÇ1K#œ•[¢y&[¸)H… æ­$èV)»Qîüª˜”¿ UÊaü?SEï'p ±høpM,0Ò™Òö¸P‡*”FÔï hLí€h»^˜† ‚Ëjó_Cýß朥aÒN“ꀆHPØT$Ù‡²d¢ïbõlï²$YFÈDTI\™Z±Gä°¡®ëzo÷P¡nªIV îdü¹ïYBÝä”óÍ©dÅÞksàïî|l2ƒRn6 MnÿBÄ¢=˜ïªv½Yžï½eEôļÍjäYÌJ[A+Kû·áœ[­­X ¯6sáÀ‹‹Ã`Ñ¥p™„ôØÿ¨ð™ýò¡7Ô!?€ÚŠàC†&aQ}Å6HH;8‚ÆÉÚ`Ò¤¬i³ÖI[-߬/¸Ó-øž0¶–ì,þ>§±‹æÌeçäâE;³°ck;¶ÔÔàÙ“) Cãü cc>™•¿jñÑCpô|?˜2%M0Á7+¡‡˜<€ä·ÍÒ­¿ÿÿPK!Øý¬¶ppt/tableStyles.xml ÌI‚0@Ὁwhþ}-CQ$ +wê*”!é@h£ãÝeùò’/Í?J¢—Xìd4ÿàº5ݤ{ƒc@ÖqÝqi´`° y¶ß¥>¬u® ³L:ê¼tgo$mN ppNçÙîÀµ ¥™ô·AA_Íõ†žý1"‚q‚åÌzs^ ïX£º£ðWÃƉĸ¶ßnú·ß9nJ’]Ü‹uó /ÀG›&Û6‹+˜àh ã0&°ÎÚ&M¥‡¸"é'ðš0Î{n;júgA÷¬í¹k¨£sTþƒ'xg”Uƒ[tJ kN¤Õ™­ø5Äs_':T®Ñ„yËØDa…RÁ4[U0ŽH«ºi`]W«e’¼ ñ#èqtc£ù?ârxúôãïÞw¦üÿÿPK!ž˜>¯™Îppt/viewProps.xml”S;oÂ0Þ+õ?XÞ!!âXªva¨ín9G°”Ø–Ï<}/1Jèfßã{ÜÙÓù¡*Ù*£3ÞëÆœ–&WºÈø×ê½3æ ½Ð¹(†Œù|öú2µéNÁþÓ1ИŠŒo¼·i¡Ü@%°k,hÊ­«„§«+¢Ü‰=We”Äñ0ª„ÒüÜïžé7ëµ’ðfä¶íˆƒRxeñ‚fŸA³`šî_’fdNײËïÆb}§Zoä X{†'Õ`˜Ä<ºÍ­ŒmR“þpؤ¢¿8XªZX¹,ópc¨…]™§òŒÇ¼Æ•mJQÂl*R<°zOÉ€3ªëÅ …ÂDqªPš2Þ™ôÎŽtèÅãÚ•Ý0[¸@_ hÎŒZiL4QãNœYƒÄÛ$Á{( ÁQrÁkAjð«Ç†ënÚxÀ|köFͽï຦¾znCýÒ‹&³—}\±©ø5çÁ=%…Fÿh¿Ãÿ•tÏ_ÐsXZ!é×0IËÑ£#^IŽÂ1ìoÞéÿÿPK!ihÛˆóúdocProps/app.xml ¢( ÔTMoÛ0 ½Ø0|oìlY·ŠŠ!E‘òˆÛ5‹N„É’!²Y»_?ÚŠg)´·ùôH>ó㉒¸z¬m²ƒ€Æ»Y:åi®ôÚ¸Í,½+n.>¥ ’rZYï`–>¦Wòí± ¾@0ágé–¨™f–[¨Ž8ì8RùP+b3l2_U¦„k_>Ôà({—ç—<8 ú¢9$LcÆéŽ^›Tû²í†–¢ð¤lajãÏ?ˆìh‹ï>h”ã÷ìP|ikJE,‰\š2xô%·]óÉÊÿ‚°òƑȆD§ê~»é†–ó$_‹ì™X© 6A5[®O˜s´ÅÚ (¹£=ß –¸­øHè=.‡zt­E5b—û59â Éq’á^ 'ú߸'Zþ¥ÞWã~â]SøkEÐïÞ©S¬·*€æw¡bÁkl›d¾UnºçœÚ‹{Ÿ29žŒrþº;ÚûÚ‹Ø?ZòÿÿPK!ö±‹i¨docProps/core.xml ¢( Œ’ÁOà Åï&þ ÷––-Ó¶KÔìä’&Öh¼!|ëˆ-4€ëößK»­ë¢ð?Þ÷ ]î›:رR« %QŒP\ ©ª ½–«ðÖ1%X­dè-óÛ›”·”k…Ñ-'Áž¤,åm†¶ÎµcË·Ð0y‡òâF›†9¿4nÿb`Ç Ü€c‚9†{`ØŽDtB >"ÛoSÁ1ÔЀr'Q‚/^¦±”‰³‘îÐú™Nq§lÁâèÞ[9»®‹ºÙÃçOðûúùe5”ªïŠÊSÁ©“®†¼Ð˜BKå‚€õ‰™óe§xtô^n€9mòO£m¥ëA=ïõ]×̺µ–ñp¸Ø~K½ÛÀNö/š“»O×þª¡…ã} ?=¶pVÞfOå å$Na<“û’Ä”Jæ}¬«óýœÇæîD—$ñ8J’ ñ ȇÄ×+ÿÿÿPK-!Ì»~á')[Content_Types].xmlPK-!høt¡â `_rels/.relsPK-!ˆQ¿ÛÙÎ –ppt/slides/_rels/slide1.xml.relsPK-![SLÙÎ ­ppt/slides/_rels/slide2.xml.relsPK-!¼½ú¸ÙÎ Ä ppt/slides/_rels/slide4.xml.relsPK-!Ës7L}Û ppt/_rels/presentation.xml.relsPK-!2wŽ|ÙÎ l ppt/slides/_rels/slide5.xml.relsPK-!ÕÂ'ˆÙÎ ƒppt/slides/_rels/slide3.xml.relsPK-!QcdyM šppt/presentation.xmlPK-!ÆLF”²•8Eppt/slides/slide5.xmlPK-!}¿òiD Ëg*ppt/slides/slide4.xmlPK-!Itj*s yN¡&ppt/slides/slide1.xmlPK-!¸{Tºx ÷\G0ppt/slides/slide2.xmlPK-!~Y9ŒÊ!)ò:ppt/slides/slide3.xmlPK-!ð‰DžÕ¿*ïAppt/notesSlides/_rels/notesSlide5.xml.relsPK-!i¢_!Ç, Cppt/slideMasters/_rels/slideMaster1.xml.relsPK-!ÕÑ’ñ¾7,tDppt/slideLayouts/_rels/slideLayout9.xml.relsPK-!ÕÑ’ñ¾7-|Eppt/slideLayouts/_rels/slideLayout10.xml.relsPK-!ÕÑ’ñ¾7-…Fppt/slideLayouts/_rels/slideLayout11.xml.relsPK-!¨Kõ/à0!ŽGppt/slideMasters/slideMaster1.xmlPK-!J¯u9Ô¿*üOppt/notesSlides/_rels/notesSlide1.xml.relsPK-!ÕÑ’ñ¾7,Qppt/slideLayouts/_rels/slideLayout1.xml.relsPK-!ÕÑ’ñ¾7, Rppt/slideLayouts/_rels/slideLayout6.xml.relsPK-!ÕÑ’ñ¾7,(Sppt/slideLayouts/_rels/slideLayout5.xml.relsPK-!ÕÑ’ñ¾7,0Tppt/slideLayouts/_rels/slideLayout4.xml.relsPK-!ÕÑ’ñ¾7,8Uppt/slideLayouts/_rels/slideLayout3.xml.relsPK-!ÕÑ’ñ¾7,@Vppt/slideLayouts/_rels/slideLayout2.xml.relsPK-!ÕÑ’ñ¾7,HWppt/slideLayouts/_rels/slideLayout8.xml.relsPK-!X¤MÓK1 PXppt/notesSlides/notesSlide5.xmlPK-!*ÖøÈZ: Ø[ppt/notesSlides/notesSlide4.xmlPK-!¶H•â!o_ppt/slideLayouts/slideLayout5.xmlPK-!T_é}i!eppt/slideLayouts/slideLayout4.xmlPK-!ceVçR!Ljppt/slideLayouts/slideLayout3.xmlPK-!ø³a´™ !roppt/slideLayouts/slideLayout2.xmlPK-!%5…tª!esppt/slideLayouts/slideLayout1.xmlPK-!<íjÕ¿*Nxppt/notesSlides/_rels/notesSlide3.xml.relsPK-!~C0ZÕ¿*kyppt/notesSlides/_rels/notesSlide4.xml.relsPK-!bAAø=¼!ˆzppt/slideLayouts/slideLayout6.xmlPK-!Ø<šé j!~ppt/slideLayouts/slideLayout7.xmlPK-!ªŠÔ“Y¿!Oppt/slideLayouts/slideLayout8.xmlPK-! à¿dVÿç†ppt/notesSlides/notesSlide3.xmlPK-!˜0çíYÿzŠppt/notesSlides/notesSlide2.xmlPK-!LžIN°Žppt/notesSlides/notesSlide1.xmlPK-!™ö™®Õ¿*›‘ppt/notesSlides/_rels/notesSlide2.xml.relsPK-!îÄÝ¡¯ "¸’ppt/slideLayouts/slideLayout11.xmlPK-!îT ‰ËÐ "—ppt/slideLayouts/slideLayout10.xmlPK-!#•îƒ/!›ppt/slideLayouts/slideLayout9.xmlPK-!ÕÑ’ñ¾7,r ppt/slideLayouts/_rels/slideLayout7.xml.relsPK-!+ÆÆáFÌ!z¡ppt/notesMasters/notesMaster1.xmlPK-!¹îs–°ÿ§ppt/theme/theme1.xmlPK-!´ÏX»$,Ç®ppt/notesMasters/_rels/notesMaster1.xml.relsPK- !;Q§¸TT̯docProps/thumbnail.jpegPK-!¹îs–°ppt/theme/theme2.xmlPK-!Øý¬¶É ppt/tableStyles.xmlPK-!-¯®Q‹¦ ppt/presProps.xmlPK-!ž˜>¯™Î& ppt/viewProps.xmlPK-!ihÛˆóúîdocProps/app.xmlPK-!ö±‹i¨docProps/core.xmlPK::µ·gprbuild-25.0.0/doc/gprbuild_ug/gnat_project_manager.rst000066400000000000000000006340711470075373400234060ustar00rootroot00000000000000.. |with| replace:: :samp:`with` .. |withs| replace:: :samp:`with`\ s .. |withed| replace:: :samp:`with`\ ed .. |withing| replace:: :samp:`with`\ ing .. |limited_with| replace:: :samp:`limited with` .. -- Example: A |withing| unit has a |with| clause, it |withs| a |withed| unit .. _GNAT_Project_Manager: ******************** GNAT Project Manager ******************** .. _GNAT_Project_Manager_Introduction: Introduction ============ This chapter describes GNAT's *Project Manager*, a facility that allows you to manage complex builds involving a number of source files, directories, and options for different system configurations. In particular, project files allow you to specify properties including: * The directory or set of directories containing the source files, and/or the names of the specific source files themselves; * The directory in which the compiler's output (:file:`ALI` files, object files, tree files, etc.) is to be placed; * The directory in which the executable programs are to be placed; * Switch settings, which can be applied either globally or to individual compilation units, for any of the project-enabled tools; * The source files containing the main subprograms to be built; * The source programming language(s); and * Source file naming conventions, which can be specified either globally or for individual compilation units (see :ref:`Naming_Schemes`). Project files also allow you to: * Change any of the above settings depending on external values, thus enabling the reuse of the projects in various **scenarios** (see :ref:`Scenarios_in_Projects`); and * Automatically build libraries as part of the build process (see :ref:`Library_Projects`). Project files are written in an Ada-like syntax, using familiar notions such as packages, context clauses, declarations, default values, assignments, and inheritance (see :ref:`Project_File_Reference`). Project files can depend upon other project files in a modular fashion, simplifying complex system integration and project reuse. .. index:: Importing a project * One project can **import** other projects containing needed source files. More generally, the Project Manager lets you structure large development efforts into possibly interrelated subsystems, where build decisions are delegated to the subsystem level, and thus different compilation environments (switch settings) are used for different subsystems. See :ref:`Organizing_Projects_into_Subsystems`. .. index:: Project extension * You can organize GNAT projects in a hierarchy: a project can **extend** a base project, inheriting its source files and optionally overriding any of them with alternative versions. See :ref:`Project_Extension`. .. index:: -P .. index:: -X Several tools support project files, generally in addition to specifying the information on the command line itself. They share common switches to control the loading of the project (in particular :samp:`-P{projectfile}` to define the applicable project file and :samp:`-X{vbl}={value}` to set the value of an external variable). The Project Manager supports a wide range of development strategies, for systems of all sizes. Here are some typical practices that are easily handled: * Using a common set of source files and generating object files in different directories via different switch settings. This can be used for instance to generate separate sets of object files for debugging and for production. * Using a mostly shared set of source files with different versions of some units or subunits. This can be used for instance to group and hide all OS dependencies in a small number of implementation units. Project files can be used to achieve some of the effects of a source versioning system (for example, defining separate projects for the different sets of sources that comprise different releases) but the Project Manager is independent of any source configuration management tool that might be used by the developers. The sections below use an example-driven approach to present and illustrate the various concepts related to projects. .. _Building_with_Projects: Building with Projects ====================== In its simplest form a project may be used in a stand-alone fashion to build a single executable, and this section will focus on such a setup in order to introduce the main ideas. Later sections will extend this basic model to more complex and realistic configurations. The following concepts are the foundation of project files, and will be further detailed later in this documentation. They are summarized here as a reference. .. index:: Project file **Project file**: A text file expressed in an Ada-like syntax, generally with the :file:`.gpr` extension. It defines build-related characteristics of an application. The characteristics include the list of sources, the location of those sources, the location for the generated object files, the name of the main program, and the options for the various tools involved in the build process. .. index:: Project attribute **Project attribute**: A specific project characteristic is defined by an `attribute clause`. Its value is a string or a sequence of strings. All settings in a project are defined through a list of predefined attributes with precise semantics. See :ref:`Attributes`. .. index:: Packages in project files **Package in a project**: Global attributes are defined at the top level of a project. Attributes affecting specific tools are grouped in a package whose name is related to tool's function. The most common packages are `Builder`, `Compiler`, `Binder`, and `Linker`. See :ref:`Packages`. .. index:: Project variable **Project variables**: In addition to attributes, a project can use variables to store intermediate values and avoid duplication in complex expressions. Variables can be initialized with external values coming from the environment. A frequent use of variables is to define `scenarios`. See :ref:`External Values `, :ref:`Scenarios_in_Projects`, and :ref:`Variables`. **Source files** and **source directories**: A source file is associated with a language through a naming convention. For instance, :file:`foo.c` is typically the name of a C source file; :file:`bar.ads` or :file:`bar.1.ada` are two common naming conventions for a file containing an Ada spec. A compilable entity is often composed of a main source file and potentially several auxiliary ones, such as header files in C. The naming conventions can be user-defined (see :ref:`Naming_Schemes`), and will drive the builder to call the appropriate compiler for the given source file. Source files are searched for in the source directories associated with the project through the **Source_Dirs** attribute. By default, all the files (in these source directories) following the naming conventions associated with the declared languages are considered to be part of the project. It is also possible to limit the list of source files using the **Source_Files** or **Source_List_File** attributes. Note that those last two attributes only accept basenames with no directory information. **Object files** and **object directory**: An object file is an intermediate file produced by the compiler from a compilation unit. It is used by post-compilation tools to produce final executables or libraries. Object files produced in the context of a given project are stored in a single directory that can be specified by the **Object_Dir** attribute. In order to store objects in two or more object directories, the system must be split into distinct subsystems, each with its own project file. The following subsections introduce the attributes of interest for simple build needs. Here is the basic setup that will be used in the following examples: The Ada source files :file:`pack.ads`, :file:`pack.adb`, and :file:`proc.adb` are in the :file:`common/` directory. The file :file:`proc.adb` contains an Ada main subprogram ``Proc`` that |withs| package ``Pack``. We want to compile these source files with the switch :option:`-O2`, and place the resulting files in the :file:`common/obj/` directory. Here is the directory structure: :: common/ pack.ads pack.adb proc.adb common/obj/ proc.ali, proc.o pack.ali, pack.o, proc.exe Our project is to be called *Build*. The name of the file is the name of the project (case-insensitive) with the :file:`.gpr` extension, therefore the project file name is :file:`build.gpr`. This is not mandatory, but a warning is issued when this convention is not followed. This is a very simple example, and as stated above, a single project file is sufficient. We will thus create a new file, :file:`build.gpr`, that initially contains an empty project declaration: .. code-block:: gpr project Build is end Build; Note that repeating the project name after ``end`` is mandatory. .. _Source_Files_and_Directories: Source Files and Directories ---------------------------- When you create a new project, the first task is to specify where the corresponding source files are located. These are the only settings that are needed by all the tools that will use this project (builder, compiler, binder and linker for the compilation, IDEs to edit the source files, etc.). .. index:: Source directories The first step is thus to declare the source directories, which are the directories to be searched to find source files. In the current example, the :file:`common` directory is the only source directory. .. index:: Source_Dirs attribute There are several ways to specify the source directories: * When the attribute **Source_Dirs** is not defined, a project contains a single source directory which is the one where the project file itself resides. In our example, if :file:`build.gpr` is placed in the :file:`common` directory, the project will have the needed implicit source directory. * The attribute **Source_Dirs** can be set to a list of path names, one for each of the source directories. Such paths can either be absolute names (for instance :file:`"/usr/local/common/"` on Unix), or relative to the directory in which the project file resides (for instance :file:`"."` if :file:`build.gpr` is inside :file:`common/`, or :file:`"common"` if it is one level up). Each of the source directories must exist and be readable. .. index:: Portability of path names The syntax for directories is platform specific. For portability, however, the project manager will always properly translate Unix-like path names to the native format of the specific platform. For instance, when the same project file is to be used both on Unix and Windows, :file:`"/"` should be used as the directory separator rather than :file:`"\\"`. * The attribute **Source_Dirs** can automatically include subdirectories using a special syntax inspired by some Unix shells. If any of the paths in the list ends with ":file:`**`", then that path and all its subdirectories (recursively) are included in the list of source directories. For instance, ":file:`**`" and ":file:`./**`" represent the complete directory tree rooted at the directory in which the project file resides. .. index:: Source_Dirs attribute .. index:: Excluded_Source_Dirs attribute When using the ``Source_Dirs`` construct, you may sometimes find it convenient to also use the attribute ``Excluded_Source_Dirs``, which is also a list of paths. Each entry specifies a directory whose immediate content, not including subdirs, is to be excluded. It is also possible to exclude a complete directory subtree using the ``**`` notation. .. index:: Ignore_Source_Sub_Dirs attribute It is often desirable to remove, from the source directories, directory subtrees rooted at some subdirectories. An example is the subdirectories created by a Version Control System such as Subversion that creates directory subtrees rooted at a subdirectory named :file:`.svn`. To do that, attribute **Ignore_Source_Sub_Dirs** can be used. It specifies the list of simple file names or patterns for the roots of these undesirable directory subtrees. .. code-block:: gpr for Source_Dirs use ("./**"); for Ignore_Source_Sub_Dirs use (".svn", "@*"); With the declaration of attribute Ignore_Source_Sub_Dirs above, .svn subtrees as well as subtrees rooted at subdirectories with a name starting with '@' are not part of the source directories of the project. When applied to the simple example, and because we generally prefer to have the project file at the top-level directory rather than mixed with the sources, we will add the relevant definition for the ``Source_Dirs`` attribute to our :file:`build.gpr` project file: .. code-block:: gpr project Build is for Source_Dirs use ("common"); -- <<<< end Build; Once the source directories have been specified, you may need to indicate specific source files of interest. By default, all source files present in the source directories are considered by the Project Manager. When this is not desired, it is possible to explicitly specify the list of sources to consider. In such a case, only source file base names are indicated and not their absolute or relative path names. The project manager is in charge of locating the specified source files in the specified source directories. * By default, the project manager searches for all source files of all specified languages in all the source directories. Since the project manager was initially developed for Ada environments, the default language is usually Ada and the above project file is complete: it defines without ambiguity the sources composing the project: that is, all the sources in subdirectory :file:`common` for the default language (Ada) using the default naming convention. .. index:: Languages attribute However, when compiling a multi-language application, or a pure C application, the project manager must be told which languages are of interest, which is done by setting the **Languages** attribute to a list of strings, each of which is the name of a language. .. index:: Naming scheme Even when only Ada is used, the default naming might not be suitable. Indeed, how does the project manager distinguish an Ada source file from any other file? Project files can describe the naming scheme used for source files, and override the default (see :ref:`Naming_Schemes`). The default is the standard GNAT extension (:file:`.adb` for bodies and :file:`.ads` for specs), which is what is used in our example, and thus no naming scheme is explicitly specified. See :ref:`Naming_Schemes`. .. index:: Source_Files attribute * `Source_Files`. In some cases, source directories might contain files that should not be included in a project. One can specify the explicit list of file names to be considered through the **Source_Files** attribute. When this attribute is defined, instead of looking at every file in the source directories, the project manager takes only those names into consideration and reports errors if they cannot be found in the source directories or do not correspond to the naming scheme. * It is sometimes useful to have a project with no sources (most of the time because the attributes defined in the project file will be reused in other projects, as explained in :ref:`Organizing_Projects_into_Subsystems`. To do this, the attribute ``Source_Files`` is set to the empty list, i.e. ``()``. Alternatively, ``Source_Dirs`` can be set to the empty list, with the same result. .. index:: Source_List_File attribute * `Source_List_File`. If there is a large number of files, it might be more convenient to use the attribute **Source_List_File**, which specifies the full path of a file. This file must contain a list of source file names (one per line, no directory information) that are searched as if they had been defined through ``Source_Files``. Such a file can easily be created through external tools. A warning is issued if both attributes ``Source_Files`` and ``Source_List_File`` are given explicit values. In this case, the attribute ``Source_Files`` prevails. .. index:: Excluded_Source_Files attribute .. index:: Locally_Removed_Files attribute .. index:: Excluded_Source_List_File attribute * `Excluded_Source_Files`. Specifying an explicit list of files is not always convenient. Instead it might be preferable to use the default search rules with specific exceptions. This can be done through the attribute **Excluded_Source_Files** (or its synonym **Locally_Removed_Files**). Its value is the list of file names that should not be taken into account. This attribute is often used when extending a project, see :ref:`Project_Extension`. A similar attribute **Excluded_Source_List_File** plays the same role but takes the name of file containing file names similarly to ``Source_List_File``. In most simple cases, such as the above example, the default source file search behavior provides the expected result, and we do not need to add anything after setting ``Source_Dirs``. The Project Manager automatically finds :file:`pack.ads`, :file:`pack.adb`, and :file:`proc.adb` as source files of the project. Note that by default a warning is issued when a project has no sources attached to it and this is not explicitly indicated in the project file. .. _Duplicate_Sources_in_Projects: Duplicate Sources in Projects ----------------------------- If the order of the source directories is known statically, that is if ``"/**"`` is not used in the string list for ``Source_Dirs``, then there may be several files with the same name situated in different directories of the project. In this case, only the file in the first directory is considered as a source of the project and the others are hidden. If ``"/**"`` is used in the string list for ``Source_Dirs``, it is an error to have several files with the same name in the same directory ``"/**"`` subtree, since there would be an ambiguity as to which one should be used. If there are two sources with the same name in different directories of the same ``"/**"`` subtree, one way to resolve the problem is to exclude the directory of the file that should not be used as a source of the project. .. _Object_and_Exec_Directory: Object and Exec Directory ------------------------- Another consideration when designing a project is to decide where the compiler should place the object files. In fact, the compiler and other tools might create several different kinds of files (for GNAT, there is the object file and the ALI file). One of the important concepts in projects is that most tools may consider source directories as read-only and thus do not attempt to create new or temporary files there. Instead, all such files are created in the object directory. (This is not true for project-aware IDEs, one of whose purposes is to create the source files.) .. index:: Object_Dir attribute .. index:: -p (gprbuild) The object directory is specified through the **Object_Dir** attribute. Its value is the path to the object directory, either absolute or relative to the directory containing the project file. This directory must already exist and be readable and writable, although some tools have a switch to create the directory if needed (See the switch :option:`-p` for *gprbuild*). If the attribute ``Object_Dir`` is not specified, it defaults to the directory containing the project file. For our example, we can specify the object directory in this way (assuming that the project file will reside in the parent directory of :file:`common`): .. code-block:: gpr project Build is for Source_Dirs use ("common"); for Object_Dir use "common/obj"; -- <<<< end Build; As mentioned earlier, *there is a single object directory per project*. As a result, if you have an existing system where the object files are spread across several directories, one option is to move all of them into the same directory if you want to build it with a single project file. An alternative approach is described below (see :ref:`Organizing_Projects_into_Subsystems`), allowing each separate object directory to be associated with a corresponding subsystem of the application. Incidentally, the directory designated by the ``Object_Dir`` attribute may be used by project aware tools other than the compilation toolchain to store reports or intermediate files. .. index:: Exec_Dir attribute When the *linker* is called, it usually creates an executable. By default, this executable is placed in the project's object directory. However in some situations it may be convenient to store it in elsewhere. This can be done through the **Exec_Dir** attribute, which, like ``Object_Dir`` contains a single absolute or relative path and must point to an existing and writable directory, unless you ask the tool to create it on your behalf. If neither ``Object_Dir`` nor ``Exec_Dir`` is specified then the executable is placed in the directory containing the project file. In our example, let's specify that the executable is to be placed in the same directory as the project file :file:`build.gpr`. The project file is now: .. code-block:: gpr project Build is for Source_Dirs use ("common"); for Object_Dir use "obj"; for Exec_Dir use "."; -- <<<< end Build; .. _Main_Subprograms: Main Subprograms ---------------- An important role of a project file is to identify the executable(s) that will be built. It does this by specifying the source file for the main subprogram (for Ada) or the file that contains the ``main`` function (for C). There can be any number of such main files within a given project, and thus several executables can be built from a single project file. Of course, a given executable might not (and in general will not) need all the source files referenced by the project. As opposed to other build mechanisms such as through a *Makefile*, you do not need to specify the list of dependencies of each executable. The project-aware builder knows enough of the semantics of the languages to build and link only the necessary elements. .. index:: Main attribute The list of main files is specified via the **Main** attribute. It contains a list of file names (no directories). If a file name is specified without extension, it is completed using the naming convention defined in the package Naming. If a project defines this attribute, it is not necessary to identify main files on the command line when invoking a builder, and editors like *GPS* will be able to create extra menus to spawn or debug the corresponding executables. .. code-block:: gpr project Build is for Source_Dirs use ("common"); for Object_Dir use "obj"; for Exec_Dir use "."; for Main use ("proc.adb"); -- <<<< end Build; If this attribute is defined in the project, then spawning the builder with a command such as .. code-block:: sh gprbuild -Pbuild automatically builds all the executables corresponding to the files listed in the *Main* attribute. It is possible to specify one or more executables on the command line to build a subset of them. One or more spaces may be placed between the :option:`-P` and the project name, and the project name may be a simple name (no file extension) or a path for the project file. Thus each of the following is equivalent to the command above: .. code-block:: sh gprbuild -P build gprbuild -P build.gpr gprbuild -P ./build.gpr .. _Tools_Options_in_Project_Files: Tools Options in Project Files ------------------------------ We now have a project file that fully describes our environment, and it can be used to build the application with a simple *GPRbuild* command as shown above. In fact, the empty project that we saw at the beginning (with no attribute definitions) could already achieve this effect if it was placed in the :file:`common` directory. Of course, we might want more control. This section shows you how to specify the compilation switches that the various tools involved in the building of the executable should use. .. index:: Command line length Since source names and locations are described in the project file, it is not necessary to use switches on the command line for this purpose (such as :option:`-I` for gcc). This removes a major source of command line length overflow. Clearly, the builders will have to communicate this information one way or another to the underlying compilers and tools they call, but they usually use various text files, such as response files, for this purpose and thus are not subject to command line overflow. Several tools are used to create an executable: the compiler produces object files from the source files; the binder (when the language is Ada) creates a "source" file that, among other things, takes care of elaboration issues and global variable initialization; and the linker gathers everything into a single executable. All these tools are known to the project manager and will be invoked with user-defined switches from the project files. To obtain this effect, a project file feature known as a *package* is used. .. index:: Packages in project files A project file contains zero or more **packages**, each of which defines the attributes specific to one tool (or one set of tools). Project files use an Ada-like syntax for packages. Package names permitted in project files are restricted to a predefined set (see :ref:`Packages`), and the contents of packages are limited to a small set of constructs and attributes (see :ref:`Attributes`). Our example project file below includes several empty packages. At this stage, they could all be omitted since they are empty, but they show which packages would be involved in the build process. .. code-block:: gpr project Build is for Source_Dirs use ("common"); for Object_Dir use "obj"; for Exec_Dir use "."; for Main use ("proc.adb"); package Builder is --<<< for gprbuild end Builder; package Compiler is --<<< for the compiler end Compiler; package Binder is --<<< for the binder end Binder; package Linker is --<<< for the linker end Linker; end Build; Let's first examine the compiler switches. As stated in the initial description of the example, we want to compile all files with :option:`-O2`. This is a compiler switch, although it is typical, on the command line, to pass it to the builder which then passes it to the compiler. We recommend directly using the correct package, which will make the setup easier to understand. Several attributes can be used to specify the switches: .. index:: Default_Switches attribute .. index:: Indexed attribute concept **Default_Switches**: This illustrates the concept of an **indexed attribute**. When such an attribute is defined, you must supply an *index* in the form of a literal string. In the case of *Default_Switches*, the index is the name of the language to which the switches apply (since a different compiler will likely be used for each language, and each compiler has its own set of switches). The value of the attribute is a list of switches. In this example, we want to compile all Ada source files with the switch :option:`-O2`; the resulting `Compiler` package is as follows: .. code-block:: gpr package Compiler is for Default_Switches ("Ada") use ("-O2"); end Compiler; .. index:: Switches attribute **Switches**: In some cases, we might want to use specific switches for one or more files. For instance, compiling :file:`proc.adb` might not be desirable at a high level of optimization. In such a case, the *Switches* attribute (indexed by the file name) can be used and will override the switches defined by *Default_Switches*. The *Compiler* package in our project file would become: .. code-block:: gpr package Compiler is for Default_Switches ("Ada") use ("-O2"); for Switches ("proc.adb") use ("-O0"); end Compiler; *Switches* may take a pattern as an index, such as in: .. code-block:: gpr package Compiler is for Default_Switches ("Ada") use ("-O2"); for Switches ("pkg*") use ("-O0"); end Compiler; Sources :file:`pkg.adb` and :file:`pkg-child.adb` would be compiled with :option:`-O0`, not :option:`-O2`. *Switches* can also be given a language name as index instead of a file name in which case it has the same semantics as *Default_Switches*. However, indexes with wild cards are never valid for language name. .. index:: Local_Configuration_Pragmas attribute **Local_Configuration_Pragmas**: This attribute may specify the path of a file containing configuration pragmas for use by the Ada compiler, such as `pragma Restrictions (No_Tasking)`. These pragmas will be used for all the sources of the project. .. index:: Builder package .. index:: Binder package .. index:: Linker package The switches for the other tools are defined in a similar manner through the **Default_Switches** and **Switches** attributes, respectively in the *Builder* package (for *GPRbuild*), the *Binder* package (binding Ada executables) and the *Linker* package (for linking executables). .. _Compiling_with_Project_Files: Compiling with Project Files ---------------------------- Now that our project file is written, let's build our executable. Here is the command we would use from the command line: .. index:: -P (gprbuild) .. code-block:: sh gprbuild -Pbuild This will automatically build the executables specified in the *Main* attribute: for each, it will compile or recompile the sources for which the object file does not exist or is not up-to-date; it will then run the binder; and finally run the linker to create the executable itself. The *GPRbuild* builder can automatically manage C files the same way: create the file :file:`utils.c` in the :file:`common` directory, set the attribute *Languages* to `"(Ada, C)"`, and re-run .. code-block:: sh gprbuild -Pbuild *GPRbuild* knows how to recompile the C files and will recompile them only if one of their dependencies has changed. No direct indication on how to build the various elements is given in the project file, which describes the project properties rather than a set of actions to be executed. Here is the invocation of *GPRbuild* when building a multi-language program: .. code-block:: sh $ gprbuild -Pbuild gcc -c proc.adb gcc -c pack.adb gcc -c utils.c gprbind proc ... gcc proc.o -o proc Notice the three steps described earlier: * The first three gcc commands correspond to the compilation phase. * The gprbind command corresponds to the post-compilation phase. * The last gcc command corresponds to the final link. .. index:: -v (gprbuild) The default output of *GPRbuild* is reasonably simple and easy to understand. In particular, some of the less frequently used commands are not shown, and some parameters are abbreviated. Thus it is not possible to rerun the effect of the *GPRbuild* command by cut-and-pasting its output. The :option:`-v` option to *GPRbuild* provides a much more verbose output which includes, among other information, more complete compilation, post-compilation and link commands. .. _Executable_File_Names: Executable File Names --------------------- .. index:: Executable attribute By default, the executable name corresponding to a main file is computed from the main source file name. Through the attribute **Executable** in package ``Builder``, it is possible to change this default. For instance, instead of building an executable named ``"proc"`` (or ``"proc.exe"`` on Windows), we could configure our project file to build ``proc1`` (respectively ``proc1.exe``) as follows: .. code-block:: gpr project Build is ... -- same as before package Builder is for Executable ("proc.adb") use "proc1"; end Builder end Build; .. index:: Executable_Suffix Attribute **Executable_Suffix**, when specified, changes the suffix of the executable files when no attribute ``Executable`` applies: its value replaces the platform-specific executable suffix. The default executable suffix is the empty string empty on Unix and ``".exe"`` on Windows. It is also possible to change the name of the produced executable by using the command line switch :option:`-o`. However, when several main programs are defined in the project, it is not possible to use the :option:`-o` switch; then the only way to change the names of the executable is through the attributes ``Executable`` and ``Executable_Suffix``. .. _Using_Variables_to_Avoid_Duplication: Using Variables to Avoid Duplication ------------------------------------ To illustrate some other project capabilities, here is a slightly more complex project using similar sources and a main program in C: .. code-block:: gpr project C_Main is for Languages use ("Ada", "C"); for Source_Dirs use ("common"); for Object_Dir use "obj"; for Main use ("main.c"); package Compiler is C_Switches := ("-pedantic"); for Default_Switches ("C") use C_Switches; for Default_Switches ("Ada") use ("-gnaty"); for Switches ("main.c") use C_Switches & ("-g"); end Compiler; end C_Main; This project has many similarities with the previous one. As expected, its ``Main`` attribute now refers to a C source file. The attribute ``Exec_Dir`` is now omitted, thus the resulting executable will be put in the object directory :file:`obj`. The most noticeable difference is the use of a variable in the ``Compiler`` package to store settings used in several attributes. This avoids text duplication and eases maintenance (a single place to modify if we want to add new switches for C files). We will later revisit the use of variables in the context of scenarios (see :ref:`Scenarios_in_Projects`). In this example, we see that the file :file:`main.c` will be compiled with the switches used for all the other C files, plus :option:`-g`. In this specific situation the use of a variable could have been replaced by a reference to the ``Default_Switches`` attribute: .. code-block:: gpr for Switches ("c_main.c") use Compiler'Default_Switches ("C") & ("-g"); Note the tick character "``'``", which is used to refer to attributes defined in a package. Here is the output of the *GPRbuild* command using this project: .. code-block:: sh $ gprbuild -Pc_main gcc -c -pedantic -g main.c gcc -c -gnaty proc.adb gcc -c -gnaty pack.adb gcc -c -pedantic utils.c gprbind main.bexch ... gcc main.o -o main The default switches for Ada sources, the default switches for C sources (in the compilation of :file:`lib.c`), and the specific switches for :file:`main.c` have all been taken into account. .. index:: Naming scheme .. index:: Naming package .. _Naming_Schemes: Naming Schemes -------------- Sometimes an Ada software system needs to be ported from one compilation environment to another (such as GNAT), but the files might not be named using the default GNAT conventions. Instead of changing all the file names, which for a variety of reasons might not be possible, you can define the relevant file naming scheme in the **Naming** package of your project file. The naming scheme has two distinct goals for the Project Manager: it allows source files to be located when searching in the source directories, and given a source file name it makes it possible to infer the associated language, and thus which compiler to use. Note that the Ada compiler's use of pragma `Source_File_Name` is not supported when using project files. You must use the features described here. You can, however, specify other configuration pragmas. The following attributes can be defined in package `Naming`: .. index:: Casing attribute **Casing**: Its value must be one of ``"lowercase"`` (the default if unspecified), ``"uppercase"`` or ``"mixedcase"``. It describes the casing of file names with regard to the Ada unit name. Given an Ada package body My_Unit, the base file name (i.e. minus the extension, which is controlled by other attributes described below) will respectively be: * for "lowercase": "my_unit" * for "uppercase": "MY_UNIT" * for "mixedcase": any spelling with indifferent casing such as "My_Unit", "MY_Unit", "My_UnIT" etc... The case insensitive name must be unique, otherwise an error will be reported. For example, there cannot be two source file names such as "My_Unit.adb" and "MY_UnIT.adb". On Windows, file names are case insensitive, so this attribute is irrelevant. .. index:: Dot_Replacement attribute **Dot_Replacement**: This attribute specifies the string that should replace the ``"."`` in unit names. Its default value is ``"-"`` so that a unit ``Parent.Child`` is expected to be found in the file :file:`parent-child.adb`. The replacement string must satisfy the following requirements to avoid ambiguities in the naming scheme: * It must not be empty * It cannot start or end with an alphanumeric character * It cannot be a single underscore * It cannot start with an underscore followed by an alphanumeric * It cannot contain a dot ``'.'`` unless the entire string is ``"."`` * It cannot include a space or a character that is not printable ASCII .. index:: Spec_Suffix attribute .. index:: Specification_Suffix attribute **Spec_Suffix** and **Specification_Suffix**: For Ada, these attributes specify the suffix used in file names that contain specifications. For other languages, they give the extension for files that contain declarations (header files in C for instance). The attribute is indexed by the language name. The two attributes are equivalent, but ``Specification_Suffix`` is obsolescent. If the value of the attribute is the empty string, it indicates to the Project Manager that the only specifications/header files for the language are those specified with attributes ``Spec`` or ``Specification_Exceptions``. If ``Spec_Suffix ("Ada")`` is not specified, then the default is ``".ads"``. A non empty value must satisfy the following requirements: * It must include at least one dot * If ``Dot_Replacement`` is a single dot, then it cannot include more than one dot. .. index:: Body_Suffix attribute .. index:: Implementation_Suffix attribute **Body_Suffix** and **Implementation_Suffix**: These attributes are equivalent and specify the extension used for file names that contain code (bodies in Ada). They are indexed by the language name. ``Implementation_Suffix`` is obsolescent and fully replaced by the first attribute. For each language of a project, one of these two attributes needs to be specified, either in the project itself or in the configuration project file. If the value of the attribute is the empty string, it indicates to the Project Manager that the only source files for the language are those specified with attributes ``Body`` or ``Implementation_Exceptions``. These attributes must satisfy the same requirements as ``Spec_Suffix``. In addition, they must be different from any of the values in ``Spec_Suffix``. If ``Body_Suffix ("Ada")`` is not specified, then the default is ``".adb"``. If ``Body_Suffix ("Ada")`` and ``Spec_Suffix ("Ada")`` end with the same string, then a file name that ends with the longest of these two suffixes will be a body if the longest suffix is ``Body_Suffix ("Ada")``, or a spec if the longest suffix is ``Spec_Suffix ("Ada")``. If the suffix does not start with a ``'.'``, a file with a name exactly equal to the suffix will also be part of the project (for instance if you define the suffix as ``Makefile.in``, a file called :file:`Makefile.in` will be part of the project. This capability is usually not of interest when building. However, it might become useful when a project is also used to find the list of source files in an editor, like the GNAT Programming System (GPS). .. note:: Attributes ``Body_Suffix`` and ``Spec_Suffix`` have case-insensitive values. This means different languages should not share the same attribute value in a single project. For instance : .. code-block:: gpr package Naming is for Body_Suffix ("c") use ".c"; for Body_Suffix ("c++") use ".C"; for Spec_Suffix ("c") use ".h"; for Spec_Suffix ("c++") use ".H"; end Naming; will result in : .. code-block:: gpr Body_Suffix (".c") for language c is also defined for language c++. Spec_Suffix (".h") for language c is also defined for language c++. In that case, having each language inside its own project and individually imported to a master project allows such project architecture. .. index:: Separate_Suffix attribute **Separate_Suffix**: This attribute is specific to Ada. It denotes the suffix used in file names for files that contain subunits (separate bodies). If it is not specified, then it defaults to same value as ``Body_Suffix ("Ada")``. The value of this attribute cannot be the empty string. Otherwise, the same rules apply as for the ``Body_Suffix`` attribute. .. index:: Spec attribute .. index:: Specification attribute **Spec** or **Specification**: These attributes are equivalent. The ``Spec`` attribute can be used to define the source file name for a given Ada compilation unit's spec. The index is the literal name of the Ada unit (case insensitive). The value is the literal base name of the file that contains this unit's spec (case sensitive or insensitive depending on the operating system). This attribute allows the definition of exceptions to the general naming scheme, in case some files do not follow the usual convention. When a source file contains several units, the relative position of the unit can be indicated. The first unit in the file is at position 1. .. code-block:: gpr for Spec ("MyPack.MyChild") use "mypack.mychild.spec"; for Spec ("top") use "foo.a" at 1; for Spec ("foo") use "foo.a" at 2; .. index:: Body attribute .. index:: Implementation attribute **Body** or **Implementation**: These attribute play the same role as ``Spec``, but for Ada bodies. .. index:: Specification_Exceptions attribute .. index:: Implementation_Exceptions attribute **Specification_Exceptions** and **Implementation_Exceptions**: These attributes define exceptions to the naming scheme for languages other than Ada. They are indexed by the language name, and contain a list of file names respectively for headers and source code. As an example of several of these attributes, the following package models the Apex file naming rules: .. code-block:: gpr package Naming is for Casing use "lowercase"; for Dot_Replacement use "."; for Spec_Suffix ("Ada") use ".1.ada"; for Body_Suffix ("Ada") use ".2.ada"; end Naming; .. _Organizing_Projects_into_Subsystems: Organizing Projects into Subsystems =================================== A **subsystem** is a coherent part of the complete system to be built. It is represented by a set of sources and a single object directory. A system can consist of a single subsystem when it is simple as we have seen in the earlier examples. Complex systems are usually composed of several interdependent subsystems. A subsystem is dependent on another subsystem if knowledge of the other one is required to build it, and in particular if visibility on some of the sources of this other subsystem is required. Each subsystem is usually represented by its own project file. In this section, we'll enhance the previous example. Let's assume some sources of our ``Build`` project depend on other sources. For instance, when building a graphical interface, it is usual to depend upon a graphical library toolkit such as GtkAda. Furthermore, we also need sources from a logging module we had previously written. .. _Importing_Projects: Importing Projects ------------------ .. index:: Importing a project GtkAda comes with its own project file (appropriately called :file:`gtkada.gpr`), and we will assume we have already built a project called :file:`logging.gpr` for the logging module. With the information provided so far in :file:`build.gpr`, building the application would fail with an error indicating that the gtkada and logging units that are relied upon by the sources of this project cannot be found. This is solved by defining :file:`build.gpr` to *import* the gtkada and logging projects: this is done by adding the following |with| clauses at the beginning of our project: .. code-block:: gpr with "gtkada.gpr"; with "a/b/logging.gpr"; project Build is ... -- as before end Build; .. index:: Externally_Built attribute When such a project is compiled, *gprbuild* will automatically check the imported projects and recompile their sources when needed. It will also recompile the sources from `Build` when needed, and finally create the executable. In some cases, the implementation units needed to recompile a project are not available, or come from some third party and you do not want to recompile it yourself. In this case, set the attribute **Externally_Built** to :samp:`"true"`, indicating to the builder that this project can be assumed to be up-to-date, and should not be considered for recompilation. In Ada, if the sources of this externally built project were compiled with another version of the compiler or with incompatible options, the binder will issue an error. .. index:: with clause The project's |with| clause has several effects. It provides source visibility between projects during the compilation process. It also guarantees that the necessary object files from ``Logging`` and ``GtkAda`` are available when linking ``Build``. As can be seen in this example, the syntax for importing projects is similar to the syntax for importing compilation units in Ada. However, project files use literal strings instead of names, and the |with| clause identifies project files rather than packages. Each literal string after |with| is the path (absolute or relative) to a project file. The :file:`.gpr` extension is optional, but we recommend adding it. If no extension is specified, and no project file with the :file:`.gpr` extension is found, then the file is searched for exactly as written in the |with| clause, that is with no extension. As mentioned above, the path after a |with| has to be a literal string, and you cannot use concatenation, or lookup the value of external variables to change the directories from which a project is loaded. A solution if you need something like this is to use aggregate projects (see :ref:`Aggregate_Projects`). .. index:: Project path When a relative path or a base name is used, the project files are searched relative to each of the directories in the **project path**. This path includes all the directories found by the following procedure, in decreasing order of priority; the first matching file is used: * First, the file is searched relative to the directory that contains the current project file. * Then it is searched relative to all the directories specified in the environment variables :envvar:`GPR_PROJECT_PATH_FILE`, :envvar:`GPR_PROJECT_PATH` and :envvar:`ADA_PROJECT_PATH` (in that order) if they exist. The value of :envvar:`GPR_PROJECT_PATH_FILE`, when defined, is the path name of a text file that contains project directory path names, one per line. :envvar:`GPR_PROJECT_PATH` and :envvar:`ADA_PROJECT_PATH`, when defined, contain project directory path names separated by directory separators. :envvar:`ADA_PROJECT_PATH` is used for compatibility, it is recommended to use :envvar:`GPR_PROJECT_PATH_FILE` or :envvar:`GPR_PROJECT_PATH`. * Finally, it is searched relative to the default project directories. The following locations are searched, in the specified order: * :file:`///share/gpr` * :file:`///lib/gnat` * :file:`//share/gpr` * :file:`//lib/gnat` * :file:`/share/gpr/` * :file:`/lib/gnat/` The first two paths are only added if the explicit runtime is specified either via :option:`--RTS` switch or via ``Runtime`` attribute. can be communicated via :option:`--target` switch or ``Target`` attribute, otherwise default target will be used. is typically discovered automatically based on target, runtime and language information. In our example, :file:`gtkada.gpr` is found in the predefined directory if it was installed at the same root as GNAT. .. index:: -aP .. index:: -v (gprls) Some tools also support extending the project path from the command line, generally through the :option:`-aP`. You can see the value of the project path by using the ``gprls -v`` command. Any symbolic link will be fully resolved in the directory of the importing project file before the imported project file is examined. .. index:: --no-indirect-imports (gprbuild) Any source file in the imported project can be used by the sources of the importing project, transitively. Thus if `A` imports `B`, which imports `C`, the sources of `A` may depend on the sources of `C`, even if `A` does not import `C` explicitly. However, this is not recommended, because if and when `B` ceases to import `C`, some sources in `A` will no longer compile. *GPRbuild* has a switch :option:`--no-indirect-imports` that will report such indirect dependencies. .. index:: Project import closure .. _Project_Import_Closure: .. rubric:: Project import closure The :dfn:`project import closure` for a given project `proj` is the set of projects consisting of `proj` itself, together with each project that is directly or indirectly imported by `proj`. The import may be from either a |with| or, as will be explained below, a |limited_with|. .. note:: One very important aspect of a project import closure is that **a given source can only belong to one project** in this set (otherwise the project manager would not know which settings apply to it and when to recompile it). Thus different project files do not usually share source directories, or, when they do, they need to specify precisely which project owns which sources using the attribute *Source_Files* or equivalent. By contrast, two projects can each own a source with the same base file name as long as they reside in different directories. The latter is not true for Ada sources because of the correlation between source files and Ada units. .. index:: Cyclic project dependencies .. index:: Limited with (project import) .. _Cyclic_Project_Dependencies: Cyclic Project Dependencies --------------------------- In general, cyclic import dependencies are forbidden: if project `A` |withs| project `B` (directly or indirectly) then `B` is not allowed to |with| `A`. However, there are cases when cyclic dependencies at the project level are necessary, as dependencies at the source level may exist both ways between `A`'s sources and `B`'s sources. For these cases, another form of import between projects is supplied: the **limited with**. A project `A` that imports a project `B` with a simple |with| may also be imported, directly or indirectly, by `B` through a |limited_with|. The difference between a simple |with| and |limited_with| is that the name of a project imported with a |limited_with| cannot be used in the importing project. In particular, its packages cannot be renamed and its variables cannot be referenced. .. code-block:: gpr with "b.gpr"; with "c.gpr"; project A is for Exec_Dir use B'Exec_Dir; -- OK end A; limited with "a.gpr"; -- Cyclic dependency: A -> B -> A project B is for Exec_Dir use A'Exec_Dir; -- not OK end B; with "d.gpr"; project C is end C; limited with "a.gpr"; -- Cyclic dependency: A -> C -> D -> A project D is for Exec_Dir use A'Exec_Dir; -- not OK end D; .. _Sharing_between_Projects: Sharing between Projects ------------------------ When building an application, it is common to have similar needs in several of the projects corresponding to the subsystems under construction. For instance, they might all have the same compilation switches. As seen above (see :ref:`Tools_Options_in_Project_Files`), setting compilation switches for all sources of a subsystem is simple: it is just a matter of adding a ``Compiler'Default_Switches`` attribute to each project file with the same value. However, that would entail duplication of data, and both places would need to be changed in order to recompile the whole application with different switches. This may be a serious issue if there are many subsystems and thus many project files to edit. There are two main approaches to avoiding this duplication: * Since :file:`build.gpr` imports :file:`logging.gpr`, we could change the former to reference the attribute in Logging, either through a package renaming, or by referencing the attribute. The following example shows both cases: .. code-block:: gpr project Logging is package Compiler is for Switches ("Ada") use ("-O2"); end Compiler; package Binder is for Switches ("Ada") use ("-E"); end Binder; end Logging; with "logging.gpr"; project Build is package Compiler renames Logging.Compiler; package Binder is for Switches ("Ada") use Logging.Binder'Switches ("Ada"); end Binder; end Build; The solution used for `Compiler` gets the same value for all attributes of the package, but you cannot modify anything from the package (adding extra switches or some exceptions). The solution for the `Binder` package is more flexible, but more verbose. If you need to refer to the value of a variable in an imported project, rather than an attribute, the syntax is similar but uses a ``"."`` rather than an apostrophe. For instance: .. code-block:: gpr with "imported"; project Main is Var1 := Imported.Var; end Main; * The second approach is to define the switches in a separate project. That project does not contain any source files (thus, as opposed to the first example, none of the projects plays a special role), and will only be used to define the attributes. Such a project is typically named :file:`shared.gpr`. .. code-block:: gpr abstract project Shared is for Source_Files use (); -- no sources package Compiler is for Switches ("Ada") use ("-O2"); end Compiler; end Shared; with "shared.gpr"; project Logging is package Compiler renames Shared.Compiler; end Logging; with "shared.gpr"; project Build is package Compiler renames Shared.Compiler; end Build; As with the first example, we could have chosen to set the attributes one by one rather than to rename a package. The reason we explicitly indicate that `Shared` has no sources is so that it can be created in any directory, and we are sure it shares no sources with `Build` or `Logging`, which would be invalid. .. index:: Project qualifier .. index:: abstract project qualifier Note the additional use of the **abstract** qualifier in :file:`shared.gpr`. This qualifier is optional, but helps convey the message that we do not intend this project to have source files (see :ref:`Qualified_Projects` for additional information about project qualifiers). .. index:: Global attribute .. _Global_Attributes: Global Attributes ----------------- We have already seen many examples of attributes used to specify a particular option for one of the tools involved in the build process. Most of those attributes are project specific. That is to say, they only affect the invocation of tools on the sources of the project where they are defined. .. index:: Main project There are a few additional attributes that, when defined for a "main" project `proj`, also apply to all other projects in the project import closure of `proj`. A :dfn:`main project` is a project explicitly specified on the command line. Such attributes are known as :dfn:`global attributes`; here are several that are commonly used: .. index:: Global_Configuration_Pragmas attribute **Builder'Global_Configuration_Pragmas**: This attribute specifies a file that contains configuration pragmas to use when building executables. These pragmas apply to all executables built from this project import closure. As noted earlier, additional pragmas can be specified on a per-project basis by setting the ``Compiler'Local_Configuration_Pragmas`` attribute. .. index:: Global_Compilation_Switches attribute **Builder'Global_Compilation_Switches**: This attribute is a list of compiler switches that apply when compiling any source file in the project import closure. These switches are used in addition to the ones defined in the ``Compiler`` package, which only apply to the sources of the corresponding project. This attribute is indexed by the name of the language. Using such global capabilities is convenient, but care is needed since it can also lead to unexpected behavior. An example is when several subsystems are shared among different main projects but the different global attributes are not compatible. Note that using aggregate projects can be a safer and more powerful alternative to global attributes. .. index Scenarios .. _Scenarios_in_Projects: Scenarios in Projects ===================== Various project properties can be modified based on **scenarios**. These are user-defined modes (the values of project variables and attributes) that determine the behavior of a project, based on the values of externally defined variables. Typical examples are the setup of platform-specific compiler options, or the use of a debug and a release mode (the former would activate the generation of debug information, while the latter would request an increased level of code optimization). Let's enhance our example to support debug and release modes. The issue is to let the user choose which kind of system to build: use :option:`-g` as a compiler switch in debug mode and :option:`-O2` in release mode. We will also set up the projects so that we do not share the same object directory in both modes; otherwise switching from one to the other might trigger more recompilations than needed or mix objects from the two modes. One approach is to create two different project files, say :file:`build_debug.gpr` and :file:`build_release.gpr`, that set the appropriate attributes as explained in previous sections. This solution does not scale well, because in the presence of multiple projects depending on each other, you will also have to duplicate the complete set of projects and adapt the project files accordingly. .. index:: External variable Instead, project files support the notion of scenarios controlled by the values of externally defined variables. Such values can come from several sources (in decreasing order of priority): .. index:: -X **Command line**: When launching *gprbuild*, the user can pass :option:`-X` switches to define the external variables. In our case, the command line might look like .. code-block:: sh gprbuild -Pbuild.gpr -Xmode=release which defines the external variable named :samp:`mode` and sets its value to :samp:`"release"`. .. index:: Environment variable in scenarios **Environment variables**: When the external value does not come from the command line, it can come from the value of an environment variable of the appropriate name. In our case, if an environment variable named :samp:`mode` exists, its value will be used. .. index:: external function **Tool mode**: In the special case of the ``GPR_TOOL`` variable, if its value has not been specified via the command line or as an environment variable, the various tools set this variable to a value proper to each tool. gprbuild sets this value to ``gprbuild``. See the documentation of other tools to find out which value they set this variable to. **External function second parameter**. Once an external variable is defined, its value needs to be obtained by the project. The general form is to use the predefined function :samp:`external`, which returns the current value of the external variable. For instance, we could set up the object directory to point to either :file:`obj/debug` or :file:`obj/release` by changing our project to .. code-block:: gpr project Build is for Object_Dir use "obj/" & external ("mode", "debug"); ... -- as before end Build; The second parameter to :samp:`external` is optional, and is the default value to use if :samp:`mode` is not set from the command line or the environment. If the second parameter is not supplied, and there is no external or environment variable named by the first parameter, then an error is reported. In order to set the switches according to the different scenarios, other constructs are needed, such as typed variables and case constructions. .. index:: Typed variable .. index:: Case construction A **typed variable** is a variable that can take only a limited number of values, similar to variable from an enumeration type in Ada. Such a variable can then be used in a **case construction**, resulting in conditional sections in the project. The following example shows how this can be done: .. code-block:: gpr project Build is type Mode_Type is ("debug", "release"); -- all possible values Mode : Mode_Type := external ("mode", "debug"); -- a typed variable package Compiler is case Mode is when "debug" => for Switches ("Ada") use ("-g"); when "release" => for Switches ("Ada") use ("-O2"); end case; end Compiler; end Build; This project is larger than the ones we have seen previously, but it has become much more flexible. The :samp:`Mode_Type` type defines the only valid values for the :samp:`Mode` variable. If any other value is read from the environment, an error is reported and the project is considered as invalid. The ``Mode`` variable is initialized with an external value defaulting to :samp:`"debug"`. This default could be omitted and that would force the user to define the value. Finally, we can use a case construction to set the switches depending on the scenario the user has chosen. Most aspects of a project can depend on scenarios. The notable exception is the identity of an imported project (via a |with| or |limited_with| clause), which cannot depend on a scenario. Scenarios work analogously across projects in a project import closure. You can either duplicate a variable similar to :samp:`Mode` in each of the projects (as long as the first argument to :samp:`external` is always the same and the type is the same), or simply set the variable in the :file:`shared.gpr` project (see :ref:`Sharing_Between_Projects`). .. index:: Library project .. _Library_Projects: Library Projects ================ So far, we have seen examples of projects that create executables. However, it is also possible to create libraries instead. A **library** is a specific type of subsystem where, for convenience, objects are grouped together using system-specific means such as archives or Windows DLLs. Library projects provide a system- and language-independent way of building both **static** and **dynamic** libraries. They also support the concept of **standalone libraries** (SAL) which offer two significant properties: the elaboration (e.g. initialization) of the library is either automatic or very simple; a change in the implementation part of the library implies minimal post-compilation actions on the complete system and potentially no action at all for the rest of the system in the case of dynamic SALs. There is a restriction on shared library projects: by default, they are only allowed to import other shared library projects. They are not allowed to import non-library projects or static library projects. The GNAT Project Manager takes complete care of the library build, rebuild and installation tasks, including recompilation of the source files for which objects do not exist or are not up to date, assembly of the library archive, and installation of the library (i.e., copying associated source, object and :file:`ALI` files to the specified location). .. _Building_Libraries: Building Libraries ------------------ Let's enhance our example and transform the `logging` subsystem into a library. In order to do so, a few changes need to be made to :file:`logging.gpr`. Some attributes need to be defined: at least `Library_Name` and `Library_Dir`; in addition, some other attributes can be used to specify specific aspects of the library. For readability, it is also recommended (although not mandatory), to use the qualifier `library` in front of the `project` keyword. .. index:: Library_Name attribute **Library_Name**: This attribute is the name of the library to be built. There is no restriction on the name of a library imposed by the project manager, except for stand-alone libraries whose names must follow the syntax of Ada identifiers; however, there may be system-specific restrictions on the name. In general, we recommend using only alphanumeric characters (and possibly single underscores), to help portability. .. index:: Library_Dir attribute **Library_Dir**: This attribute is the path (absolute or relative) of the directory where the library is to be installed. In the process of building a library, the sources are compiled and the object files are placed in the explicitly- or implicitly specified :file:`Object_Dir` directory. When all sources of a library are compiled, some of the compilation artifacts, including the library itself, are copied to the library_dir directory. This directory must exist and be writable. It must also be different from the object directory so that cleanup activities in the Library_Dir do not affect recompilation needs. Here is the new version of :file:`logging.gpr` that makes it a library: .. code-block:: gpr library project Logging is -- "library" is optional for Library_Name use "logging"; -- will create "liblogging.a" on Unix for Object_Dir use "obj"; for Library_Dir use "lib"; -- different from object_dir end Logging; Once the above two attributes are defined, the library project is valid and is sufficient for building a library with default characteristics. Other library-related attributes can be used to change the defaults: .. index:: Library_Kind attribute **Library_Kind**: The value of this attribute must be either :samp:`"static"`, :samp:`"static-pic"`, :samp:`"dynamic"` or :samp:`"relocatable"` (the last is a synonym for :samp:`"dynamic"`). It indicates which kind of library should be built (the default is to build a static library, that is an archive of object files that can potentially be linked into a static executable). A static-pic library is also an archive, but the code is Position Independent Code, usually compiled with the switch -fPIC. When the library is set to be dynamic, a separate image is created that will be loaded independently, usually at the start of the main program execution. Support for dynamic libraries is very platform specific, for instance on Windows it takes the form of a DLL while on GNU/Linux, it is a dynamic `elf` image whose suffix is usually :file:`.so`. Library project files, on the other hand, can be written in a platform independent way so that the same project file can be used to build a library on different operating systems. If you need to build both a static and a dynamic library, we recommend using two different object directories, since in some cases some extra code needs to be generated for the latter. For such cases, one can either define two different project files, or a single one that uses scenarios to indicate the various kinds of library to be built and their corresponding object_dir. .. index:: Library_ALI_Dir attribute **Library_ALI_Dir**: This attribute may be specified to indicate the directory where the ALI files of the library are installed. By default, they are copied into the :file:`Library_Dir` directory, but as for the executables where we have a separate `Exec_Dir` attribute, you might want to put them in a separate directory since there may be hundreds of such files. The same restrictions as for the :samp:`Library_Dir` attribute apply. .. index:: Library_Version attribute **Library_Version**: This attribute is platform dependent, and has no effect on Windows. On Unix, it is used only for dynamic libraries as the internal name of the library (the "soname"). If the library file name (built from the ``Library_Name``) is different from the ``Library_Version``, then the library file will be a symbolic link to the actual file whose name will be ``Library_Version``. This follows the usual installation schemes for dynamic libraries on many Unix systems. .. code-block:: gpr project Logging is Version := "1"; for Library_Dir use "lib"; for Library_Name use "logging"; for Library_Kind use "dynamic"; for Library_Version use "liblogging.so." & Version; end Logging; After the compilation, the directory :file:`lib` will contain both a :file:`liblogging.so.1` library and a symbolic link to it called :file:`liblogging.so`. .. index:: Library_GCC attribute **Library_GCC**: This attribute is the name of the tool to use instead of ``gcc`` to link shared libraries. A common use of this attribute is to define a wrapper script that accomplishes specific actions before calling ``gcc`` (which itself calls the linker to build the library image). .. index:: Library_Options attribute **Library_Options**: This attribute may be used to specify additional switches ("last switches") when linking a shared library or a static standalone library. In the case of a simple static library, the values for this attribute are restricted to paths to object files. Those paths may be absolute or relative to the object directory. .. index:: Leading_Library_Options attribute **Leading_Library_Options**: This attribute, which is taken into account only by *GPRbuild*, may be used to specify leading options ("first switches") when linking a shared library. .. _Using_Library_Projects: Using Library Projects ---------------------- When the builder detects that a project file is a library project file, it recompiles all sources of the project that need recompilation and rebuilds the library if any of the sources have been recompiled. It then groups all object files into a single file, which is a shared or a static library. This library can later on be linked with multiple executables. Note that the use of shared libraries reduces the size of the final executable and can also reduce the memory footprint at execution time when the library is shared among several executables. *GPRbuild* also allows building **multi-language libraries** when specifying sources from multiple languages. A non-library project `NLP` can import a library project `LP`. When the builder is invoked on `NLP`, it always rebuilds `LP` even if all of the latter's files are up to date. For instance, let's assume in our example that ``logging`` has the following sources: :file:`log1.ads`, :file:`log1.adb`, :file:`log2.ads` and :file:`log2.adb`. If :file:`log1.adb` has been modified, then the library :file:`liblogging` will be rebuilt when compiling all the sources of ``Build`` even if :file:`proc.ads`, :file:`pack.ads` and :file:`pack.adb` do not include a ``"with Log1"``. To ensure that all the sources in the ``Logging`` library are up to date, and that all the sources of ``Build`` are also up to date, the following two commands need to be used: .. code-block:: sh gprbuild -Plogging.gpr gprbuild -Pbuild.gpr All :file:`ALI` files will also be copied from the object directory to the library directory. To build executables, *GPRbuild* will use the library rather than the individual object files. .. index:: Externally_Built attribute Library projects can also be useful to specify a library that needs to be used but, for some reason, cannot be rebuilt. Such a situation may arise when some of the library sources are not available. Such library projects need to use the ``Externally_Built`` attribute as in the example below: .. code-block:: gpr library project Extern_Lib is for Languages use ("Ada", "C"); for Source_Dirs use ("lib_src"); for Library_Dir use "lib2"; for Library_Kind use "dynamic"; for Library_Name use "l2"; for Externally_Built use "true"; -- <<<< end Extern_Lib; In the case of externally built libraries, the ``Object_Dir`` attribute does not need to be specified because it will never be used. The main effect of using such an externally built library project is mostly to affect the linker command in order to reference the desired library. It can also be achieved by using ``Linker'Linker_Options`` or ``Linker'Switches`` in the project corresponding to the subsystem needing this external library. This latter method is more straightforward in simple cases but when several subsystems depend upon the same external library, finding the proper place for the ``Linker'Linker_Options`` might not be easy and if it is not placed properly, the final link command is likely to present ordering issues. In such a situation, it is better to use the externally built library project so that all other subsystems depending on it can declare this dependency through a project |with| clause, which in turn will trigger the builder to find the proper order of libraries in the final link command. .. _Stand-alone_Library_Projects: Stand-alone Library Projects ---------------------------- .. index:: Stand-alone libraries A **stand-alone library** is a library that contains the necessary code to elaborate the Ada units that are included in the library. A stand-alone library is a convenient way to add an Ada subsystem to a more global system whose main is not in Ada since it makes the elaboration of the Ada part mostly transparent. However, stand-alone libraries are also useful when the main is in Ada: they provide a means for minimizing relinking and redeployment of complex systems when localized changes are made. The name of a stand-alone library, specified with attribute ``Library_Name``, must have the syntax of an Ada identifier. The most prominent characteristic of a stand-alone library is that it offers a distinction between interface units and implementation units. Only the former are visible to units outside the library. A stand-alone library project is thus characterized by a third attribute, usually ``Library_Interface``, in addition to the two attributes that make a project a Library Project (`Library_Name` and `Library_Dir`). This third attribute may also be ``Interfaces``. ``Library_Interface`` only works when the interface is in Ada and takes a list of units as parameter. ``Interfaces`` works for any supported language and takes a list of sources as parameter. .. index:: Library_Interface attribute **Library_Interface**: This attribute defines an explicit subset of the units of the project. Units from projects importing this library project may only "with" units whose sources are listed in the `Library_Interface`. Other sources are considered implementation units. .. code-block:: gpr for Library_Dir use "lib"; for Library_Name use "logging"; for Library_Interface use ("lib1", "lib2"); -- unit names .. index:: Interfaces attribute **Interfaces** This attribute defines an explicit subset of the source files of a project. Sources from projects importing this project, can only depend on sources from this subset. This attribute can be used on non library projects. It can also be used as a replacement for attribute ``Library_Interface``, in which case, units have to be replaced by source files. For multi-language library projects, it is the only way to make the project a Stand-Alone Library project whose interface is not purely Ada. .. index:: Library_Standalone attribute **Library_Standalone**: This attribute defines the kind of stand-alone library to build. Values are either ``standard`` (the default), ``no`` or ``encapsulated``. When ``standard`` is used the code to elaborate and finalize the library is embedded, when ``encapsulated`` is used the library can furthermore depend only on static libraries (including the GNAT runtime). This attribute can be set to ``no`` to make it clear that the library should not be stand-alone in which case the ``Library_Interface`` should not defined. Note that this attribute only applies to shared libraries, so ``Library_Kind`` must be set to `dynamic` or `relocatable`. .. code-block:: gpr for Library_Dir use "lib"; for Library_Name use "logging"; for Library_Kind use "dynamic"; for Library_Interface use ("lib1", "lib2"); -- unit names for Library_Standalone use "encapsulated"; In order to include the elaboration code in the stand-alone library, the binder is invoked on the closure of the library units creating a package whose name depends on the library name (:file:`b~logging.ads/b` in the example). This binder-generated package includes **initialization** and **finalization** procedures whose names depend on the library name (``logginginit`` and ``loggingfinal`` in the example). The object corresponding to this package is included in the library. .. index:: Library_Auto_Init attribute **Library_Auto_Init**: A dynamic stand-alone Library is automatically initialized if automatic initialization of stand-alone Libraries is supported on the platform and if attribute ``Library_Auto_Init`` is not specified or is specified with the value ``"true"``. Whether a static stand-alone Library is automatically initialized is platform dependent. Specifying ``"false"`` for the ``Library_Auto_Init`` attribute prevents automatic initialization. When a non-automatically initialized stand-alone library is used in an executable, its initialization procedure must be called before any service of the library is used. When the main subprogram is in Ada, it may mean that the initialization procedure has to be called during elaboration of another package. .. index:: Library_Dir attribute **Library_Dir**: For a stand-alone library, only the :file:`ALI` files of the interface units (those that are listed in attribute `Library_Interface`) are copied to the library directory. As a consequence, only the interface units may be imported from Ada units outside of the library. If other units are imported, the binding phase will fail. .. index:: Binder'Default_Switches attribute .. index:: Default_Switches attribute **Binder'Default_Switches**: When a stand-alone library is bound, the switches that are specified in the attribute ``Binder'Default_Switches ("Ada")`` are used in the call to *gnatbind*. .. index:: Library_Src_Dir attribute **Library_Src_Dir**: This attribute defines the location (absolute or relative to the project directory) where the sources of the interface units are copied at installation time. These sources includes the specs of the interface units along with the closure of sources necessary to compile them successfully. That may include bodies and subunits, when pragmas `Inline` are used, or when there are generic units in specs. This directory cannot point to the object directory or one of the source directories, but it can point to the library directory, which is the default value for this attribute. .. index:: Library_Symbol_Policy attribute **Library_Symbol_Policy**: This attribute controls the export of symbols on some platforms (like Windows, GNU/Linux). It is not supported on all platforms (where it will just have no effect). It may have one of the following values: * ``"restricted"``: The exported symbols will be restricted to the one from the interface of the stand-alone library. This is either computed automatically or using the ``Library_Symbol_File`` if specified. * ``"unrestricted"``: All symbols from the stand-alone library are exported. .. index:: Library_Symbol_File attribute **Library_Symbol_File** This attribute may define the name of the symbol file to be used when building a stand-alone library when the symbol policy is ``"restricted"``, on platforms that support symbol control. This file must contain one symbol per line and only those symbols will be exported from the stand-alone library. .. _Installing_a_Library_with_Project_Files: Installing a Library with Project Files --------------------------------------- When using project files, a usable version of the library is created in the directory specified by the ``Library_Dir`` attribute of the library project file. Thus no further action is needed in order to make use of the libraries that are built as part of the general application build. You may want to install a library in a context different from where the library is built. This situation arises with third party suppliers, who may want to distribute a library in binary form where the user is not expected to be able to recompile the library. The simplest option in this case is to provide a project file slightly different from the one used to build the library, by using the ``Externally_Built`` attribute. See :ref:`Using_Library_Projects`. .. index:: gprinstall tool Another option is to use *gprinstall* to install the library in a different context than the build location. The *gprinstall* tool automatically generates a project to use this library, and also copies the minimum set of sources needed to use the library to the install location. See :ref:`Package_Install_Attributes`. .. index:: Project extension .. index:: Extending a project .. _Project_Extension: Project Extension ================= During development of a large system, it is sometimes necessary to use modified versions of some of the source files, without changing the original sources. This can be achieved through the *project extension* facility. Suppose that our example ``Build`` project is built every night for the whole team, in some shared directory. A developer usually needs to work on a small part of the system, and might not want to have a copy of all the sources and all the object files since that could require too much disk space and too much time to recompile everything. A better approach is to override some of the source files in a separate directory, while still using the object files generated at night for the non-overridden shared sources. Another use case is a large software system with multiple implementations of a common interface; in Ada terms, multiple versions of a package body for the same spec, or perhaps different versions of a package spec that have the same visible part but different private parts. For example, one package might be safe for use in tasking programs, while another might be used only in sequential applications. A third example is different versions of the same system. For instance, assume that a ``Common`` project is used by two development branches. One of the branches has now been frozen, and no further change can be done to it or to ``Common``. However, on the other development branch the sources in ``Common`` are still evolving. A new version of the subsystem is needed, which reuses as much as possible from the original. .. index:: Base project Each of these can be implemented in GNAT using **project extension**: If one project *extends* another project (the *base project*) then by default all source files of the base project are inherited by the extending project, but the latter can override any of the base project's source files with a new version, and can also add new files or remove unnecessary ones. A project can extend at most one base project. This facility is somewhat analogous to class extension (with single inheritance) in object-oriented programming. Project extension hierarchies are permitted (an extending project may itself serve as a base project and be extended), and a project that extends a project can also import other projects. An extending project implicitly inherits all the sources and objects from its base project. It is possible to create a new version of some of the sources in one of the additional source directories of the extending project. Those new versions hide the original versions. As noted above, adding new sources or removing existing ones is also possible. Here is an example of how to extend the project `Build` from previous examples: .. code-block:: gpr project Work extends "../bld/build.gpr" is end Work; The project after the ``extends`` keyword is the base project being extended. As usual, it can be specified using an absolute path, or a path relative to any of the directories in the project path. The ``Work`` project does not specify source or object directories, so the default values for these attributes will be used; that is, the current directory (where project ``Work`` is placed). We can compile that project with .. code-block:: sh gprbuild -Pwork If no sources have been placed in the current directory, this command has no effect, since this project does not change the sources it inherited from ``Build`` and thus all the object files in ``Build`` and its dependencies are still valid and are reused automatically. Suppose we now want to supply an alternative version of :file:`pack.adb` but use the existing versions of :file:`pack.ads` and :file:`proc.adb`. We can create the new file in the ``Work`` project's directory (for example by copying the one from the ``Build`` project and making changes to it). If new packages are needed at the same time, we simply create new files in the source directory of the extending project. When we recompile, *GPRbuild* will now automatically recompile this file (thus creating :file:`pack.o` in the current directory) and any file that depends on it (thus creating :file:`proc.o`). Finally, the executable is also linked locally. Note that we could have obtained the desired behavior using project import rather than project inheritance. Some project ``proj`` would contain the sources for :file:`pack.ads` and :file:`proc.adb`, and ``Work`` would import ``proj`` and add :file:`pack.adb`. In this situation ``proj`` cannot contain the original version of :file:`pack.adb` since otherwise two versions of the same unit would be in project import closure of ``proj``, which is not allowed. In general we do not recommended placing the spec and body of a unit in different projects, since this affects their autonomy and reusability. In a project file that extends another project, it is possible to indicate that an inherited source is **not part** of the sources of the extending project. This is necessary, for example, when a package spec has been overridden in such a way that a body is forbidden. In this case, it is necessary to indicate that the inherited body is not part of the sources of the project, otherwise there will be a compilation error. .. index:: Excluded_Source_Files attribute .. index:: Excluded_Source_List_File attribute Two attributes are available for this purpose: * **Excluded_Source_Files**, whose value is a list of file names, and * **Excluded_Source_List_File**, whose value is the path of a text file containing one file name per line. .. code-block:: gpr project Work extends "../bld/build.gpr" is for Source_Files use ("pack.ads"); -- New spec of Pkg does not need a completion for Excluded_Source_Files use ("pack.adb"); end Work; All tool packages that are not declared in the extending project are inherited from the base project, with their attributes, with the exception of ``Linker'Linker_Options`` which is never inherited. In particular, an extending project retains all the switches specified in its base project. At the project level, if they are not declared in the extending project, some attributes are inherited from the base project. They are: ``Languages``, ``Main`` (for a root non library project) and ``Library_Name`` (for a project extending a library project). .. _Importing_and_Project_Extension: Importing and Project Extension ------------------------------- One of the fundamental restrictions for project extension is the following: **A project is not allowed to import, directly or indirectly, both an extending project P and also some project that P extends either directly or indirectly** In the absence of this rule, two imports might access different versions of the same source file, or different sets of tool switches for the same source file (one from the base project and the other from an extending project). As an example of this problem, consider the following set of project files: * :file:`a.gpr` which contains the source files :file:`foo.ads` and :file:`foo.adb`, among others * :file:`b.gpr` which imports :file:`a.gpr` (one of its source files |withs| ``foo``) * :file:`c.gpr` which imports :file:`b.gpr` Suppose we want to extend the projects as follows: * :file:`a_ext.gpr` extends :file:`a.gpr` and overrides :file:`foo.adb` * :file:`c_ext.gpr` extends :file:`c.gpr`, overriding one of its source files Since :file:`c_ext.gpr` needs to access sources in :file:`b.gpr`, it will import :file:`b.gpr` Finally, :file:`main.gpr` needs to access the overridden source files in :file:`a_ext.gpr` and :file:`c_ext.gpr` and thus will import these two projects. .. only:: html or latex This project structure is shown in :numref:`figure #`. .. _fig-badproject: .. figure:: importing_and_project_extension_figure_1.png :figwidth: image :align: center Example of Source File Ambiguity from `imports`/`extends` Violation .. only:: not (html or latex) This project structure is as follows: :: +-imports--> a_ext.gpr ---extends-----> a.gpr | ^ | | | |imports | | main.gpr +--------imports-----> b.gpr | | ^ | | | | | |imports | | | +-imports--> c_ext.gpr-----extends----> c.gpr This violates the restriction above, since :file:`main.gpr` imports the extending project :file:`a_ext.gpr` and also (indirectly through :file:`c_ext.gpr` and :file:`b.gpr`) the project :file:`a.gpr` that :file:`a_ext.gpr` extends. The problem is that the import path through :file:`c_ext.gpr` and :file:`b.gpr` would build with the version of :file:`foo.adb` from :file:`a.gpr`, whereas the import path through :file:`a_ext.gpr` would use that project's version of :file:`foo.adb`. The error will be detected and reported by ``gprbuild``. A solution is to introduce an "empty" extension of :file:`b.gpr`, which is imported by :file:`c_ext.gpr` and imports :file:`a_ext.gpr`: .. code-block:: gpr with "a_ext.gpr"; project B_Ext extends "b.gpr" is end B_Ext; .. only:: html or latex This project structure is shown in :numref:`figure #`. .. _fig-goodproject: .. figure:: importing_and_project_extension_figure_2.png :figwidth: image :align: center Using "Empty" Project Extension to Avoid `imports`/`extends` Violation .. only:: not (html or latex) This project structure is as follows: :: +-imports--> a_ext.gpr ---extends-----> a.gpr | ^ ^ | | | | |imports |imports | | | main.gpr b_ext.gpr-----extends----> b.gpr | ^ ^ | | | | |imports |imports | | | +-imports--> c_ext.gpr-----extends----> c.gpr There is now no ambiguity over which version of :file:`foo.adb` to use; it will be the one from :file:`a_ext.gpr`. .. index:: extends all When extending a large system spanning multiple projects, it is often inconvenient to extend every project in the project import closure that is impacted by a small change introduced in a low layer. In such cases, it is possible to create an **implicit extension** of an entire hierarchy using the **extends all** relationship. When a project ``P`` is extended using `extends all` inheritance, all projects that are imported by ``P``, both directly and indirectly, are considered virtually extended. That is, the project manager creates implicit projects that extend every project in the project import closure; all these implicit projects do not control sources on their own and use the object directory of the `extends all` project. It is possible to explicitly extend one or more projects in the import closure in order to adapt the sources. These extending projects must be imported by the ``extends all`` project, which will replace the corresponding virtual projects with the explicit ones. When building such a project closure extension, the project manager will ensure recompilation of both the modified sources and the sources in implicit extending projects that depend on them. To illustrate the ``extends all`` feature, here's a slight variation on the earlier examples. We have a ``Main`` project that imports project ``C``, which imports ``B``, which imports ``A``. The source files in ``Main`` refer to compilation units whose sources are in ``C`` and ``A``. (Recall that ``imports`` is transitive, so ``A`` is implicitly accessible in ``Main``.) .. only:: html or latex This project structure is shown in :numref:`figure #`. .. _fig-simpleproject: .. figure:: importing_and_project_extension_figure_3.png :figwidth: image :align: center Simple Project Structure before Extension .. only:: not (html or latex) Thus: :: a.gpr ^ | |imports | b.gpr ^ | |imports | c.gpr ^ | |imports | main.gpr Suppose that we want to extend :file:`a.gpr`, overriding one of its source files, and create a new version of :file:`main.gpr` that can access the overridden file in the extending project :file:`a_ext.gpr` and otherwise use the sources in :file:`b.gpr` and :file:`c.gpr`. Instead of explicitly defining empty projects to extend :file:`b.gpr` and :file:`c.gpr`, we can create a new project :file:`main_ext.gpr` that does an ``extends all`` of :file:`main.gpr` and imports :file:`a_ext.gpr`. The ``extends_all`` will implicitly create the empty projects :file:`b_ext.gpr` and :file:`c_ext.gpr` as well as the relevant import relationships: * :file:`c_ext.gpr` will import :file:`b_ext.gpr`, which will import :file:`a_ext.gpr` * :file:`main_ext.gpr` will implicitly import :file:`c_ext.gpr` since :file:`main.gpr` imports :file:`c.gpr`. .. only:: html or latex The resulting project structure is shown in :numref:`figure #`, where the italicized labels, dashed arrows, and dashed boxes indicate what was added implicitly as an effect of the ``extends_all``. .. _fig-extends_all: .. figure:: importing_and_project_extension_figure_4.png :figwidth: image :align: center Project Structure with ``extends_all`` .. only:: not (html or latex) Thus: :: a.gpr <--- extends --- a_ext.gpr <-------+ ^ ^ | | | | imports [imports] imports | | | b.gpr <-- [extends] -- [b_ext.gpr] main_ext.gpr --+ ^ ^ | | | | | | imports [imports] [imports] | | | | | c.gpr <--- extends --- [c_ext.gpr] <-----+ | ^ | | | imports | | | main.gpr <-------- extends_all-----------------------+ where the bracketed elements indicate what was created automatically as an effect of the ``extends_all``. When project :file:`main_ext.gpr` is built, the entire modified project space is considered for recompilation, including the sources from :file:`b.gpr` and :file:`c.gpr` that are affected by the changes to :file:`a.gpr`. .. index:: Child project .. index:: Parent project .. _Child_Projects: Child Projects ============== In order to more clearly express the relationship between a project ``Q`` and some other project ``P`` that ``Q`` either imports or extends, you can use the notation ``P.Q`` to declare ``Q`` as a **child** of ``P``. The project ``P`` is then referred to as the **parent** of ``Q``. This is useful, for example, when the purpose of the child is to serve as a testing subsystem for the parent. The visibility of the child on the sources and other properties of the parent is determined by whether the child imports or extends the parent. No additional visibility is obtained by declaring the project as a child; the `parent.child` notation serves solely as a naming convention to convey to the reader the closeness of the relationship between the projects. For example: .. code-block:: gpr -- math_proj.gpr project Math_Proj is ... end Math_Proj; --------------- with "math_proj.gpr"; project Math_Proj.Tests is -- Legal; child imports parent ... end Math_Proj.Tests; --------------- project Math_Proj.High_Performance extends "math_proj.gpr" is -- Legal; child extends parent ... end Math_Proj.High_Performance; --------------- project GUI_Proj.Tests is -- Illegal ... end GUI_Proj.Tests; Child projects may in turn be the parents of other projects, so in general a project hierarchy can be created. A project may be the parent of many child projects, but a child project can only have one parent. Note that child projects have slightly different semantics from their Ada language analog (child units). An Ada child unit implicitly |withs| its parent, whereas a child project must have an explicit |with| clause (or else extend its parent). The need to explicitly |with| or extend the parent project helps avoid the error of unintentionally creating a child of some project that happens to be on the project path. .. index:: Aggregate project .. _Aggregate_Projects: Aggregate Projects ================== Aggregate projects are an extension of the project paradigm, and are designed to handle a few specific situations that cannot be solved directly using standard projects. This section will present several such use cases. .. _Building_all_main_programs_from_a_single_project_closure: Building all main programs from a single project closure -------------------------------------------------------- A large application is typically organized into modules and submodules, which are conveniently represented as a project graph (the project import closure): a "root" project `A` |withs| the projects for modules `B` and `C`, which in turn |with| projects for submodules. Very often, modules will build their own executables (for testing purposes for instance) or libraries (for easier reuse in various contexts). However, if you build your project through *GPRbuild*, using a syntax similar to :: gprbuild -PA.gpr this will only rebuild the main programs of project A, not those of the imported projects B and C. Therefore you have to spawn several *GPRbuild* commands, one per project, to build all executables. This is somewhat inconvenient, but more importantly is inefficient because *GPRbuild* needs to do duplicate work to ensure that sources are up-to-date, and cannot easily compile things in parallel when using the :option:`-j` switch. Also, libraries are always rebuilt when building a project. To solve this problem you can define an *aggregate project* ``Agg`` that groups ``A``, ``B`` and ``C``: .. index:: Project_Files attribute .. code-block:: gpr aggregate project Agg is for Project_Files use ("a.gpr", "b.gpr", "c.gpr"); end Agg; Then, when you build with :: gprbuild -PAgg.gpr this will build all main programs from ``A``, ``B`` and ``C``. If `B` or `C` do not define any main program (through their `Main` attribute), all their sources are built. When you do not group them in an aggregate project, only those sources that are needed by `A` will be built. If you add a main to a project ``P`` not already explicitly referenced in the aggregate project, you will need to add :file:`p.gpr` in the list of project files for the aggregate project, or the main will not be built when building the aggregate project. .. _Building_a_set_of_projects_with_a_single_command: Building a set of projects with a single command ------------------------------------------------ Another application of aggregate projects is when you have multiple applications and libraries that are built independently (but can be built in parallel). For instance, you might have a project graph rooted at ``A``, and another one (which might share some subprojects) rooted at ``B``. Using only *GPRbuild*, you could do .. code-block:: sh gprbuild -PA.gpr gprbuild -PB.gpr to build both. But again, *GPRbuild* has to do some duplicate work for those files that are shared between the two, and cannot truly build things in parallel efficiently. If the two projects are really independent, share no sources other than through a common subproject, and have no source files with a common basename, you could create a project ``C`` that imports ``A`` and ``B``. But these restrictions are often too strong, and one has to build them independently. An aggregate project does not have these limitations and can aggregate two project graphs that have common sources: .. code-block:: gpr aggregate project Agg is for Project_Files use ("a.gpr", "b.gpr"); end Agg; This scenario is particularly useful in environments like VxWorks 653 where the applications running in the multiple partitions can be built in parallel through a single *GPRbuild* command. This also works well with Annex E of the Ada Language Reference Manual. .. _Defining_a_build_environment: Defining a build environment ---------------------------- The environment variables at the time you launch *GPRbuild* will influence the view these tools have of the project (for example :envvar:`PATH` to find the compiler, :envvar:`ADA_PROJECT_PATH` or :envvar:`GPR_PROJECT_PATH` to find the projects, and environment variables that are referenced in project files through the ``external`` built-in function). Several command line switches can be used to override those (:option:`-X` or :option:`-aP`), but on some systems and with some projects, this might make the command line too long, and on all systems often make it hard to read. An aggregate project can be used to set the environment for all projects built through that aggregate. One of the benefits is that you can put the aggregate project under configuration management, and make sure all your users have a consistent environment when building. For example: .. code-block:: gpr aggregate project Agg is for Project_Files use ("A.gpr", "B.gpr"); for Project_Path use ("../dir1", "../dir1/dir2"); for External ("BUILD") use "PRODUCTION"; package Builder is for Global_Compilation_Switches ("Ada") use ("-g"); end Builder; end Agg; Another use of aggregate projects is to simulate the referencing of external variables in |with| clauses, For technical reasons the following project file is not allowed: .. code-block:: gpr with external("SETUP") & "path/prj.gpr"; -- ILLEGAL project MyProject is ... end MyProject; However, you can use aggregate projects to obtain an equivalent effect: .. code-block:: gpr aggregate project Agg is for Project_Path use (external("SETUP") & "path"); for Project_Files use ("myproject.gpr"); end Agg; .. code-block:: gpr with "prj.gpr"; -- searched on Agg'Project_Path project MyProject is ... end MyProject; .. _Improving_builder_performance: Improving builder performance ----------------------------- The loading of aggregate projects is optimized in *GPRbuild*, so that all files are searched for only once on the disk (thus reducing the number of system calls and yielding faster compilation times, especially on systems with sources on remote servers). As part of the loading, *GPRbuild* computes how and where a source file should be compiled, and even if it is located several times in the aggregated projects it will be compiled only once. .. index:: -j Since there is no ambiguity as to which switches should be used, individual compilations, binds and links can be performed in parallel (through the usual :option:`-j` switch) and this can be done while maximizing the use of CPUs (compared to launching multiple *GPRbuild* commands in parallel). The -j option can control parallelization of compilation, binding, and linking separately with -jc, -jb, and -jl variants accordingly. .. _Syntax_of_aggregate_projects: Syntax of aggregate projects ---------------------------- An aggregate project follows the general syntax of project files. The recommended extension is still :file:`.gpr`. However, a special ``aggregate`` qualifier must appear before the keyword ``project``. An aggregate project cannot |with| any other project (standard or aggregate), except an abstract project (which can be used to share attribute values). Also, aggregate projects cannot be extended or imported though a |with| clause by any other project. Building other aggregate projects from an aggregate project is done through the ``Project_Files`` attribute (see below). An aggregate project does not have any source files directly (only through other standard projects). Therefore a number of the standard attributes and packages are forbidden in an aggregate project. Here is a (non exhaustive) list: * ``Languages`` * ``Source_Files``, ``Source_List_File`` and other attributes dealing with list of sources. * ``Source_Dirs`` and ``Exec_Dir`` * ``Library_Dir``, ``Library_Name`` and other library-related attributes * ``Main`` * ``Roots`` * ``Externally_Built`` * ``Inherit_Source_Path`` * ``Excluded_Source_Dirs`` * ``Locally_Removed_Files`` * ``Excluded_Source_Files`` * ``Excluded_Source_List_File`` * ``Interfaces`` The ``Object_Dir`` attribute is allowed and used by some analysis tools such as `gnatcheck` to store intermediate files and aggregated results. The attribute value is just ignored by the compilation toolchain, for which every artifact of interest is best associated with the leaf non aggregate projects and stored in the corresponding ``Object_Dir``. The package ``Naming`` and packages that control the compilation process (``Compiler``, ``Binder``, ``Linker`` and ``Install``) are forbidden. The following three attributes can be used only in an aggregate project: .. index:: Project_Files attribute **Project_Files**: This attribute is compulsory. It specifies a list of constituent :file:`.gpr` files that are grouped in the aggregate. The list may be empty. The project files can be any projects except configuration or abstract projects; they can be other aggregate projects. When grouping standard projects, you can have both the root of a project import closure (and you do not need to specify all its imported projects), and any project within the closure. The basic idea is to specify all those projects that have main programs you want to build and link, or libraries you want to build. You can specify projects that do not use the ``Main`` attribute or the ``Library_*`` attributes, and the result will be to build all their source files (not just the ones needed by other projects). The file can include paths (absolute or relative). Paths are relative to the location of the aggregate project file itself (if you use a base name, the :file:`.gpr` file is expected in the same directory as the aggregate project file). The environment variables :envvar:`ADA_PROJECT_PATH`, :envvar:`GPR_PROJECT_PATH` and :envvar:`GPR_PROJECT_PATH_FILE` are not used to find the project files. The extension :file:`.gpr` is mandatory, since this attribute contains file names, not project names. Paths can also include the ``"*"`` and ``"**"`` globbing patterns. The latter indicates that any subdirectory (recursively) will be searched for matching files. The ``"**"`` pattern can only occur at the last position in the directory part (i.e. ``"a/**/*.gpr"`` is supported, but not ``"**/a/*.gpr"``). Starting the pattern with ``"**"`` is equivalent to starting with ``"./**"``. At present the pattern ``"*"`` is only allowed in the filename part, not in the directory part. This is mostly for efficiency reasons to limit the number of system calls that are needed. Here are a few examples: .. code-block:: gpr for Project_Files use ("a.gpr", "subdir/b.gpr"); -- two specific projects relative to the directory of agg.gpr for Project_Files use ("**/*.gpr"); -- all projects recursively, except in the current directory for Project_Files use ("**/*.gpr", "*.gpr"); -- all projects recursively .. index:: Project_Path attribute **Project_Path**: This attribute can be used to specify a list of directories in which to search for project files in |with| clauses. When you specify a project in ``Project_Files`` (say :file:`x/y/a.gpr`), and :file:`a.gpr` imports a project :file:`b.gpr`, only :file:`b.gpr` is searched in the project path. The file :file:`a.gpr` must be exactly at :samp:`{dir of the aggregate}/x/y/a.gpr`. This attribute, however, does not affect the search for the aggregated project files specified with ``Project_Files``. Each aggregate project has its own ``Project_Path`` (thus if :file:`agg1.gpr` includes :file:`agg2.gpr`, they can potentially both have a different `Project_Path`). This project path is defined as the concatenation, in this order, of: * the current directory; * followed by the command line :option:`-aP` switches; * then the directories from the :envvar:`GPR_PROJECT_PATH` and :envvar:`ADA_PROJECT_PATH` environment variables; * then the directories from the ``Project_Path`` attribute; * and finally the predefined directories. In the example above, the project path for :file:`agg2.gpr` is not influenced by the attribute `agg1'Project_Path`, nor is `agg1` influenced by `agg2'Project_Path`. .. only:: html or latex This can potentially lead to errors. Consider the example in :numref:`figure #`. .. _fig-aggproject_error: .. figure:: project-manager-figure.png :figwidth: image :align: center Example of ``Project_Path`` Error .. only:: not (html or latex) This can potentially lead to errors. Consider the following example: :: +---------------+ +----------------+ | agg1.gpr | | agg2.gpr | | 'project_path|----includes----->| 'project_path | | | | | +---------------+ +----------------+ | | includes includes | | v v +-------+ +---------+ | p.gpr |<-------- imports --------| q.gpr | +-------+---------+ +---------+ | | imports imports | | v v +-------+ +---------+ | r.gpr | | r'.gpr | +-------+ +---------+ When looking for :file:`p.gpr`, both aggregates find the same physical file on the disk. However, it might happen that with their different project paths, both aggregate projects would in fact find a different :file:`r.gpr`. Since we have a common project :file:`p.gpr` |withing| two different :file:`r.gpr`, this will be reported as an error by the builder. Directories are relative to the location of the aggregate project file. Example: .. code-block:: gpr for Project_Path use ("/usr/local/gpr", "gpr/"); .. index:: External attribute **External**: This attribute can be used to set the value of environment variables as retrieved through the ``external`` function in projects. It does not affect the environment variables themselves (so for instance you cannot use it to change the value of your :envvar:`PATH` as seen from the spawned compiler). This attribute affects the external values as seen in the rest of the aggregate project, and in the aggregated projects. The exact value of an external variable comes from one of three sources (each level overrides the previous levels): * An External attribute in aggregate project, for instance `for External ("BUILD_MODE") use "DEBUG"`; * Environment variables. These override the value given by the attribute, so that users can override the value set in the (presumably shared with others team members) aggregate project. * The :option:`-X` command line switch to *gprbuild*. This always takes precedence. This attribute is only taken into account in the main aggregate project (i.e. the one specified on the command line to *GPRbuild*), and ignored in other aggregate projects. It is invalid in standard projects. The goal is to have a consistent value in all projects that are built through the aggregate, which would not be the case in a "diamond" situation: ``A`` groups the aggregate projects ``B`` and ``C``, which both (either directly or indirectly) build the project ``P``. If ``B`` and ``C`` could set different values for the environment variables, we would have two different views of ``P``, which in particular might impact the list of source files in ``P``. .. index:: Package Builder .. _package_Builder_in_aggregate_projects: package Builder in aggregate projects ------------------------------------- When used in an aggregate project, only the following attributes of this package are valid: .. index:: Switches attribute **Switches**: This attribute gives the list of switches to use for *GPRbuild*. Because no mains can be specified for aggregate projects, the only possible index for attribute ``Switches`` is ``others``. All other indexes will be ignored. Example: .. code-block:: gpr for Switches (others) use ("-v", "-k", "-j8"); These switches are only read from the main aggregate project (the one passed on the command line), and ignored in all other aggregate projects or projects. It can only contain builder switches, not compiler switches. .. index:: Global_Compilation_Switches attribute **Global_Compilation_Switches** This attribute gives the list of compiler switches for the various languages. For instance, .. code-block:: gpr for Global_Compilation_Switches ("Ada") use ("O1", "-g"); for Global_Compilation_Switches ("C") use ("-O2"); This attribute is only taken into account in the aggregate project specified on the command line, not in other aggregate projects. In the projects grouped by that aggregate, the attribute ``Builder'Global_Compilation_Switches`` is also ignored. However, the attribute ``Compiler'Default_Switches`` will be taken into account (but that of the aggregate has higher priority). The attribute ``Compiler'Switches`` is also taken into account and can be used to override the switches for a specific file. As a result, it always has priority. The rules are meant to avoid ambiguities when compiling. For instance, aggregate project ``Agg`` groups the projects ``A`` and ``B``, which both depend on ``C``. Here is an example for all of these projects: .. code-block:: gpr aggregate project Agg is for Project_Files use ("a.gpr", "b.gpr"); package Builder is for Global_Compilation_Switches ("Ada") use ("-O2"); end Builder; end Agg; .. code-block:: gpr with "c.gpr"; project A is package Builder is for Global_Compilation_Switches ("Ada") use ("-O1"); -- ignored end Builder; package Compiler is for Default_Switches ("Ada") use ("-O1", "-g"); for Switches ("a_file1.adb") use ("-O0"); end Compiler; end A; .. code-block:: gpr with "c.gpr"; project B is package Compiler is for Default_Switches ("Ada") use ("-O0"); end Compiler; end B; .. code-block:: gpr project C is package Compiler is for Default_Switches ("Ada") use ("-O3", "-gnatn"); for Switches ("c_file1.adb") use ("-O0", "-g"); end Compiler; end C; The following switches are used: * all files from project ``A`` except :file:`a_file1.adb` are compiled with :option:`-O2 -g`, since the aggregate project has priority. * the file :file:`a_file1.adb` is compiled with :option"`-O0`, since ``Compiler'Switches`` has priority * all files from project ``B`` are compiled with :option:`-O2`, since the aggregate project has priority * all files from ``C`` are compiled with :option:`-O2 -gnatn`, except for :file:`c_file1.adb` which is compiled with :option:`-O0 -g` Even though ``C`` is seen through two paths (through ``A`` and through ``B``), the switches used by the compiler are unambiguous. .. index:: Global_Configuration_Pragmas attribute **Global_Configuration_Pragmas** This attribute can be used to specify a file containing configuration pragmas, to be passed to the Ada compiler. Since we ignore the package ``Builder`` in other aggregate projects and projects, only those pragmas defined in the main aggregate project will be taken into account. Projects can locally add to those by using the ``Compiler'Local_Configuration_Pragmas`` attribute if they need. .. index:: Global_Config_File attribute **Global_Config_File** This attribute, indexed with a language name, can be used to specify a config when compiling sources of the language. For Ada, these files are configuration pragmas files. For projects that are built through the aggregate mechanism, the package ``Builder`` is ignored, except for the ``Executable`` attribute which specifies the name of the executables resulting from the link of the main programs, and for the ``Executable_Suffix``. .. index:: Aggregate library project .. _Aggregate_Library_Projects: Aggregate Library Projects ========================== Aggregate library projects make it possible to build a single library using object files built using other standard or library projects. This gives the flexibility to describe an application as having multiple modules (for example a GUI, database access, and other) using different project files (so possibly built with different compiler options) and yet create a single library (static or relocatable) out of the corresponding object files. .. _Building_aggregate_library_projects: Building aggregate library projects ----------------------------------- For example, we can define an aggregate project ``Agg`` that groups ``A``, ``B`` and ``C``: .. code-block:: gpr aggregate library project Agg is for Project_Files use ("a.gpr", "b.gpr", "c.gpr"); for Library_Name use "agg"; for Library_Dir use "lagg"; end Agg; Then, when you build with: .. code-block:: sh gprbuild agg.gpr this will build all units from projects ``A``, ``B`` and ``C`` and will create a static library named :file:`libagg.a` in the :file:`lagg` directory. An aggregate library project has the same set of restrictions as a standard library project. Note that a shared aggregate library project cannot aggregate a static library project. In platforms where a compiler option is required to create relocatable object files, a ``Builder package`` in the aggregate library project may be used: .. code-block:: gpr aggregate library project Agg is for Project_Files use ("a.gpr", "b.gpr", "c.gpr"); for Library_Name use ("agg"); for Library_Dir use ("lagg"); for Library_Kind use "relocatable"; package Builder is for Global_Compilation_Switches ("Ada") use ("-fPIC"); end Builder; end Agg; With the above aggregate library Builder package, the :option:`-fPIC` option will be passed to the compiler when building any source code from projects :file:`a.gpr`, :file:`b.gpr` and :file:`c.gpr`. .. _Syntax_of_aggregate_library_projects: Syntax of aggregate library projects ------------------------------------ An aggregate library project follows the general syntax of project files. The recommended extension is still :file:`.gpr`. However, a special ``aggregate library`` qualifier must appear before the keyword ``project``. An aggregate library project cannot |with| any other project (standard or aggregate), except an abstract project which can be used to share attribute values. An aggregate library project does not have any source files directly (only through other standard projects). Therefore a number of the standard attributes and packages are forbidden in an aggregate library project. Here is a (non-exhaustive) list: * ``Languages`` * ``Source_Files``, ``Source_List_File`` and other attributes dealing with a list of sources. * ``Source_Dirs`` and ``Exec_Dir`` * ``Main`` * ``Roots`` * ``Externally_Built`` * ``Inherit_Source_Path`` * ``Excluded_Source_Dirs`` * ``Locally_Removed_Files`` * ``Excluded_Source_Files`` * ``Excluded_Source_List_File`` The only package that is allowed (and optional) is ``Builder``. The ``Project_Files`` attribute is used to describe the aggregated projects whose object files have to be included into the aggregate library. The environment variables :envvar:`ADA_PROJECT_PATH`, :envvar:`GPR_PROJECT_PATH` and :envvar:`GPR_PROJECT_PATH_FILE` are not used to find the project files. As for regular (not library) aggregate projects, the ``Object_Dir`` attribute is allowed and used by some analysis tools in the same fashion. .. _Project_File_Reference: Project File Reference ====================== This section describes the syntactic structure of project files, explains the various constructs that can be used, and summarizes the available attributes. The syntax is presented in a notation similar to what is used in the Ada Language Reference Manual. Curly braces '{' and '}' indicate 0 or more occurrences of the enclosed construct, and square brackets '[' and ']' indicate 0 or 1 occurrence of the enclosed construct. Reserved words are enclosed between apostrophes. .. _Project_Declaration: Project Declaration ------------------- Project files have an Ada-like syntax. The minimal project file is: .. code-block:: gpr project Empty is end Empty; The identifier ``Empty`` is the name of the project. This project name must be present after the reserved word ``end`` at the end of the project file, followed by a semicolon. **Identifiers** (i.e., the user-defined names such as project or variable names) have the same syntax as Ada identifiers: they must start with a letter, and be followed by zero or more letters, digits or underscore characters; it is also illegal to have two underscores next to each other. Identifiers are always case-insensitive (``"Name"`` is the same as ``"name"``). :: simple_name ::= identifier name ::= simple_name { . simple_name } **Strings** are used for values of attributes or as indexes for these attributes. They are in general case sensitive, except when noted otherwise (in particular, strings representing file names will be case insensitive on some systems, so that ``"file.adb"`` and ``"File.adb"`` both represent the same file). .. index:: Reserved words (in project files) **Reserved words** are the standard Ada 95 reserved words, plus several others listed below, and cannot be used for identifiers. In particular, the following Ada 95 reserved words are currently used in project files: :: abstract all at case end for is limited null others package renames type use when with The additional project file reserved words are: :: extends external external_as_list project Note that ``aggregate`` and ``library`` are qualifiers that may appear before the keyword ``project``, but they are not themselves keywords. To avoid possible compatibility issues in the future, we recommend that the reserved words introduced by Ada 2005 and Ada 2012 not be used as identifiers in project files. Note also that new reserved words may be added to the project file syntax in a later release. **Comments** in project files have the same syntax as in Ada, two consecutive hyphens through the end of the line. .. index:: Independent project .. _Independent_Project: A project may be an **independent project**, entirely defined by a single project file. Any source file in an independent project depends only on the predefined library and other source files in the same project. Alternatively, a project may depend on other projects in various ways: * by **importing** them through context clauses (|with| clauses), or * by **extending** at most one other project (its base project). A given project may exhibit either or both of these dependencies; for example: .. code-block:: gpr with "imported_proj.gpr"; project My_Project extends "base_proj.gpr" is end My_Project; The import dependencies form a **directed graph**, potentially cyclic when using **limited with**. The subgraph reflecting the **extends** relationship is a tree (hierarchy). A path name denotes a project file. It can be absolute or relative. An absolute path name includes a sequence of directories, in the syntax of the host operating system, that uniquely identifies the project file in the file system. A relative path name identifies the project file, relative to the directory that contains the current project, or relative to a directory listed in the environment variables :envvar:`ADA_PROJECT_PATH` and :envvar:`GPR_PROJECT_PATH`. Path names are case sensitive if file names in the host operating system are case sensitive. As a special case, the directory separator can always be ``'/'`` even on Windows systems, so that project files can be made portable across architectures. The syntax of the environment variables :envvar:`ADA_PROJECT_PATH` and :envvar:`GPR_PROJECT_PATH` is a list of directory names separated by colons on Unix and semicolons on Windows. A given project name can appear only once in a context clause, and may not appear in different context clauses for the same project. It is illegal for a project imported by a context clause to refer, directly or indirectly, to the project in which this context clause appears (the dependency graph cannot contain cycles), except when one of the |with| clauses in the cycle is a |limited_with|. .. index:: Immediate sources of a project .. index:: Sources of a project A project's **immediate sources** are the source files directly defined by that project, either implicitly by residing in the project source directories, or explicitly through any of the source-related attributes. More generally, a project's **sources** are the immediate sources of the project together with the immediate sources (unless overridden) of any project on which it depends directly or indirectly. :: project ::= context_clause project_declaration context_clause ::= {with_clause} with_clause ::= [ 'limited' ] 'with' path_name { , path_name } ; path_name ::= string_literal project_declaration ::= simple_project_declaration | project_extension simple_project_declaration ::= [ qualifier ] 'project' name 'is' {declarative_item} 'end' name ; project_extension ::= [ qualifier ] 'project' name 'extends' [ 'all' ] name 'is' {declarative_item} 'end' name ; qualifier ::= 'abstract' | identifier [ identifier ] .. _Qualified_Projects: Qualified Projects ------------------ Immediately preceding the reserved ``project``, a **qualifier** may be specified which identifies the nature of the project. The following qualifiers are allowed: .. index:: Standard project .. _Standard_Project: **standard**: A standard project is a non-library project with source files. This is the default (implicit) qualifier. .. index:: Abstract project **abstract**: A project with no source files. Such a project must either have no declaration for attributes ``Source_Dirs``, ``Source_Files``, ``Languages`` or ``Source_List_File``, or one of ``Source_Dirs``, ``Source_Files``, or ``Languages`` must be declared as empty. If it extends another project, the base project must also be an abstract project. .. index:: Aggregate project **aggregate**: A project whose sources are aggregated from other project files. **aggregate library**: A library whose sources are aggregated from other project or library project files. .. index:: Library project **library**: A library project must define both of the attributes `Library_Name` and `Library_Dir`. .. index:: Configuration project .. _Configuration_Project: **configuration**: A configuration project cannot be in a project tree. It describes compilers and other tools to *gprbuild*. .. index:: Declarations in project files .. _Declarations: Declarations ------------ Declarations introduce new entities that denote types, variables, attributes, and packages. Some declarations can only appear immediately within a project declaration. Others can appear within a project or within a package. :: declarative_item ::= simple_declarative_item | typed_string_declaration | package_declaration simple_declarative_item ::= variable_declaration | typed_variable_declaration | attribute_declaration | case_construction | empty_declaration empty_declaration ::= 'null' ; An empty declaration is allowed anywhere a declaration is allowed. It has no effect. .. index:: Packages in project files .. _Packages: Packages -------- A project file may contain **packages**, which group attributes (typically all the attributes that are used by one of the GNAT tools). A package with a given name may only appear once in a project file. The following packages are currently supported in project files (See :ref:`Attributes` for the list of attributes that each can contain). .. index:: Binder package *Binder* This package specifies characteristics useful when invoking the binder either directly via the *gnat* driver or when using *GPRbuild*. See :ref:`Main_Subprograms`. .. index:: Builder package *Builder* This package specifies the compilation options used when building an executable or a library for a project. Most of the options should be set in one of ``Compiler``, ``Binder`` or ``Linker`` packages, but there are some general options that should be defined in this package. See :ref:`Main_Subprograms`, and :ref:`Executable_File_Names` in particular. .. index:: Check package .. index:: gnatcheck tool *Check* This package specifies the options used when calling the coding standard verification tool *gnatcheck*. Its attributes ``Default_Switches`` and ``Switches`` have the same semantics as for the package ``Builder``. The first string should always be :option:`-rules` to specify that all the other options belong to the ``-rules`` section of the parameters to *gnatcheck*. .. index:: Clean package .. index:: gprclean tool *Clean* This package specifies the options used when cleaning a project or a project tree using the tools *gnatclean* or *gprclean*. .. index:: Compiler package *Compiler* This package specifies the compilation options used by the compiler for each language. See :ref:`Tools_Options_in_Project_Files`. .. index:: Cross_Reference package .. index:: gnatxref tool *Cross_Reference* This package specifies the options used when calling the library tool *gnatxref* via the *gnat* driver. Its attributes ``Default_Switches`` and ``Switches`` have the same semantics as for the package ``Builder``. .. index:: Documentation package .. index:: gnatdoc tool *Documentation* This package specifies the options used when calling the tool *gnatdoc*. .. index:: Eliminate package .. index:: gnatelim tool *Eliminate* This package specifies the options used when calling the tool *gnatelim*. Its attributes ``Default_Switches`` and ``Switches`` have the same semantics as for the package ``Builder``. .. index:: Finder package .. index:: gnatfind tool *Finder* This package specifies the options used when calling the search tool *gnatfind* via the *gnat* driver. Its attributes ``Default_Switches`` and ``Switches`` have the same semantics as for the package ``Builder``. .. index:: Gnatls package .. index:: gnatls tool *Gnatls* This package specifies the options to use when invoking *gnatls* via the *gnat* driver. .. index:: Gnatstub package .. index:: gnatstub tool *Gnatstub* This package specifies the options used when calling the tool *gnatstub*. Its attributes ``Default_Switches`` and ``Switches`` have the same semantics as for the package ``Builder``. .. index:: IDE package *IDE* This package specifies the options used when starting an integrated development environment, for instance *GPS* or *GNATbench*. .. index:: Install package .. index:: gprinstall tool *Install* This package specifies the options used when installing a project with *gprinstall*. See :ref:`Package_Install_Attributes`. .. index:: Linker package *Linker* This package specifies the options used by the linker. See :ref:`Main_Subprograms`. .. index:: Metrics package .. index:: gnatmetric tool *Metrics* This package specifies the options used when calling the tool *gnatmetric*. Its attributes ``Default_Switches`` and ``Switches`` have the same semantics as for the package ``Builder``. .. index:: Naming package *Naming* This package specifies the naming conventions that apply to the source files in a project. In particular, these conventions are used to automatically find all source files in the source directories, or given a file name to find out its language for proper processing. See :ref:`Naming_Schemes`. .. index:: Pretty_Printer package .. index:: gnatpp tool *Pretty_Printer* This package specifies the options used when calling the formatting tool *gnatpp*. Its attributes ``Default_Switches`` and ``Switches`` have the same semantics as for the package ``Builder``. .. index:: Remote package .. index:: Distributed compilation *Remote* This package is used by *GPRbuild* to describe how distributed compilation should be done. .. index:: Stack package .. index:: gnatstack tool *Stack* This package specifies the options used when calling the tool *gnatstack*. Its attributes **Default_Switches** and **Switches** have the same semantics as for the package `Builder`. .. index:: Synchronize package .. index:: gnatsync tool *Synchronize* This package specifies the options used when calling the tool *gnatsync* via the *gnat* driver. In its simplest form, a package may be empty: .. code-block:: gpr project Simple is package Builder is end Builder; end Simple; A package may contain **attribute declarations**, **variable declarations** and **case constructions**, as will be described below. When there is ambiguity between a project name and a package name, the name always designates the project. To avoid possible confusion, it is always a good idea to avoid naming a project with one of the names allowed for packages or any name that starts with `gnat`. .. index:: Renaming declaration .. index:: Package renaming .. rubric:: Package renaming A package may be defined by a **renaming declaration**. The new package renames a package declared in a different project file, and has the same attributes as the package it renames. The name of the renamed package must be the same as the name of the renaming package. The project must contain a package declaration with this name, and the project must appear in the context clause of the current project, or be its base or parent project. It is not possible to add or override attributes to the renaming project. If you need to do so, you should use an **extending declaration** (see below). Packages that are renamed in other project files often come from project files that have no sources: they are just used as templates. Any modification in the template will be reflected automatically in all the project files that rename a package from the template. This is a very common way to share settings between projects. .. index:: Package extension .. index:: Extending declaration .. _Package_Extension: .. rubric:: Package extension A package can also be defined by an **extending declaration**. This is similar to a **renaming declaration**, except that it is possible to add or override attributes. :: package_declaration ::= package_spec | package_renaming | package_extension package_spec ::= 'package' simple_name 'is' { simple_declarative_item } 'end' package_identifier ; package_renaming ::= 'package' simple_name 'renames' simple_name.package_identifier ; package_extension ::= 'package' simple_name 'extends' simple_name.package_identifier 'is' { simple_declarative_item } 'end' package_identifier ; .. index:: Expressions in project files .. _Expressions: Expressions ----------- An expression is any value that can be assigned to an attribute or a variable. It is either a literal value, or a construct requiring run-time computation by the Project Manager. In a project file, the computed value of an expression is either a string or a list of strings. A string value is one of: * A literal string, for instance ``"comm/my_proj.gpr"`` * The name of a variable that evaluates to a string (see :ref:`Variables`) * The name of an attribute that evaluates to a string (see :ref:`Attributes`) * An external reference (see :ref:`External_Values`) * A concatenation of the above, as in ``"prefix_" & Var``. A list of strings is one of the following: * A parenthesized comma-separated list of zero or more string expressions, for instance ``(File_Name, "gnat.adc", File_Name & ".orig")`` or ``()``. * The name of a variable that evaluates to a list of strings * The name of an attribute that evaluates to a list of strings * A concatenation of a list of strings and a string (as defined above), for instance ``("A", "B") & "C"`` * A concatenation of two lists of strings The following is the grammar for expressions :: string_literal ::= "{string_element}" -- Same as Ada string_expression ::= string_literal | name | external_value | attribute_reference | ( string_expression { & string_expression } ) string_list ::= ( string_expression { , string_expression } ) | _name | attribute_reference term ::= string_expression | string_list expression ::= term { & term } -- Concatenation Concatenation involves strings and list of strings. As soon as a list of strings is involved, the result of the concatenation is a list of strings. The following Ada declarations show the existing operators: .. code-block:: ada function "&" (X : String; Y : String) return String; function "&" (X : String_List; Y : String) return String_List; function "&" (X : String_List; Y : String_List) return String_List; Here are some specific examples: .. code-block:: ada List := () & File_Name; -- One string in this list List2 := List & (File_Name & ".orig"); -- Two strings Big_List := List & Lists2; -- Three strings Illegal := "gnat.adc" & List2; -- Illegal, must start with list .. index:: Built-in Functions .. _Builtin_Functions: Built-in Functions ------------------ Built-in functions may be used in expression. The names of built-in functions are not reserved words and may also be used as variable names. In an expression, a built-in function is recognized if its name is immediately followed by an open parenthesis ('('). .. _External_Values: .. index:: external function The function ``external`` ^^^^^^^^^^^^^^^^^^^^^^^^^ An external value is an expression whose value is obtained from the command that invoked the processing of the current project file (typically a *gprbuild* command). The syntax of a single string external value is:: external_value ::= 'external' ( string_literal [, string_literal] ) The first string_literal is the name of the external variable, whose value (a string) may be specified by an environment variable with this name, or on the command line via the :samp:`-X{name}={value}` option. The command line takes precedence if the name is defined in both contexts, thus allowing the user to locally override an environment variable. The second string_literal, if present, is the default to use if there is no specification for this external value either on the command line or in the environment. If the value of the external variable is not obtained from an environment variable or the command line, and the invocation of the ``external`` function does not supply a second parameter, then an error is reported. An external reference may be part of a string expression or of a string list expression, and can therefore appear in a variable declaration or an attribute declaration. .. _Scenario_Variable: This construct is typically used to initialize *typed variables*, which are then used in *case* constructions to control the value assigned to attributes in various scenarios. Thus such variables are often called *scenario variables*. .. index:: external_as_list function The function ``external_as_list`` ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ An external value is an expression whose value is obtained from the command that invoked the processing of the current project file (typically a *gprbuild* command). The syntax for a string list external value is:: external_value ::= 'external_as_list' ( string_literal , string_literal ) The first string_literal is the name of the external variable, with the same interpretation as for the ``external`` function; it is looked up first on the command line (as the name in a :samp:`-X{name}={value}` option) and, if not so specified, then as an environment variable. If it is not defined by either of these, then the function returns an empty list. The second string_literal is the separator between each component of the string list. An empty list is returned if the separator is an empty string or if the external value is only one separator. Any separator at the beginning or at the end of the external value is discarded. Then, if there is no separator in the external value, the result is a string list with only one string. Otherwise, any string between the beginning and the first separator, between two consecutive separators and between the last separator and the end are components of the string list. Note the following differences between ``external`` and ``external_as_list``: * The ``external_as_list`` function has no default value for the external variable * The ``external_as_list`` function returns an empty list, and does not report an error, when the value of the external variable is undefined. These differences reflect the different use cases for the two functions. External variables evaluated by the ``external`` function are often used for configuration control, and misspellings should be detected as errors rather than silently returning the empty string. If the user intended an empty string as the result when the external variable was undefined, then this could easily be obtained: :: external ("SOME_VAR", "") In contrast, the ``external_as_list`` function more typically is used for external variables that may or may not have definitions (for example, lists of options or paths) and then the desired result in the undefined case is an empty list, not a reported error. Here is an example of the ``external_as_list`` function: :: external_as_list ("SWITCHES", ",") If the external value of ``SWITCHES`` is ``"-O2,-g"``, the result is ``("-O2", "-g")``. If the external value is ``",-O2,-g,"``, the result is also ``("-O2", "-g")``. if the external value is ``"-gnatv"``, the result is ``("-gnatv")``. If the external value is ``",,"``, the result is (``""``). If the external value is ``","``, the result is ``()``, the empty string list. .. _Split: Split ^^^^^ Function Split takes two single string parameters and return a string list. Example: :: Split ("-gnatf,-gnatv", ",") => ("-gnatf", "gnatv") The first string argument is the string to be split. The second argument is the separator. Each occurrence of the separator in the first argument is a place where it is split. If the first argument is an empty string or contains only occurrences of the separator, then the result is an empty string list. If the argument does not contains any occurrence of the separator, then the result is a list with only one string: the first argument. Empty strings are not included in the result. :: Split ("-gnatf -gnatv", " ") => ("-gnatf", "gnatv") .. index:: Type declaration .. _Typed_String_Declaration: Typed String Declaration ------------------------ A **type declaration** introduces a discrete set of string literals. If a string variable is declared to have this type, its value is restricted to the given set of literals. These are the only named types in project files. A type declaration may only appear at the project level, not inside a package. :: typed_string_declaration ::= 'type' simple_name 'is' ( string_literal {, string_literal} ); The string literals in the list are case sensitive and must all be different. They may include any graphic characters allowed in Ada, including spaces. Here is an example of a string type declaration: .. code-block:: ada type OS is ("GNU/Linux", "Unix", "Windows", "VMS"); Variables of a string type are called **typed variables**; all other variables are called **untyped variables**. Typed variables are particularly useful in `case` constructions, to support conditional attribute declarations. (See :ref:`Case_Constructions`). A string type may be referenced by its name if it has been declared in the same project file, or by an expanded name whose prefix is the name of the project in which it is declared. .. index:: Variables in project files .. _Variables: Variables --------- **Variables** store values (strings or list of strings) and can appear as part of an expression. The declaration of a variable creates the variable and assigns the value of the expression to it. The name of the variable is available immediately after the assignment symbol, if you need to reuse its old value to compute the new value. Before the completion of its first declaration, the value of a variable defaults to the empty string (``""``). A **typed** variable can be used as part of a **case** expression to compute the value, but it can only be declared once in the project file, so that all case constructions see the same value for the variable. This provides more consistency and makes the project easier to understand. The syntax for its declaration is identical to the Ada syntax for an object declaration. In effect, a typed variable acts as a constant. An **untyped** variable can be declared and overridden multiple times within the same project. It is declared implicitly through an Ada assignment. The first declaration establishes the kind of the variable (string or list of strings) and successive declarations must respect the initial kind. Assignments are executed in the order in which they appear, so the new value replaces the old one and any subsequent reference to the variable uses the new value. A variable may be declared at the project file level, or within a package. :: typed_variable_declaration ::= simple_name : name := string_expression; variable_declaration ::= simple_name := expression; Here are some examples of variable declarations: .. code-block:: gpr This_OS : OS := external ("OS"); -- a typed variable declaration That_OS := "GNU/Linux"; -- an untyped variable declaration Name := "readme.txt"; Save_Name := Name & ".saved"; Empty_List := (); List_With_One_Element := ("-gnaty"); List_With_Two_Elements := List_With_One_Element & "-gnatg"; Long_List := ("main.ada", "pack1_.ada", "pack1.ada", "pack2_.ada"); A **variable reference** may take several forms: * The simple variable name, for a variable in the current package (if any) or in the current project * An expanded name, whose prefix is a context name. A **context** may be one of the following: * The name of an existing package in the current project * The name of an imported project of the current project * The name of a direct or indirect base project (i.e., a project extended by the current project, either directly or indirectly) * An expanded name whose prefix is an imported/parent project name, and whose selector is a package name in that project. .. index:: Case construction .. _Case_Constructions: Case Constructions ------------------ A **case** construction is used in a project file to effect conditional behavior. Through this construction, you can set the value of attributes and variables depending on the value previously assigned to a typed variable. All choices in a choice list must be distinct. Unlike Ada, the choice lists of all alternatives do not need to include all values of the type. An `others` choice must appear last in the list of alternatives. The syntax of a ``case`` construction is based on the Ada case construction (although the ``null`` declaration for empty alternatives is optional). The case expression must be a string variable, either typed or not, whose value is often given by an external reference (see :ref:`External_Values`). Each alternative starts with the reserved word ``when``, either a list of literal strings separated by the ``"|"`` character or the reserved word ``others``, and the ``"=>"`` token. When the case expression is a typed string variable, each literal string must belong to the string type that is the type of the case variable. After each ``=>``, there are zero or more declarations. The only declarations allowed in a case construction are other case constructions, attribute declarations, and variable declarations. String type declarations and package declarations are not allowed. Variable declarations are restricted to variables that have already been declared before the case construction. :: case_construction ::= 'case' name 'is' {case_item} 'end' 'case' ; case_item ::= 'when' discrete_choice_list => {case_declaration | attribute_declaration | variable_declaration | empty_declaration} discrete_choice_list ::= string_literal {| string_literal} | 'others' Here is a typical example, with a typed string variable: .. code-block:: gpr project MyProj is type OS_Type is ("GNU/Linux", "Unix", "Windows", "VMS"); OS : OS_Type := external ("OS", "GNU/Linux"); package Compiler is case OS is when "GNU/Linux" | "Unix" => for Switches ("Ada") use ("-gnath"); when "Windows" => for Switches ("Ada") use ("-gnatP"); when others => null; end case; end Compiler; end MyProj; .. index:: Attribute .. _Attributes: Attributes ---------- A project (and its packages) may have **attributes** that define the project's properties. Some attributes have values that are strings; others have values that are string lists. :: attribute_declaration ::= simple_attribute_declaration | indexed_attribute_declaration simple_attribute_declaration ::= 'for' attribute_designator 'use' expression ; indexed_attribute_declaration ::= 'for' **simple_name ( string_literal) 'use' expression ; attribute_designator ::= simple_name | simple_name ( string_literal ) There are two categories of attributes: **simple attributes** and **indexed attributes**. Each simple attribute has a default value: the empty string (for string attributes) and the empty list (for string list attributes). An attribute declaration defines a new value for an attribute, and overrides the previous value. The syntax of a simple attribute declaration is similar to that of an attribute definition clause in Ada. Some attributes are indexed. These attributes are mappings whose domain is a set of strings. They are declared one association at a time, by specifying a point in the domain and the corresponding image of the attribute. Like untyped variables and simple attributes, indexed attributes may be declared several times. Each declaration supplies a new value for the attribute, and replaces the previous setting. Here are some examples of attribute declarations: .. code-block:: gpr -- simple attributes for Object_Dir use "objects"; for Source_Dirs use ("units", "test/drivers"); -- indexed attributes for Body ("main") use "Main.ada"; for Switches ("main.ada") use ("-v", "-gnatv"); for Switches ("main.ada") use Builder'Switches ("main.ada") & "-g"; -- indexed attributes copy (from package Builder in project Default) -- The package name must always be specified, even if it is the current -- package. for Default_Switches use Default.Builder'Default_Switches; When an attribute is defined in the configuration project but not in the user project, it is inherited in the user project. When a single string attribute is defined in both the configuration project and the user project, its value in the user project is as declared; the value in the configuration project does not matter. For string list attributes, there are two cases. Some of these attributes are **configuration concatenable**. For these attributes, when they are declared in both the configuration project and the user project, the final value is the concatenation of the value in the configuration project with the value in the user project. The configuration concatenable attributes are indicated in the list below. Attributes references may appear anywhere in expressions, and are used to retrieve the value previously assigned to the attribute. If an attribute has not been set in a given package or project, its value defaults to the empty string or the empty list, with some exceptions. :: attribute_reference ::= attribute_prefix ' _simple_name [ (string_literal) ] attribute_prefix ::= 'project' | simple_name | package_identifier | simple_name . package_identifier Here are some examples: :: project'Object_Dir Naming'Dot_Replacement Imported_Project'Source_Dirs Imported_Project.Naming'Casing Builder'Default_Switches ("Ada") The exceptions to the empty defaults are: * ``Object_Dir``: default is ``"."`` * ``Exec_Dir``: default is ``'Object_Dir``, that is, the value of attribute ``Object_Dir`` in the same project, declared or defaulted * ``Source_Dirs``: default is ``(".")`` The prefix of an attribute may be: * ``project`` for an attribute of the current project * The name of an existing package of the current project * The name of an imported project * The name of a parent project that is extended by the current project * An expanded name whose prefix is imported/base/parent project name, and whose selector is a package name In the following sections, all predefined attributes are succinctly described, first the project level attributes (that is, those attributes that are not in a package), then the attributes in the different packages. It is possible for different tools to dynamically create new packages with attributes, or new attributes in predefined packages. These attributes are not documented here. The attributes under Configuration headings are usually found only in configuration project files. The characteristics of each attribute are indicated as follows: * **Type of value** The value of an attribute may be a single string, indicated by the word "single", or a string list, indicated by the word "list". * **Read-only** When the attribute is read-only -- that is when a declaration for the attribute is forbidden -- this is indicated by the "read-only". * **Optional index** If an optional index is allowed in the value of the attribute (both single and list), this is indicated by the words "optional index". * **Indexed attribute** An indexed attribute is indicated by the word "indexed". * **Case-sensitivity of the index** For an indexed attribute, if the index is case-insensitive, this is indicated by the words "case-insensitive index". * **File name index** For an indexed attribute, when the index is a file name, this is indicated by the words "file name index". The index may or may not be case-sensitive, depending on the platform. * **others allowed in index** For an indexed attribute, if it is allowed to use **others** as the index, this is indicated by the words "others allowed". When **others** is used as the index of an indexed attribute, the value of the attribute indexed by **others** is used when no other index would apply. * **configuration concatenable** For a string list attribute, the final value if the attribute is declared in both the configuration project and the user project is the concatenation of the two value, configuration then user. .. _Project_Level_Attributes: Project Level Attributes ^^^^^^^^^^^^^^^^^^^^^^^^ * **General** * **Name**: single, read-only The name of the project. * **Project_Dir**: single, read-only The path name of the project directory. * **Main**: list The list of main sources for the executables. * **Languages**: list The list of languages of the sources of the project. * **Roots**: list, indexed, file name index The index is the file name of an executable source. Indicates the list of units from the main project that need to be bound and linked with their closures with the executable. The index is either a file name, a language name or "*". The roots for an executable source are those in **Roots** with an index that is the executable source file name, if declared. Otherwise, they are those in **Roots** with an index that is the language name of the executable source, if present. Otherwise, they are those in **Roots ("*")**, if declared. If none of these three possibilities are declared, then there are no roots for the executable source. * **Externally_Built**: single Indicates if the project is externally built. Only case-insensitive values allowed are "true" and "false", the default. * **Warning_Message**: single Causes gprbuild to emit a user-defined warning message. * **Directories** * **Object_Dir**: single Indicates the object directory for the project. * **Exec_Dir**: single Indicates the exec directory for the project, that is the directory where the executables are. * **Create_Missing_Dirs**: single Indicates if the missing object, library and executable directories should be created automatically by the project-aware tool. Taken into account only in the main project. Only authorized case-insensitive values are "true" and "false". * **Source_Dirs**: list The list of source directories of the project. * **Inherit_Source_Path**: list, indexed, case-insensitive index Index is a language name. Value is a list of language names. Indicates that in the source search path of the index language the source directories of the languages in the list should be included. Example: .. code-block:: gpr for Inherit_Source_Path ("C++") use ("C"); * **Exclude_Source_Dirs**: list The list of directories that are included in Source_Dirs but are not source directories of the project. * **Ignore_Source_Sub_Dirs**: list Value is a list of simple names or patterns for subdirectories that are removed from the list of source directories, including their subdirectories. * **Source Files** * **Source_Files**: list Value is a list of source file simple names. * **Locally_Removed_Files**: list Obsolescent. Equivalent to Excluded_Source_Files. * **Excluded_Source_Files**: list Value is a list of simple file names that are not sources of the project. Allows to remove sources that are inherited or found in the source directories and that match the naming scheme. * **Source_List_File**: single Value is a text file name that contains a list of source file simple names, one on each line. * **Excluded_Source_List_File**: single Value is a text file name that contains a list of file simple names that are not sources of the project. * **Interfaces**: list Value is a list of file names that constitutes the interfaces of the project. * **Aggregate Projects** * **Project_Files**: list Value is the list of aggregated projects. * **Project_Path**: list Value is a list of directories that are added to the project search path when looking for the aggregated projects. * **External**: single, indexed Index is the name of an external reference. Value is the value of the external reference to be used when parsing the aggregated projects. * **Libraries** * **Library_Dir**: single Value is the name of the library directory. This attribute needs to be declared for each library project. * **Library_Name**: single Value is the name of the library. This attribute needs to be declared or inherited for each library project. * **Library_Kind**: single Specifies the kind of library: static library (archive) or shared library. Case-insensitive values must be one of "static" for archives (the default), "static-pic" for archives of Position Independent Code, or "dynamic" or "relocatable" for shared libraries. * **Library_Version**: single Value is the name of the library file. * **Library_Interface**: list Value is the list of unit names that constitutes the interfaces of a Stand-Alone Library project. * **Library_Standalone**: single Specifies if a Stand-Alone Library (SAL) is encapsulated or not. Only authorized case-insensitive values are "standard" for non encapsulated SALs, "encapsulated" for encapsulated SALs or "no" for non SAL library project. * **Library_Encapsulated_Options**: list, configuration concatenable Value is a list of options that need to be used when linking an encapsulated Stand-Alone Library. * **Library_Encapsulated_Supported**: single Indicates if encapsulated Stand-Alone Libraries are supported. Only authorized case-insensitive values are "true" and "false" (the default). * **Library_Auto_Init**: single Indicates if a Stand-Alone Library is auto-initialized. Only authorized case-insensitive values are "true" and "false". * **Leading_Library_Options**: list, configuration concatenable Value is a list of options that are to be used at the beginning of the command line when linking a shared library. * **Library_Options**: list, configuration concatenable Value is a list of options that are to be used when linking a shared library. * **Library_Rpath_Options**: list, indexed, case-insensitive index, configuration concatenable Index is a language name. Value is a list of options for an invocation of the compiler of the language. This invocation is done for a shared library project with sources of the language. The output of the invocation is the path name of a shared library file. The directory name is to be put in the run path option switch when linking the shared library for the project. * **Library_Src_Dir**: single Value is the name of the directory where copies of the sources of the interfaces of a Stand-Alone Library are to be copied. * **Library_ALI_Dir**: single Value is the name of the directory where the ALI files of the interfaces of a Stand-Alone Library are to be copied. When this attribute is not declared, the directory is the library directory. * **Library_gcc**: single Obsolescent attribute. Specify the linker driver used to link a shared library. Use instead attribute Linker'Driver. * **Library_Symbol_File**: single Value is the name of the library symbol file. * **Library_Symbol_Policy**: single Indicates the symbol policy kind. Only authorized case-insensitive values are "restricted", "unrestricted". * **Library_Reference_Symbol_File**: single Value is the name of the reference symbol file. * **Configuration - General** * **Default_Language**: single Value is the case-insensitive name of the language of a project when attribute Languages is not specified. * **Run_Path_Option**: list Value is the list of switches to be used when specifying the run path option in an executable. * **Run_Path_Origin**: single Value is the string that may replace the path name of the executable directory in the run path options. * **Separate_Run_Path_Options**: single Indicates if there may be several run path options specified when linking an executable. Only authorized case-insensitive values are "true" or "false" (the default). * **Toolchain_Version**: single, indexed, case-insensitive index Index is a language name. Specify the version of a toolchain for a language. * **Required_Toolchain_Version**: single, indexed, case-insensitive index Index is a language name. Specify the value expected for the Toolchain_Version attribute for this language, typically provided by an auto-generated configuration project. If Required_Toolchain_Version and Toolchain_Version do not match, the project processing aborts with an error. * **Toolchain_Description**: single, indexed, case-insensitive index Obsolescent. No longer used. * **Object_Generated**: single, indexed, case-insensitive index Index is a language name. Indicates if invoking the compiler for a language produces an object file. Only authorized case-insensitive values are "false" and "true" (the default). * **Objects_Linked**: single, indexed, case-insensitive index Index is a language name. Indicates if the object files created by the compiler for a language need to be linked in the executable. Only authorized case-insensitive values are "false" and "true" (the default). * **Target**: single Value is the name of the target platform. Taken into account only in the main project. Note that when the target is specified on the command line (usually with a switch --target=), the value of attribute reference 'Target is the one specified on the command line. * **Runtime**: single, indexed, case-insensitive index Index is a language name. Indicates the runtime directory that is to be used when using the compiler of the language. Taken into account only in the main project, or its extended projects if any. Note that when the runtime is specified for a language on the command line (usually with a switch --RTS), the value of attribute reference 'Runtime for this language is the one specified on the command line. * **Runtime_Dir**: single, indexed, case-insensitive index Index is a language name. Value is the path name of the runtime directory for the language. * **Runtime_Library_Dirs**: list, indexed, case-insensitive index Index is a language name. Value is the path names of the directories where the runtime libraries are located. This attribute is not normally declared. * **Runtime_Library_Dir**: single, indexed, case-insensitive index Index is a language name. Value is the path name of the directory where the runtime libraries are located. This attribute is obsolete. * **Runtime_Source_Dirs**: list, indexed, case-insensitive index Index is a language name. Value is the path names of the directories where the sources of runtime libraries are located. This attribute is not normally declared. * **Runtime_Source_Dir**: single, indexed, case-insensitive index Index is a language name. Value is the path name of the directory where the sources of runtime libraries are located. This attribute is obsolete. * **Runtime_Library_Version**: single, indexed, case-insensitive index Index is a language name. Value is library version for the language. This attribute is not normally declared. * **Toolchain_Name**: single, indexed, case-insensitive index Index is a language name. Indicates the toolchain name that is to be used when using the compiler of the language. Taken into account only in the main project, or its extended projects if any. * **Configuration - Libraries** * **Library_Builder**: single Value is the path name of the application that is to be used to build libraries. Usually the path name of "gprlib". * **Library_Support**: single Indicates the level of support of libraries. Only authorized case-insensitive values are "static_only", "full" or "none" (the default). * **Configuration - Archives** * **Archive_Builder**: list Value is the name of the application to be used to create a static library (archive), followed by the options to be used. * **Archive_Builder_Append_Option**: list Value is the list of options to be used when invoking the archive builder to add project files into an archive. * **Archive_Indexer**: list Value is the name of the archive indexer, followed by the required options. * **Archive_Suffix**: single Value is the extension of archives. When not declared, the extension is ".a". * **Library_Partial_Linker**: list Value is the name of the partial linker executable, followed by the required options. * **Configuration - Shared Libraries** * **Shared_Library_Prefix**: single Value is the prefix in the name of shared library files. When not declared, the prefix is "lib". * **Shared_Library_Suffix**: single Value is the extension of the name of shared library files. When not declared, the extension is ".so". * **Symbolic_Link_Supported**: single Indicates if symbolic links are supported on the platform. Only authorized case-insensitive values are "true" and "false" (the default). * **Library_Major_Minor_Id_Supported**: single Indicates if major and minor ids for shared library names are supported on the platform. Only authorized case-insensitive values are "true" and "false" (the default). * **Library_Auto_Init_Supported**: single Indicates if auto-initialization of Stand-Alone Libraries is supported. Only authorized case-insensitive values are "true" and "false" (the default). * **Shared_Library_Minimum_Switches**: list, configuration concatenable Value is the list of required switches when linking a shared library. * **Library_Version_Switches**: list, configuration concatenable Value is the list of switches to specify a internal name for a shared library. * **Library_Install_Name_Option**: single Value is the name of the option that needs to be used, concatenated with the path name of the library file, when linking a shared library. .. _Package_Binder_Attributes: Package Binder Attributes ^^^^^^^^^^^^^^^^^^^^^^^^^ * **General** * **Default_Switches**: list, indexed, case-insensitive index, configuration concatenable Index is a language name. Value is the list of switches to be used when binding code of the language, if there is no applicable attribute Switches. * **Switches**: list, optional index, indexed, case-insensitive index, others allowed, configuration concatenable Index is either a language name or a source file name. Value is the list of switches to be used when binding code. Index is either the source file name of the executable to be bound or the language name of the code to be bound. * **Configuration - Binding** * **Driver**: single, indexed, case-insensitive index Index is a language name. Value is the name of the application to be used when binding code of the language. * **Required_Switches**: list, indexed, case-insensitive index, configuration concatenable Index is a language name. Value is the list of the required switches to be used when binding code of the language. * **Prefix**: single, indexed, case-insensitive index Index is a language name. Value is a prefix to be used for the binder exchange file name for the language. Used to have different binder exchange file names when binding different languages. * **Objects_Path**: single,indexed, case-insensitive index Index is a language name. Value is the name of the environment variable that contains the path for the object directories. * **Object_Path_File**: single,indexed, case-insensitive index Index is a language name. Value is the name of the environment variable. The value of the environment variable is the path name of a text file that contains the list of object directories. .. _Package_Builder_Attributes: Package Builder Attributes ^^^^^^^^^^^^^^^^^^^^^^^^^^ * **Default_Switches**: list, indexed, case-insensitive index, configuration concatenable Index is a language name. Value is the list of builder switches to be used when building an executable of the language, if there is no applicable attribute Switches. * **Switches**: list, optional index, indexed, case-insensitive index, others allowed, configuration concatenable Index is either a language name or a source file name. Value is the list of builder switches to be used when building an executable. Index is either the source file name of the executable to be built or its language name. * **Global_Compilation_Switches**: list, optional index, indexed, case-insensitive index, configuration concatenable Index is a language name. Value is the list of compilation switches to be used when building an executable. Index is either the source file name of the executable to be built or its language name. * **Executable**: single, indexed, case-insensitive index Index is an executable source file name. Value is the simple file name of the executable to be built. * **Executable_Suffix**: single Value is the extension of the file names of executable. When not specified, the extension is the default extension of executables on the platform. * **Global_Configuration_Pragmas**: single Value is the file name of a configuration pragmas file that is specified to the Ada compiler when compiling any Ada source in the project tree. * **Global_Config_File**: single, indexed, case-insensitive index Index is a language name. Value is the file name of a configuration file that is specified to the compiler when compiling any source of the language in the project tree. .. _Package_Check_Attributes: Package Check Attributes ^^^^^^^^^^^^^^^^^^^^^^^^ * **Default_Switches**: list, indexed, case-insensitive index, configuration concatenable Index is a language name. Value is a list of switches to be used when invoking `gnatcheck` for a source of the language, if there is no applicable attribute Switches. * **Switches**: list, optional index, indexed, case-insensitive index, others allowed, configuration concatenable Index is a source file name. Value is the list of switches to be used when invoking `gnatcheck` for the source. .. _Package_Clean_Attributes: Package Clean Attributes ^^^^^^^^^^^^^^^^^^^^^^^^ * **Switches**: list, configuration concatenable Taken into account only in the main project. Value is a list of switches to be used by the cleaning application. * **Source_Artifact_Extensions**: list, indexed, case-insensitive index Index is a language names. Value is the list of extensions for file names derived from object file names that need to be cleaned in the object directory of the project. * **Object_Artifact_Extensions**: list, indexed, case-insensitive index Index is a language names. Value is the list of extensions for file names derived from source file names that need to be cleaned in the object directory of the project. * **Artifacts_In_Object_Dir**: single Value is a list of file names expressed as regular expressions that are to be deleted by gprclean in the object directory of the project. * **Artifacts_In_Exec_Dir**: single Value is list of file names expressed as regular expressions that are to be deleted by gprclean in the exec directory of the main project. .. _Package_Compiler_Attributes: Package Compiler Attributes ^^^^^^^^^^^^^^^^^^^^^^^^^^^ * **General** * **Default_Switches**: list, indexed, case-insensitive index, configuration concatenable Index is a language name. Value is a list of switches to be used when invoking the compiler for the language for a source of the project, if there is no applicable attribute Switches. * **Switches**: list, optional index, indexed, case-insensitive index, others allowed, configuration concatenable Index is a source file name or a language name. Value is the list of switches to be used when invoking the compiler for the source or for its language. * **Local_Configuration_Pragmas**: single Value is the file name of a configuration pragmas file that is specified to the Ada compiler when compiling any Ada source in the project. * **Local_Config_File**: single, indexed, case-insensitive index Index is a language name. Value is the file name of a configuration file that is specified to the compiler when compiling any source of the language in the project. * **Configuration - Compiling** * **Driver**: single, indexed, case-insensitive index Index is a language name. Value is the name of the executable for the compiler of the language. * **Language_Kind**: single, indexed, case-insensitive index Index is a language name. Indicates the kind of the language, either file based or unit based. Only authorized case-insensitive values are "unit_based" and "file_based" (the default). * **Dependency_Kind**: single, indexed, case-insensitive index Index is a language name. Indicates how the dependencies are handled for the language. Only authorized case-insensitive values are "makefile", "ali_file", "ali_closure" or "none" (the default). * **Required_Switches**: list, indexed, case-insensitive index, configuration concatenable Equivalent to attribute Leading_Required_Switches. * **Leading_Required_Switches**: list, indexed, case-insensitive index, configuration concatenable Index is a language name. Value is the list of the minimum switches to be used at the beginning of the command line when invoking the compiler for the language. * **Trailing_Required_Switches**: list, indexed, case-insensitive index, configuration concatenable Index is a language name. Value is the list of the minimum switches to be used at the end of the command line when invoking the compiler for the language. * **PIC_Option**: list, indexed, case-insensitive index Index is a language name. Value is the list of switches to be used when compiling a source of the language when the project is a shared library project. * **Source_File_Switches**: single, indexed, case-insensitive index configuration concatenable Index is a language name. Value is a list of switches to be used just before the path name of the source to compile when invoking the compiler for a source of the language. * **Object_File_Suffix**: single, indexed, case-insensitive index Index is a language name. Value is the extension of the object files created by the compiler of the language. When not specified, the extension is the default one for the platform. * **Object_File_Switches**: list, indexed, case-insensitive index, configuration concatenable Index is a language name. Value is the list of switches to be used by the compiler of the language to specify the path name of the object file. When not specified, the switch used is "-o". * **Multi_Unit_Switches**: list, indexed, case-insensitive index, configuration concatenable Index is a language name. Value is the list of switches to be used to compile a unit in a multi unit source of the language. The index of the unit in the source is concatenated with the last switches in the list. * **Multi_Unit_Object_Separator**: single, indexed, case-insensitive index Index is a language name. Value is the string to be used in the object file name before the index of the unit, when compiling a unit in a multi unit source of the language. * **Configuration - Mapping Files** * **Mapping_File_Switches**: list, indexed, case-insensitive index, configuration concatenable Index is a language name. Value is the list of switches to be used to specify a mapping file when invoking the compiler for a source of the language. * **Mapping_Spec_Suffix**: single, indexed, case-insensitive index Index is a language name. Value is the suffix to be used in a mapping file to indicate that the source is a spec. * **Mapping_Body_Suffix**: single, indexed, case-insensitive index Index is a language name. Value is the suffix to be used in a mapping file to indicate that the source is a body. * **Configuration - Config Files** * **Config_File_Switches**: list: single, indexed, case-insensitive index, configuration concatenable Index is a language name. Value is the list of switches to specify to the compiler of the language a configuration file. * **Config_Body_File_Name**: single, indexed, case-insensitive index Index is a language name. Value is the template to be used to indicate a configuration specific to a body of the language in a configuration file. * **Config_Body_File_Name_Index**: single, indexed, case-insensitive index Index is a language name. Value is the template to be used to indicate a configuration specific to the body a unit in a multi unit source of the language in a configuration file. * **Config_Body_File_Name_Pattern**: single, indexed, case-insensitive index Index is a language name. Value is the template to be used to indicate a configuration for all bodies of the languages in a configuration file. * **Config_Spec_File_Name**: single, indexed, case-insensitive index Index is a language name. Value is the template to be used to indicate a configuration specific to a spec of the language in a configuration file. * **Config_Spec_File_Name_Index**: single, indexed, case-insensitive index Index is a language name. Value is the template to be used to indicate a configuration specific to the spec a unit in a multi unit source of the language in a configuration file. * **Config_Spec_File_Name_Pattern**: single, indexed, case-insensitive index Index is a language name. Value is the template to be used to indicate a configuration for all specs of the languages in a configuration file. * **Config_File_Unique**: single, indexed, case-insensitive index Index is a language name. Indicates if there should be only one configuration file specified to the compiler of the language. Only authorized case-insensitive values are "true" and "false" (the default). * **Configuration - Dependencies** * **Dependency_Switches**: list, indexed, case-insensitive index, configuration concatenable Index is a language name. Value is the list of switches to be used to specify to the compiler the dependency file when the dependency kind of the language is file based, and when Dependency_Driver is not specified for the language. * **Dependency_Driver**: list, indexed, case-insensitive index Index is a language name. Value is the name of the executable to be used to create the dependency file for a source of the language, followed by the required switches. * **Configuration - Search Paths** * **Include_Switches**: list, indexed, case-insensitive index, configuration concatenable Index is a language name. Value is the list of switches to specify to the compiler of the language to indicate a directory to look for sources. * **Include_Path**: single, indexed, case-insensitive index Index is a language name. Value is the name of an environment variable that contains the path of all the directories that the compiler of the language may search for sources. * **Include_Path_File**: single, indexed, case-insensitive index Index is a language name. Value is the name of an environment variable the value of which is the path name of a text file that contains the directories that the compiler of the language may search for sources. * **Object_Path_Switches**: list, indexed, case-insensitive index, configuration concatenable Index is a language name. Value is the list of switches to specify to the compiler of the language the name of a text file that contains the list of object directories. When this attribute is not declared, the text file is not created. * **Configuration - Response Files** * **Max_Command_Line_Length**: single Value is the maximum number of character in the command line when invoking a compiler that supports response files. * **Response_File_Format**: single, indexed, case-insensitive index Indicates the kind of response file to create when the length of the compiling command line is too large. The index is the name of the language for the compiler. Only authorized case-insensitive values are "none", "gnu", "object_list", "gcc_gnu", "gcc_option_list" and "gcc_object_list". * **Response_File_Switches**: list, indexed, case-insensitive index, configuration concatenable Value is the list of switches to specify a response file for a compiler. The index is the name of the language for the compiler. .. _Package_Cross_Reference_Attributes: Package Cross_Reference Attributes ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ * **Default_Switches**: list, indexed, case-insensitive index, configuration concatenable Index is a language name. Value is a list of switches to be used when invoking `gnatxref` for a source of the language, if there is no applicable attribute Switches. * **Switches**: list, optional index, indexed, case-insensitive index, others allowed, configuration concatenable Index is a source file name. Value is the list of switches to be used when invoking `gnatxref` for the source. .. _Package_Documentation_Attributes: Package Documentation Attributes ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Please refer to GNATdoc documentation for the list of supported attributes and their meaning. .. _Package_Finder_Attributes: Package Finder Attributes ^^^^^^^^^^^^^^^^^^^^^^^^^ * **Default_Switches**: list, indexed, case-insensitive index, configuration concatenable Index is a language name. Value is a list of switches to be used when invoking `gnatfind` for a source of the language, if there is no applicable attribute Switches. * **Switches**: list, optional index, indexed, case-insensitive index, others allowed, configuration concatenable Index is a source file name. Value is the list of switches to be used when invoking `gnatfind` for the source. .. _Package_gnatls_Attributes: Package Gnatls Attributes ^^^^^^^^^^^^^^^^^^^^^^^^^ * **Switches**: list Taken into account only in the main project. Value is a list of switches to be used when invoking `gnatls`. Package gnatstub Attributes ^^^^^^^^^^^^^^^^^^^^^^^^^^^ * **Default_Switches**: list, indexed, case-insensitive index, configuration concatenable Index is a language name. Value is a list of switches to be used when invoking `gnatstub` for a source of the language, if there is no applicable attribute Switches. * **Switches**: list, optional index, indexed, case-insensitive index, others allowed, configuration concatenable Index is a source file name. Value is the list of switches to be used when invoking `gnatstub` for the source. .. _Package_IDE_Attributes: Package IDE Attributes ^^^^^^^^^^^^^^^^^^^^^^ Please refer to your IDE documentation for the list of supported attributes and their meaning. .. _Package_Install_Attributes: Package Install Attributes ^^^^^^^^^^^^^^^^^^^^^^^^^^ * **Artifacts**: list, indexed An indexed attribute to declare a set of files not part of the sources to be installed. The array index is the directory where the file is to be installed. If a relative directory then Prefix (see below) is prepended. Note also that if the same file name occurs multiple time in the attribute list, the last one will be the one installed. If an artifact is not found a warning is displayed. * **Required_Artifacts**: list, indexed As above, but artifacts must be present or an error is reported. * **Prefix**: single Value is the install destination directory. If the value is a relative path, it is taken as relative to the global prefix directory. That is, either the value passed to `--prefix` option or the default installation prefix. * **Sources_Subdir**: single Value is the sources directory or subdirectory of Prefix. * **Exec_Subdir**: single Value is the executables directory or subdirectory of Prefix. * **ALI_Subdir**: single Value is ALI directory or subdirectory of Prefix. * **Lib_Subdir**: single Value is library directory or subdirectory of Prefix. * **Project_Subdir**: single Value is the project directory or subdirectory of Prefix. * **Active**: single Indicates that the project is to be installed or not. Case-insensitive value "false" means that the project is not to be installed, all other values mean that the project is to be installed. * **Mode**: single Value is the installation mode, it is either **dev** (default) or **usage**. * **Install_Name**: single Specify the name to use for recording the installation. The default is the project name without the extension. * **Side_Debug**: single Indicates that the project's executable and shared libraries are to be stripped of the debug symbols. Those debug symbols are written into a side file named after the original file with the ".debug" extension added. Case-insensitive value "false" (default) disables this feature. Set it to "true" to activate. * **Install_Project**: single Indicates that a project is to be generated and installed. The value is either "true" to "false". Default is "true". .. _Package_Linker_Attributes: Package Linker Attributes ^^^^^^^^^^^^^^^^^^^^^^^^^ * **General** * **Required_Switches**: list, configuration concatenable Value is a list of switches that are required when invoking the linker to link an executable. * **Default_Switches**: list, indexed, case-insensitive index, configuration concatenable Index is a language name. Value is a list of switches for the linker when linking an executable for a main source of the language, when there is no applicable Switches. * **Leading_Switches**: list, optional index, indexed, case-insensitive index, others allowed, configuration concatenable Index is a source file name or a language name. Value is the list of switches to be used at the beginning of the command line when invoking the linker to build an executable for the source or for its language. * **Switches**: list, optional index, indexed, case-insensitive index, others allowed, configuration concatenable Index is a source file name or a language name. Value is the list of switches to be used when invoking the linker to build an executable for the source or for its language. * **Trailing_Switches**: list, optional index, indexed, case-insensitive index, others allowed, configuration concatenable Index is a source file name or a language name. Value is the list of switches to be used at the end of the command line when invoking the linker to build an executable for the source or for its language. These switches may override the Required_Switches. .. index:: Linker_Options attribute * **Linker_Options**: list, configuration concatenable This attribute specifies a list of additional switches to be given to the linker when linking an executable. It is ignored when defined in the main project and taken into account in all other projects that are imported directly or indirectly. These switches complement the ``Linker'Switches`` defined in the main project. This is useful when a particular subsystem depends on an external library: adding this dependency as a ``Linker_Options`` in the project of the subsystem is more convenient than adding it to all the ``Linker'Switches`` of the main projects that depend upon this subsystem. * **Map_File_Option**: single Value is the switch to specify the map file name that the linker needs to create. * **Unconditionally_Linked**: single, indexed, case-insensitive index Index is a language name. Indicates that all object files of this language going to be linked unconditionally. Only case-insensitive values allowed are "true" and "false", the default. * **Configuration - Linking** * **Driver**: single Value is the name of the linker executable. * **Configuration - Response Files** * **Max_Command_Line_Length**: single Value is the maximum number of character in the command line when invoking the linker to link an executable. * **Response_File_Format**: single Indicates the kind of response file to create when the length of the linking command line is too large. Only authorized case-insensitive values are "none", "gnu", "object_list", "gcc_gnu", "gcc_option_list" and "gcc_object_list". * **Response_File_Switches**: list, configuration concatenable Value is the list of switches to specify a response file to the linker. .. _Package_Metrics_Attribute: Package Metrics Attribute ^^^^^^^^^^^^^^^^^^^^^^^^^ * **Default_Switches**: list, indexed, case-insensitive index, configuration concatenable Index is a language name. Value is a list of switches to be used when invoking `gnatmetric` for a source of the language, if there is no applicable attribute Switches. * **Switches**: list, optional index, indexed, case-insensitive index, others allowed, configuration concatenable Index is a source file name. Value is the list of switches to be used when invoking `gnatmetric` for the source. .. _Package_Naming_Attributes: Package Naming Attributes ^^^^^^^^^^^^^^^^^^^^^^^^^ * **Specification_Suffix**: single, indexed, case-insensitive index Equivalent to attribute Spec_Suffix. .. warning:: Also has case-insensitive values in gprbuild and GNATcool.Project-based tools * **Spec_Suffix**: single, indexed, case-insensitive index Index is a language name. Value is the extension of file names for specs of the language. .. warning:: Also has case-insensitive values in gprbuild and GNATcool.Project-based tools * **Implementation_Suffix**: single, indexed, case-insensitive index Equivalent to attribute Body_Suffix. .. warning:: Also has case-insensitive values in gprbuild and GNATcool.Project-based tools * **Body_Suffix**: single, indexed, case-insensitive index Index is a language name. Value is the extension of file names for bodies of the language. .. warning:: Also has case-insensitive values in gprbuild and GNATcool.Project-based tools * **Separate_Suffix**: single Value is the extension of file names for subunits of Ada. * **Casing**: single Indicates the casing of sources of the Ada language. Only authorized case-insensitive values are "lowercase", "uppercase" and "mixedcase". * **Dot_Replacement**: single Value is the string that replace the dot of unit names in the source file names of the Ada language. * **Specification**: single, optional index, indexed, case-insensitive index Equivalent to attribute Spec. * **Spec**: single, optional index, indexed, case-insensitive index Index is a unit name. Value is the file name of the spec of the unit. * **Implementation**: single, optional index, indexed, case-insensitive index Equivalent to attribute Body. * **Body**: single, optional index, indexed, case-insensitive index Index is a unit name. Value is the file name of the body of the unit. * **Specification_Exceptions**: list, indexed, case-insensitive index Index is a language name. Value is a list of specs for the language that do not necessarily follow the naming scheme for the language and that may or may not be found in the source directories of the project. * **Implementation_Exceptions**: list, indexed, case-insensitive index Index is a language name. Value is a list of bodies for the language that do not necessarily follow the naming scheme for the language and that may or may not be found in the source directories of the project. .. _Package_Pretty_Printer_Attributes: Package Pretty_Printer Attributes ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ * **Default_Switches**: list, indexed, case-insensitive index, configuration concatenable Index is a language name. Value is a list of switches to be used when invoking `gnatpp` for a source of the language, if there is no applicable attribute Switches. * **Switches**: list, optional index, indexed, case-insensitive index, others allowed, configuration concatenable Index is a source file name. Value is the list of switches to be used when invoking `gnatpp` for the source. .. _Package_Remote_Attributes: Package Remote Attributes ^^^^^^^^^^^^^^^^^^^^^^^^^ * **Included_Patterns**: list If this attribute is defined it sets the patterns to synchronized from the master to the slaves. It is exclusive with Excluded_Patterns, that is it is an error to define both. * **Included_Artifact_Patterns**: list If this attribute is defined it sets the patterns of compilation artifacts to synchronized from the slaves to the build master. This attribute replace the default hard-coded patterns. * **Excluded_Patterns**: list Set of patterns to ignore when synchronizing sources from the build master to the slaves. A set of predefined patterns are supported (e.g. \*.o, \*.ali, \*.exe, etc.), this attributes make it possible to add some more patterns. * **Root_Dir**: single Value is the root directory used by the slave machines. .. _Package_Stack_Attributes: Package Stack Attributes ^^^^^^^^^^^^^^^^^^^^^^^^ * **Switches**: list, configuration concatenable Taken into account only in the main project. Value is the list of switches to be used when invoking `gnatstack`. Package Synchronize Attributes ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ * **Default_Switches**: list, indexed, case-insensitive index Index is a language name. Value is a list of switches to be used when invoking `gnatsync` for a source of the language, if there is no applicable attribute Switches. * **Switches**: list, optional index, indexed, case-insensitive index, others allowed Index is a source file name. Value is the list of switches to be used when invoking `gnatsync` for the source. .. index:: environment_variables .. _Environment_Variables: Environment Variables --------------------- Project processing can be affected by environment variables. * **GPR_CONFIG** When declared with a non empty name, use its value as the default configuration project file name in native platforms, instead of "default.cgpr". * **GPR_RUNTIME_PATH** Path where to look for a non empty runtime directory. * **PATH** The path, that may be modified to add the directories related to the compilers. * **GPR_PROJECT_PATH_FILE** The path to a file containing project directory path names * **GPR_PROJECT_PATH** The path where to look for projects * **ADA_PROJECT_PATH** The path where to look for projects * **TMPDIR** Directories where to create temporary files * **TEMP** Directories where to create temporary files * **TMP** Directories where to create temporary files * **GPR_VERBOSITY** Value for the quiet mode or the verbosity level. Overriden with switches -q, -v and -vP? * **USER** Used to communicate with a slave in distributed gprbuild. * **USERNAME** Used to communicate with a slave in distributed gprbuild. * **GPRBIND_DEBUG** When value is "TRUE", keep a copy of the binder exchange file sent to gprbind as main.bexch__saved * **GPRLIB_DEBUG** When value is "TRUE", keep a copy of the library exchange file sent to gprlib as main.lexch__saved .. _Project_File_Glossary: Glossary ======== .. glossary:: Abstract project A project with no source files, typically used to define common attributes that are shared by other project files. See :ref:`Sharing_between_Projects`. Aggregate project A project that in effect combines several projects in order to efficiently support concurrent builds or builds of all main programs from the constituent projects, or the convenient definition of a common environment for the constituent projects. See :ref:`Aggregate_Projects`. Attribute A named property of a project or one of its packages. See :ref:`Attributes`. Base project A project that is extended by some other project. See :ref:`Project_Extension`. Child project A project that is defined by a name ``Parent_proj.Child_proj`` where ``Child_proj`` either imports or extends ``Parent_Proj``. This feature is typically used to show a close relationship between the two projects, for example where the child project serves as a testbed for the parent. See :ref:`Child_Projects`. Configuration project A project that describes compilers and other tools, for use by *GPRbuild*. See :ref:`Configuration Project`. Extending a project The reuse and possible adaption by one project of the source files from another project (the base project). Somewhat analogous to (single) class inheritance in object-oriented programming. See :ref:`Project_Extension`. External variable A variable that is defined on the command line (by the :option:`-X` switch), as the value of an environment variable, or, by default, as the second parameter to the ``external`` function. See :ref:`Scenarios_in_Projects`. Global attribute An attribute that applies to all projects in the project import closure of a main project. See :ref:`Global_Attributes`. Importing a project The usage of a |with| or |limited_with| clause on a project file in order to reuse properties of some other project file. See :ref:`Importing_Projects`. Independent project A project defined by a single project file and thus not dependent on any other projects. See :ref:`Independent Project`. Library project A project that is used to define a library rather than an executable program. See :ref:`Library_Projects`. Main project A project that is specified on the command line. See :ref:`Global_Attributes`. Package A grouping of attribute definitions related to a particular GNAT tool. See :ref:`Packages`. Parent project A project that has one or more child projects. See :ref:`Child_Projects`. Project A set of named properties and their values, associated with the GNAT tools that are used during the development of software in Ada and other languages. Properties include directories for source files, object files, and executables; the switch settings for the various tools; and the naming scheme for source files. Project extension See glossary item `Extending a project` Project file A textual representation of a project, which uses an Ada-like notation. The syntax is presented in :ref:`Project_File_Reference`. Project import closure The *project import closure* for a given project `proj` is the set of projects consisting of `proj` itself, together with each project that is directly or indirectly imported by `proj`. The import may be from either a |with| or a |limited_with|. See :ref:`Project Import Closure`. Scenario The values of a project's variables and attributes, as determined by the settings of external variables referenced by a project. A scenario typically defines a particular mode of usage for the project. See :ref:`Scenarios_in_Projects`. Scenario variable An external variable, typically assigned to a typed variable and queried in a `case construction`. See :ref:`Scenario variable`. Standard project A non-library project with source files. See :ref:`Standard project` Typed variable A project variable that can take any of a specified set of values, analogous to a variable of an Ada enumeration type but where the values are string literals. See :ref:`Scenarios_in_Projects`. gprbuild-25.0.0/doc/gprbuild_ug/importing_and_project_extension_figure_1.png000066400000000000000000000102461470075373400274360ustar00rootroot00000000000000‰PNG  IHDR@€rD--sRGB@À}ÅPLTEI} %@a)Fj0Ji(Dg*Hm$M€4Z‰(P‚-U…9^Œ5Xƒ:a1…œ6ˆž?£:Š U2LD^z\p‰Jl–QršDq¦I“¨Y¯Z°O½U…¿Z‰Áhhhb¤e‚¥x‘±p™ÊvÌe‘Åoªºr«»u­½y°¿{¡Î’ 0ŸŸŸ‡‡‡ƒš·‹ »’¦¿Ž£½¼È‘±ÖŸ±Ç™¬Äœ¹Ú˜ÂÍ···¨¹Í°ÐÙ¢ÈÒ®ÏظÕݱÀÒ§ËÕ©ÌÕ´ÓÛ§ÀÞ½Øß½ÏæÈÏ×ÄÜãÊÔàÈ×êÏØãÂÓèÓßîÏâèÓåêÞçòÿÿÿÿ ÿÿÿ22ÿPPÿMMÿLLÿHHÿ@@ÿÿrrÿffÿÿ’’ÿƒƒÿŸŸÿÿŒŒÿ‹‹ÿ§§ÿ¿¿ÿÞÞÿÉÉÿÃÃÿÏÏÿÇÇùûüüýý÷úûäïòôøúîõ÷åðóâîñÿûûéï÷ÿççÿ÷÷ûüüÿêêÿõõìðôö÷ùâçî÷ùúîóùô÷ûãëõÿÿÿãVüù pHYsÄÄ•+tEXtSoftwareMicrosoft Officeí5q‹IDATxÚíÝ‹[UÇq×1‹K£+—eé&F—‹†.îÒ&mÍ& {s[ØaJK]©(*4᢭Ц^öüá{Þs†kIf˜ !—ïïyâœLÒÆûn8€¢Ûífâ©Nÿœk«Rºåùn8€Rø"@P´ùw«mð9öä÷¢Q ”ÕRj|ˆñÿÓ<€|» èw{ßVÍó5Z WýnO”&{ÚWùn—ÓeäwGóý¡·88›¦ Ô-d~hz@º"OPäHjŒùéÑ,zöϦÑ÷û¶6÷Ï¥i< Õ¹µ3W Ú])T9@õ*èâ®w±·èÙ?›FîžKsž€<ŽPí®d« N4åÜŽè•žø²gÓ4= výëŠ szJ«? á¡½@¯t}tú 9õª ǧY¤Ë“ölš¬:Ç!l}Þu—ÕÒÜÚÓ»Ÿßw]wÃ[³¾ð…ë>TjÉu?›[{v_©–•…/wOªÝ•¿%«L´ÂÎ(•2„Ž| ÓSLbz¯{§Í*õ÷ídZNH÷û vV@ëó"fãéÝŸÜÛ5È[³>ÿà±fµ>¿üìþÜÚÒ½Ý/²âº†ÐÑOa5»¢Ç³ÓgAQfºGgèªãäÕÌ¥kŽ3!kå^%>âÜÔÍÛÏõý*•d]è7Ñ«®dY ͆¼5ZŽnnhC2„­Ö*@Èâ›h5š:-/ÚËh6ïýh›zM^éE%þúO¶e¤q$©êýu”€Þsƒä( cIy€6li: Hé1lùð_þª ¿P*XÊ›©PFé*Ô×-YTâyo›ò/@¶¥®?¹Ð ´>ÿÐ㲨™,ê‘êpZuÍö•ž"=¬]ÜÅo¨@‘Rz ËtýÉEÿ˜*#ÖÜš–#pÌHe×x€Ô¢ë~½ ù¸5fAè¿ßðcj(@fóîy€ôðuS·'|]7Ÿä[ÿ×ø÷ÓGÑô¤]6“èŒÌœ•$ÃW%½˜ÿx_µ> oEÕ“t€t¬'áOmê8@ÍqÜ6 :Nm€ê:µ @ªëÔ&¨®S› ºNm€ê:µ @ªëÔ&¨®S› È7@€ @€ @€ @€ @€ IW,Ât]$ ßž¼fóDöóÎÏa ˆØL§Þ ŸÑÔ[!J€ˆÍt*¦ˆØÈŸÀ Q‚DL¦Í_¥={ 1±ƒûì%@DòñøøxJß>ièî€ @"€ @@j∈@€DD ¨™3åÜ9O@ÃC{"á R#ºÍt8ÎÐUÇÉ«™K×gBÖʽJ|Ĺ1¨›·ŸëÿúU*u. ¡½Œf3üÚ¶©×ä•^Tâ¯ÿd+PF"UåÍT(#€têÎë–,*ñ¼²€¦ü €TÒcX@ļ{ =|ÝÔí @—Í$:#3geÉðU‰;¾³ ·Â¹°ˆˆ@€DD ‹ÿk3€ @"€ @@€ ˆˆ@€DD @PëˆÊÁž6€…Në‰21,ÔHõƒõaIuZbÑîQ@€ @€ @€ @"€ @€äÛ©¬€Ôd€ÒåC€ô tù–RÅ(•ëI”t«WW ôö‡JMÊ£}[úùÅ+ö~¢tKå €Š½­cv3ùf¯Œ_HÖm&e<ÛéOo'ísÆ¥~*Ph@ß=([ PÎL{4©@ œ7Ò€²›I¹¯o‰RŽ!,< s9([ЬÖrPº,c[‡šrnŸ' œ7Œù”­ ¨pPº‰õD—XSŠEºÝ€ @€ @€ @€ @€ @€ @õìîÙb/€ ™«8žßî.(•óšé²´ ›ÉDéƒ-ýÄ1½®OÅ+Û*5Ù“(Ý:xrsòzã³Õ:s=âp€²j¬¯Øïù“[¢T,îôïW ìNz;™.{ J?´Óþhun-, ýÞøl5CXt€fwnÖ<š“£x¬ç ì¦~+rÚV.QÊE:„->x- ýÞøluçU ™îǺê8y5séš¹ñ”#÷*ñçÆ \šøù p¨«hìÈ0à²ÃZsúa· Ÿ­îD@rô 5|pEt¹ªlF.c-W±– ”ñ½œµz÷£éßó¯ý½>i¹Ùͤy/ôš‚qt0Ô h}Þu—ÕÒÜÚÓ»Ÿßw]wÃ[³¾ð…ë>TjÉu?›[{v_ñËÊ—»Ç{dzó'ß­îD@G®ˆž—kë–,ìÑДJ¥ ¡ã“èÙÃItV?¸™Ôr„’¾3¦—²NßÛéh½€ÖçEÌÆÓ»>¹·k*·f}þÁcÍj}~ùÙý¹µ¥{»^lÅu-¡Ø±Þøo5€N¤ô–÷dåCoßÖ¤¾¯”sÑ|Œ_u%ËRh6ìæ­ÑrtsC’!l5H@–PìŒ[ÝN€Æ«¦* 3„y÷<@zøº©ÛG^ù”WL™¼ûÛ“{3Q2ÿâÔ½m«RºÚ[ñž$GYK¢È´aKÓQ@Jaˇÿªö«/<Šq«ÛÐÇwª¦* Ëf‘™³²€døªÄc³ S^Ѻþ› ü)c}þ¡ÇeQ3YÔ#Õá´êš!ì+=Ez¬¹Ÿ>êä/ϱ¶Ü Ÿ'û[˜ŒXskZŽÀ1#•]ãR‹®ûõ‚æ㘭X>ýMtƒi>môcêŠå FÅði#@ß>òjh8@€ @€ @€ @€ @€ @€ @€ @PÒ‹.]-Ú£.‘ó €€€€ @"""€Dši»4ÐËìmÕè/ìíöˈ    BDDDDˆOþͺމÍ’IEND®B`‚gprbuild-25.0.0/doc/gprbuild_ug/importing_and_project_extension_figure_2.png000066400000000000000000000113031470075373400274320ustar00rootroot00000000000000‰PNG  IHDR@€rD--sRGB@À}ÅãPLTEI} 3<[%@a0Ji(Dg0Px)Fj&Bd$M€4Z‰(P‚-U…9^Œ3V-T…"L7_Ž:a1…œ6ˆž7—3…ž?£:Š D^z\p‰Jl–QršIk–J~»@q«Fs©I“¨Y¯Z°O½P‚½U…¿Z‰Áhhhb¤a£e‚¥x‘±p™ÊršÊvÌl–ÈxŸÌ`Ãoªºr«»u­½y°¿{¡Î’ 0$>ŸŸŸ‡‡‡ƒš·‹ »’¦¿Ž£½¼ÈŸ±Ç™¬Äš·Ùœ¹Ú‘±Ö˜ÂÍ­%···¨¹Í¢½Ü°ÐÙ¢ÈÒ®ÏظÕݱÀÒ§ÀÞ§ËÕ©ÌÕ´ÓÛ½Øß»Îå½Ïæ²ÇâÈÏ×ÄÜãÊÔàÏØãÓßîÈ×êÆÖéÌÕáÏâèÓåêÝçòÞçòÿÿÿÿ ÿÿÿÿÿ22ÿ ÿPPÿMMÿLLÿ@@ÿÿrrÿffÿ``ÿppÿÿ’’ÿƒƒÿŒŒÿ‹‹ÿ——ÿŸŸÿÿ§§ÿ¿¿ÿÞÞÿßßÿÉÉÿÃÃÿÏÏùûüüýý÷úûäïòôøúîõ÷åðóâîñûüüÿûûô÷ûìðôö÷ùÿêêÿõõâçî÷ùúÿ÷÷ÿïïãëõîóùùûýÿççÿÿÿŸ£šÃ pHYsÄÄ•+tEXtSoftwareMicrosoft Officeí5qTIDATxÚíÝ‹[ÛÖÇñ®j]'ë6Ø KÊuÛ1H—Ìdé6“´óæ¹…îÒn&Å-(´%Кnô²–3.I“Ô¹¯ëùS÷ž#!ÅH¶dìïïyK²âGçøã÷ÛJôˆ"$@¡ €€€€‰0 ?<öiæ<ö›Æú]Üäy´±€èà¦OÃ1î7ó”@@@@€€€€ ˆˆˆˆ¨ N„™ÃñnŠßÃP%‰¶0“ˆwSü>€ @€ 5º×Ç í€ÔÐ^ï^VjCJzE©l[~µ§{ù¥5Ùs@¶uè…ÂÉ«/+5,{Ÿ—" h£A^ Pzý©ö¶!ÅøзîåBáZçzºÖ™¾Ú“^)´ç•<$DÐFƒ¼@¡U u@Cæa)AfKÐЪ¼Y±•í^ÎF}Ûh×(”^—n®ròZÑ: gX‹ y8€Â”¯ aÃÎ]v|µG?¢·ä£‘ €ä@}8€BéuyŸ~¾â2cØj¼š’¬è×ÁŒk²pÝ™‹FÓ  {½z:Ö†åV8¹’ÙÇxÏPx½n&žjûϹNUJÇçhW*_$@ 5õÙ~ï¦ø=|Q¨@P” ɇ”>Äx‚‰ Ϧ(ü^ïXÛñ|8òn €Âïõîåá¶&äÝ…Þëútý»£ùþнÛ8›&¯Ôy èºþ ò€|4Eï2в€F¬Ñ½mu1?=š»¶õ³id½cmuý\š]´0±vSòUN“¾ÞuÊKq—.vïÚÖϦÑë•sihföfX€vnÊP•ÄV /¾ðîuçlšèºRcSô0׺§´JÛßoY½§-+§Æœ±¬A½U¯•“ýÖÙ#²8zKþܱR½þì+_<ÔëúÔ«¼~š»ôÊ°s6ÍjÜVš´íyUœX¼}éÃiÛ¶—Ü-¥©l{N©¢m0±xgZ?R=—gþSSSþÔSe¢Ý:€zod„MßÁ»Î¢lÉ)¹+'Ýs*PF/ì(•2„6tÉ+SÛ;éu÷ô q¥þ|µ'­OH÷ú V# Ò¤³tûÒì{oß7ÈÝRšœ½)¬J“ów¦'‹òàN¹lÛšï¦Èx¶ý,¨uåÌT(£IÚŸ“%}WNæÜ!lÄ£i@†Ðž~½`ëÌëB³ä aî‘#‹KbHa ; Hâ›hu,U55R2†å6=sµ§}ö»¡zÞö‘Í€E­È´ä”¦Í€”Œaó•¿UíyÿÖ”ª£™!Ì]sÉðuN–=+PêØ…=­@¥É9—ËŒ0™‘‘ª²EZ°Íö±L‘æ¼*Ð;ÅÇ©@õ:j&Ñ=sV =|•“Öγ × Ÿ½þ1UX‹"GÃ1#•³Å¤flû“)ácï8 º¬ù<àÇT€¶F[ª+¯>Íñküe͇_ãwÐ/8÷Íè_BjJ  œfZS ¶ §6@Nm€Ú :µ @ tj€èÔ&(ЩMP S› @§6@»rø€ @€ @€ @€ @€ è¡ìKøÊ7ýí¶o/í Ü¿‡ šóÜ—‘=4ÿùEXP­¹ØõBüý\H½ =Êñ®§ã_‚Ž¥ž ©ª1»ºâ_‚.¤Ra• Õ˜ã(ö%Hÿ¸!• Õ]€b_‚.˜ÿ–6œ ÚrÜŠy rþîpJ€jÊ›'Nœè’Û«qöóÖ©S§Rr{ @{’®8ã ½{ @€ @€ @‰pDD @""€šЈ5Ú/qc[ @]ß×{£ i€%€Û íüÞÛßoY½§-+§Æœ±¬A½U¯•“ýÖÙ#²8zKþŒòP×ØVÈ«ë{od¤ÃûÞueKNÉ]9yèžóÞÍè…¨jX+äÕõ93‰Èè®—÷ïþœ,é»r2§œ®‰vjp+¸ë•Tÿ\ìÕÛ ÕÐõ¦ø»kn×Ká?'˃1n+TC×5ÓÏŒžs*§ëuá/'­HÏ‚Û ùŽ~⟰[ ˆì]DD @""Š4 þi3€ @€ @€ @€ @€ @€ @€ zr*¾€'|å[þv;  ⳯ƒôèîJ´…™€vH¢ñ= @€šГ–g~â¹Ç“jY@Vdž@€ @€ @€ @€ @Š? !5 ð¥W²€ê-«Ðö€Ò+ç•*üE©l[÷²,µKJ_}Y©aýhÇšì_8é¬w/ŸWYÕ èºß> B{^Z2¾ÚóT»¿4 ½mµGg×:ÓW{œ}º—¯uRêdúÐOŸÆ PÖL{Œ®@. ¬;’Æ­öèu¹u/gwsÛŸ‹ …‰ÅºeÝa̳Oc h\Zö ôŠÛ"¨¯÷F£ÍÌÞ èJu@ž}g@ùÍ€Ò+ÃùB{¥üÈ? ûWdúÐOŸÆ¼5>_Ù hHï?àNwÐQˬ¬YVNeÞ-'ϱ,kT¶ÝÒ ½o8£÷+'û­\ @¥IÛžWʼnÅÛ—>œ¶m{ÉÝRšúȶç”*Úö‹w¦õ#ž€l‡Pž4ë¢ãݧMô1¾cmXn…“;}m  ÞŬŒê[9ÙûóC÷Ö+ÐÈ¡{cîºû•“ò@@¥I-féö¥Ù÷Þ¾o*»¥49{SX•&çïLO,åAÈv%êèÓfúH¿[œ ß^ÊU†±ó/–¥™ÚS4rð®»_9¹iÄûµí7›†'³>¯ Í’3„¹[DŽ,.‰!=„-l-@;?{1QGŸòEbC9¥(£­r†µíÕS\E­È´ä”¦Í€”Œaóþ*ÐåOù1uOmÂ]T}ïª>­dKÆ8ÚÂ*Mι\f„ÉŒŒT•-Ђm†°eŠ4çÐÔ§Š_ã÷žo ÐcØÁ»"GS’•Q¹7ãÚ¨;Ù ÈŒX‹"GÃ1#•³Å¤flû“)ácû˜ÙSŸÝ¯·¯ ÏÜ:2(·Þ7¶ù¸¿çßDv¿þ¾P˜€ÊIwú¼Mœª4E@Aú@»Tý$€ @€ @€ @€ @€ @€ @qô„÷e¿¿ç¹ÇjY@>òÜ—Qñ 8ºØõ€TŽw=› èºØÕŸT½¯_@û¾ò»íÛýÔŸT½¯úízt÷ùL*š/‰.@1*AÕr!õbHÏ ÚrÜŠÏ,¨JŽ¥ž © ª)ož8q¢Kn¯ÆÛÏ…T*¬ šÓo<:ÇPH%@-H °J€ZÐ1(œ ÖôÖ©S§Rr{ @ª7¡u/€ @€DD @"""€ZÐúµvãƶ@ºÞ½€sÌi€%€Û íüÞÛßoY½§Íâõuœk¥æT9Ùo=¢¯Û|KþŒòP×ØVÈ«ëõeáUŸ¾¼®¹B¼¾Ê®¹Pü¡{Î{7£¢¨a­W×çÌ$"ã\ŸYn²¤ïœ Å뮉vjp+¸ë•Tÿ\ìÕÛ ÕÐõ¦ø»kn×Ká?'˃1n+TC×5ÓÏŒžs*§ëuá/'­HÏ‚Û ùŽ~⟰[ ˆì]DD @""Š4 þi3€ @€ @€ @€ @€@‡}]iüû¾ö: '‡k¾ªz­Ç  MI´…—D$%~Ü€ @€ @€ @€ @€ @€ @>»{¼Ð @æbŽëî¼RYw1½¢—ó«=ÝË/­É~²­C/N^}Y©á¶îåó;7ÐÂÄbÝ-r›ãuØÚs=⺠©ŽB§ëg@ߺ— …këhèZgújOz¥ÐžWòеÎP+ÐÌìÍp­7Çë°ÂÂ4^éÛ!ó`V¿‰Ú6Z•W"+¶²ÝËÙ¶hZoŽ×a·\ÛßoY½§-+§Æœ1×#±ôZ9Ùo=¢/M|ëˆås¨« h`Ó(àr†µ•&m{^'o_úpÚ¶í%wKiê#ÛžSªhÛL,Þ™ÖxæJ5@^‡Ý‚€ôeÐUßÆÑõUe3ú2Öú*ÖºeDd»÷ÿFwï×q$âÐùyg„V3òÞ<Þ]`<¾•J—è–[ €@@ºÁ€þñé-•¹Oÿ<^@¿r‹KÞ'ãä—¾±²ï—ùH@ €@H@H @H$€@Ð$4_¹y€ô®Jmä* @@ € €H@@ € €@@@Ý@õƒ4íÌ„Áìa¸ÞY;z‘¦[áêË´úb¦¶™®‡Áæñ\ãh±ÑíÌl§ëõƒã9+†\~´yµjáQ?hÙÂ4  ýà&Ôè¦i† (lYîÖvvz·…¤¡……ç‡n´¯‡Á«ü †ôS³‡[áÑYë¶|¯ ªÅ(?D¤ òƒD@@ € €H@@H@@ € €ÒÀ¦Îüß½?;ëSiˆþøc!o PIúfá¯éâ=Xø]!K@åè›……b– €Êу¨% R b– €Jу PK@e軇.„Ç¿ÒE[(æm $€ € @@é@ €@H絓ì¤qZY>H SXö¦W“dùI’´Ó½ÛO“d#^¯zÕÕäÙ½0Ü}>^ÃVЄZ>m6+wÞäÃp¥†§^õîÛ|jÆ@:P;; 5# ° M·Ã(>õªí4´s- @¥”†=¬ ʶ°þ«> °}=ã €4ÐýìÝŒ'ç4·¯^5¹ŽS@“^´T`@@ €š¤üËT@@ € €H € € €H €š0@ó•«l~"”œ3ç…b¦6Á€*µ«¬2€Î™óB1S € € € € €& Ðoh Fwk»3óÿU¿,€²É 39€FþFþÐý9 ÍøõëýsgIÅCs\tO !ÛìáVxtÖÎûÎwb=xr]P-þ%ÍÏ™%üUÆÀÉti@~@@@@@@@@@@@@@@@@@@×hª2TŸ÷eSèœ9VÌÔ&Ð-M„ŒË÷å…¼-@%éÛ¥¿ÐÅ{´ôûB– €ÊÑ·KKÅ,A•£GP!K@¥(.@Å,A•¢G "– €ÊÐ÷?^ ¯hÂæ @@@@@ÐG¨ @@ €hlí$»4N@+˧tñèœÂ ´7½š$ËO’¤îÝ~š$ñj|Õ«®&Ïî…áîëðñ¶:€&Ðòi3°Y¹ó&†+í4<õªwßæ+P3è @íì(ÔŒ€Â*4Ý£øÔ«¶ÓÐε,@•Pö°6@ ”maýW}@aûzÆ4ÐýìÝŒ'ç4·¯^5¹ŽS@“^´T`ÐG ¨à@@ €&fž@@@@@@@@@@@#4_9«ÏÏúÄ<@½«R¹ @@@@@@@@@@@@@@7Ðvš¶ÂÓìa¸ÜY;z‘¦[µúÁËì"@ ´™®ÏvæÂóñ\ãh±ÑíÌl§ëõƒã9+д“ìh¿O%Ú< €Zµð¨´lae´²|z]€ݸ•4I€wõ€¾úú@aêýëOÝ­íÎLƨ¿…4+ÐÞôj’,?I’vºwûi’lÄ«ñU¯ºš<»†»¯ÃÇ«Ûê––2Bï¢÷ÃÊÓènmÆÏ®7º¯òC4@“hù´جÜy“ÕvžzÕ»oó¨W(#ô‹oãg·Â£³Ömù6~L€_U?ÔÎŽBÍ(¬BÓí0ŠO½j;Íí|°]îÍ—²¾úÍ/|Ä(?D4–¾ÿÏU5" 4ìaí÷þ —{óÐßí‰%èC@ÙÖÕ¶¯ça¼qu iäó_?‰.% ûÙ!ºOÎi(n_½jr…§ Œ_e”±hiüe|è’$€ € @@ € €H@@H@@ € €@]CS•‘›H77€@@ €@H €@ $€ôR¹/ OÜ`€.è/npÉûÃxI $€[ €@@H iPÿª“ÙííIEND®B`‚gprbuild-25.0.0/doc/gprbuild_ug/importing_and_project_extension_figure_4.png000066400000000000000000000145201470075373400274400ustar00rootroot00000000000000‰PNG  IHDR@€rD--sRGB@À}ÅpPLTEI} %@a)Fj0S}+Jo&Bd0Ji(Dg*Hm$M€4Z‰(P‚-U…9^Œ"L-T…1U€8\‰:a1…œ6ˆž1…?£:Š 7„£@8U\0ID^zMBc^HlJl–QršIk–WwžWvFi“J~»@q«Jy±I“¨Y¯Z°U†¿P‚½O½U…¿[ŠÁZ‰Áhhhb¤e‚¥x‘±y’±n‰ªmˆªfƒ·sŽ®f’ÆxŸÌršÊl–ÈaŽÄp™Ê`Ãe‘Åu­½oªºr«»y°¿}£Î{¡ÎŸŸŸ‡‡‡ƒš·Ž‹±‹ »’¦¿Ž£½¤¾¢½¼Èƒ§Ñš·Ù”³×Ž¯ÕŸ»Û‰«ÓŸ±Ç™¬Äœ¹Ú—µØŒ­Ô˜ÂÍ···¤¾Ý¨¹Í­¼Ï«ºÎ©¹Í®ÏظÕÝ°ÐÙ¢ÈÒªÂß±ÀÒ´ÓÛ§ÀÞ½Øß´ÄدÆá»ÎåµÊã²ÇâÈÀjÈÒßÇÑÞÀÌÚÄÜãÆÖéÌÚìÒßîÀÒçÊÔàÏØãÌÕáÈ×êÓßîÏâèÓåê×ãðÝçòÿÿÿÿ ÿÿÿÿ ÿ22ÿ00ÿ33ÿPPÿMMÿLLÿYYÿ@@ÿÿ``ÿrrÿffÿppÿggÿŸŸÿÿ’’ÿƒƒÿŒŒÿ‹‹ÿžžô¡ÿ§§ÿ¯¯ÿ··ÿ¸¸ÿ¿¿ÿÞÞÿÉÉÿÃÃÿßßÿÇÇÿÏÏÿÅÅÿûûÿêêÿõõÿ÷÷ùûüäïòôøúüýý÷úûîõ÷åðóâîñèïöîóùùûýô÷ûãëôûüüìðôö÷ùâçî÷ùúòõ÷èìñÿççÿññÿååéï÷ãëõÿÿÿÊRS~ pHYsÄÄ•+tEXtSoftwareMicrosoft Officeí5qTIDATxÚíÝ_[×yð¬§ìÅÞž½Ì:'ÚpJ'%îb^²o¬Q†ñKÛYM– ¼­i0¶Æ¾àºÅu2kƲux/[±ƒÝXéÛvþ¥=ç\ñbôv_®îýý>ÆWâÜ#ݯžsŽ@ÒAlä Ü!„@@ˆ‡ýÕGŸ@üœþ‰»€~w±Ïówáö}\„qßÏSB €€ €  ¤j}[C&å;@Ü ó/·    B  Ÿ:Rc:GÜ;^zãn¨\jêM§Æ=@zãn€€€€€€€€€€€€€€€ÈíP¥ÍŽÍÉäÔ:@óãš6ÃScsw®ÿ넦i ¹-óß|OÓ¦9OiÚ?ÍÝ—åûbî\ŸúÇïË ”Û2?>µD¬æÇgîNŒÍ¥èBT ÊϬ|?‹Qhô!,·…äÐÙ2$†°Ù¢€‚H‡‘Šr€ôÒ´§1l€(/óãÓ9.“Äd’Fª-Ь&‡°£)ÒtU*4ó—·g€lZ,p§jÚØÉpäH¥oÉâ“šöïß$>Z±Y¡Þ\=è ãKG² èöÍ[ÜñPjXæ\šC÷hûè©û¯qÞK[ßâ=ùÇçöMMsÐvwDÚW8õ¢ïÁ±†å/‹Þu”ì¦9@¦Ÿ{  ªM-ÐÞCöɃõ]òÈt=<Ü~ÿXûÊèÁ>ÞÑ°üðpÞ\ðqÐvw¤ŸñÕ°<:J½ÉU âÝ4Èüs‹K¹ò@yh P×:2=tÐz–{öŽOÞtí--ÿ¾>¿;¢G²«T‚ä–@EºùófîóÏ=ˆ @ù€®Ð‘GL/ŠªY¼¥¹_¶»#égúDǶïæ/œ4Èìs´H@* ˆÆ‚ö•Þ>y€¶Ç†žsTIÈu@};CX¯~ÒsåÁ1qI}Énþb$Ò|Õè.Í?÷@×IPþ!£GôW 9`ЙôÙiOÁErÞú1ìÁ1’#(uÉÞ•èæ/E(g.A&Ÿ{ 9ö;ã”Èr9t¯—¾FO­ô”^%/κ ¨\Jt³æ¤éNó &ÀÏé÷ör€ÜÈÞÞÈ™4ç{R¼›5/I@g3÷NΞµb¿† üªÉ¡_etŸ¦Ë¼¢ *ÔO³è¦4E@—ðî3@­RõÉœ ²H¶uíø#^ÁPµâ¯7ÙÄ[^ ²èÑñkv;„—68i÷¹D 4 ~¦€ÈFÓMC@6:x¹i€ÈFÏž ²ÑÁÌÉ·€ltðêñ4^´ó„4P¦¥€ÈF׎¯Ùèà¥VËOHQ^:@d£ƒé¦«;@$2Øfq rÙWìÃ×÷ýXö}îÚWþCá÷—¿Jž³ø„4YNKš{2ÖúµÚ6hiod5ƒ‘nîÅXí×µ—ùÕ´FžIsÆr¿Î¿@  Š×–{Ðõ~eZ/:@­t ¼X‚lôkÍÊË|ÈúÝ‹%ÈV¿ú[H Vy ¼W‚ìõ«ù"©t­¹¹9B_•}q°ãý²ð„4YNÄcxœè—ù—ùíÎ…³t@¶^ð¾jöm§Èw€ìeÈäË|€O÷ 6 ›/55ù¾Sä;@vûu­ÉÌÒ@{cê}§€òbæ}§Èw€ì¿o™÷ ßr Æ_æ@T g ¿Ì€|hÈ6Œ¿ïù#ýºÜfð i ‚1ú¾S@cô}§Èwqèíç ¾ï!ErÑÐË|±B€€€€rP’ ƒ ¹ (ÍYO…9W­¶@ïÝ‘Úg‹~–±ùØËŒuŠ­â»õгìsa:;¼Aÿs¥‰×m–¼|=Ôé Â2 (š›Xݦ~–¶$8¬‡|¨ß»qqÆ[}t*dPB>JãPBñ觓õP"wï&• ±ÛØsavà+µÂ6£>­‡#ʱ¡è™(•q*YC7ÑB‘ çqº{\e6ÂáºÍ$‹þ(Lÿê6iÈZE³#µ´]Fúo¤vØèM´PdÈ yïæ¾Ë¢{öó›Æ§΄:%qÝæF8ú㨢[t"/Úš¥+)ŒV‹,Yô Yß㢨sýÞ÷,ŠgAI1é¥^ˆs;]NŠuІ £Õ" @–÷Ü¡,«O§§âth‰’Ü Oôž®&kd³Zd¨š‰9t4+Žo²n3ÆääYÌs©VÈzA5±SG«Õ" @~‰œï¨Œ_¢—  ê !@@@@&âç·w  ²–f÷š.ð¾Sä;@.¦À§ù™Èå¼— ßr³ñ¼÷ ßrµ_™½/@d*W÷|¼<¹ìyß)ò fw›Ï´\ _r;¼<Ù\j ?r}/] r¿_鶫@6òöÎÇËYȹ³ä[@Í ö±ÚvÙŸ€þ;•JiôõŸ¤$C[OHû ÐO¾¥Éü¹œó| ˆWú™Tqw/’ið% ½©(@žDSÖô—÷Ý$ú»ª PÐñþf_%HI < ÞüºQ RS€½Œ—yÔtÍ€~ò-5/ëá'3UèH¡ü¶±«1Ö‹â;Øn»êsá|Uª©w25ÆzQ|§Ûm»“!u»Zm Ë€ê= HåÐ:Ôö@6Òýg@6’ùà*ô*cìù2'¿Wþ*ìwKíÄàbEÏÇÇ̵÷+‘0Ço²ù;€ÔzÅ©†ŽP 1%å €€ÈU@oæ@®I ßRSÊ€€\°Œ& ¬Â€È€°ŒÇÈ=‰ä[@jJPjlÎý! Ëøütñwµ¯ô8ÛöëÓ¶NÞxßZáp,T%€æÇgò7Þ˜Z _aŽºs]ÓfDéI½§iÚ´¾O¾;¡Qå¡oÞ!U)M+¬Ëx絯¼Åùè_sÞSß°LçRj¿ÿç½âÒC÷èú£§ôï–ßâ=NúÀhë5Åý̈3yã{Ú‚¬ô ?››Õ$,ma~|¡Ècï$ Ñƒ}tü®<8öɃbü€Ä¶ÇÄxöðpûýcúu:–v¤ÉÖŒ´^´mª-M’gEÕ‘ƒ•¾A f³Ò8™×\¥H(bÚC`DÊêÉM…èw=8&¾§¯†å§†0}+ÛzѶ'õ¡)%É9´¾aV¯G)*I¢,Ý ‹Ëe¤6¡ÙYfÕºBÇs ö1¶¹¨lë[m/æ’K¬YíûT}äZß@KwQR¢Mýì;KűÝCX’ îñz¨³ì­²´Œ/ èÊèÁ*Ô·PûJoŸ¼5ÛƒŒC€dkFZ×Û¾}3ïU›4:iS?sè9š1Oë–¨‰zDß¼;1-¸éò…#^·éBi²>„U1 *?\yP—¸~GnÚë 1iE§|ë5’¦ÝâÎf7 ØSO³mCë!Æ¢ôÄë^fŒuæ¶=õt‚Çž ‹ëÅN„¢YS7¹ô2¥~»ËIėź¢£ì£Z–ñ‡îõÒ×è©R oëÏD—o½FòqÐF¸ns=”Øò“ØG³±_¢q-vàí‘,Άõëun„õ­¹YÆ—^¦È+tˆ¯†åÑQZGä*PéFÕ<$j„>ÍuPùÖŸ¼©mç¿8ÿ''Ov TÛ€âTu¨Ê$© q!Ils¤¤ŽŒíט!@¥–)¹»A– Y{v•X`àwaÛ^¼¥¹QvEúØšGÇt3qhk§’CÅH\‡ôì™r›T`™²kRÝ'm*½À ÃmKB.’£ÓÖ°¤ZIöUª>²ÖКd'Y4'Súwöõå¢Ù`îz4ÊÕÓuêË.0ÈDÛDÈi@»–ñ4)fÛÓš‘ZÆ¢_«sh³˜œñжTŒb4º‰Zôø ÚÈ2¾Ä2屡œäJ]ÜÀò€Lµ½8ë0 “¿ KŠ*etíåÌý\f@Ž¶mX½31ñ)ÓgDæŸ*{“圚óóËò ËÁoム¿ o€€¨rCþ¨>˜€ð7Ñ@ä@XÆcäžDò- 5¥ €€ÈÕ! Ëø`Â* €€|ËxÌÜ“@¾¤¦”¹:„aL@X…aL@Gcoê'¯rþ|á“_)qÙÖɯ–ÚË>Ÿã½ÿ×Ì|êwÍ>ª( CiI+ÜÙ™‹–€¼ h0Ò­ngý-ò ÖÈ3ÊJPºí‘õ OŒD– ŒŸUÈàäî7ÌÏçJ¤ÄN÷ÛmÛQX‚ìD= ƒiTt|ý <*¢©*Aƒövx@/|ʃôV HI J7 |½±Ñ{%èZ³žûj>oïçƒè…ÆF/– eI_ÈØk à€¨y±UQèè2Ü{‰¨ØIÆþ-6 Y€ÿ.¨€Îž·ÝD°ýÅéÓ/¾xúô_Ð`Û*ÙÍoxP@vWðäe@ ²:è@#\@Ž€‚ h- @~äö(ÓêÌóÜP@Ýœi€‚ èš+x 0 žv¨Â* €Èd.YÏÚñGŽµ@Á›9µ‚ €:ç`cô/þ-Wôç~„!„@@ˆÿ%Ù°ŠÛªh7è˜Â[Z%€bѬŠ»Õ‘ݘO¼n³äåë¡Î 7èq@å£èÈVP¹ŒÔ&<Û W*ÐHí³ŒE?ËX‚|ìeÆ:ÅVñÝzèYö¹0Þ ÿ‡íÜVE»±ä6ö\˜øJ-uHœ£²bìÀ‡Ô}Fm?È_€†šÒä@¯2Æž/})•7óÎ4)ÁÈ«È@XmTw€*è÷)Us©™µ‹@ÆstÏ÷™–~ ëQ½‚ *ŸíÉjk€‚È¡¼é…N¿–ñ@n,ãûUþ ùn¯äuðäÛe|¦UÁ;¹—ñ«x €|¶Œ Àr(ÛËøÕÕÊu€|°Œ?s±r w¥ÆæŠ_èð2~ Eå_ÑÀî\Ÿ.°uòÆûJ‡#€*¶‚ GÍÏäo¼;1µä: ­eüµ ú K€î\×´QzRcïiš6­oà“ïNhTyè›wHUJÓŠ(rl_Á¡ €lºs}F”˜ÉßÓä`¥oøéÄØܬ¶ ai óã Å~Þ©e|úäU>¤ú ¨ó:9t6žºÿç½õ ËoÉÆQmÑh’<+ªŽ¬ô b0›•†ÄÉü¸¶àî±{órä™×›H1 .Þqhô0><Ü~ÿXûÊèÁ>ÞÑ°üð°ñ 4©M)HΡõ ³z=JQIeéî]ìfX$iKZ@WrTP×ÔSO_ Ë=&†0}‰5«}ŸªœCëhé.êQJ¡©Ÿ}g©è æÔ2þ,Š€Ü´Z PûŠÊ ZÌk“F'mêãb=G3æi}ÃÕ!Qè›w'¦Å7]ìÈ—ïöz¨³< (ÒVÉU¼ÿ}úÕÇÑ€Uÿ7¼ÒÛ7zP2Ê aÅݾyËñ;Ý #Ÿjô8ñiê¯ìRÌ÷€%¡]“è+TyÚWz»Ä¥í+è“è€nßÔ4w­‡Ø·Ï²„(=ñº—c¹mO=à±ç¬n“ÇN„¢ÙíMÓøu±Ò+ù’„ò–ñ‡îõÒ×è©•žâËxÁÇ @¯ìöÍƇsgáh6vàKl˜ÇtU’Þ×mÒÙð–5™ËÏtWð·¨^ô©ÓΤQæÓ¿žçCT }]$OJ>øŸ®íÌÉ·édgZ•dÃ[gãTu¨Ê$© q!iëâ¤À“–öŒk›®8ú¿o8ÝÏû-<‘¸xKs§íJl§¦Ät3qhk§‹é*ÂéÙ¥MT¯"úfñ™hIÈÕ!,NååÏw[J²¯Rõ‘µ†6ÐÅIFƒ™Ò¿ å€ôe˜Õ_e!W'Ñ»æÐ#µŒE¿VÛ)Q…˜œñжTŒb4º‰Z´k @Š¢¯âmü.lqÖM@å“sèÇåär€ÔÅÃT/VïLL| $ÆôQ ÷!áêÈ€ ^@¶‚ItPá-îÈ G€ÈV°Œ êa@ÕÈ¡`@¶‚ItPa@^8ò@¶‚e<UËxª6@Ëx²L¢ƒ Ëxò‘ ²,ã¨ú@•™eŒ½ÊùóöN(˜€ü   ò4 }5¦³: € €B BBüw}w0Ùô§¸ƒ}ž?p‚@!„î€B  €BAÊåÿ•9dñ¢3êçIEND®B`‚gprbuild-25.0.0/doc/gprbuild_ug/introduction.rst000066400000000000000000000024751470075373400217530ustar00rootroot00000000000000.. _Introduction: ************ Introduction ************ This User's Guide describes several software tools that use the GNAT project facility to drive their behavior. GNAT projects are stored in text files with the extension :samp:`.gpr`, commonly called *GPR files*. These GPR tools use a common facility, the GNAT Project Manager, that is fully described in :ref:`GNAT_Project_Manager`. The main GPR tool is :samp:`GPRbuild`, a multi-language builder for systems organized into subsystems and libraries. This tool is described in :ref:`Building with GPRbuild`. The other GPR tools are described in :ref:`GPRbuild_Companion_Tools`: * :samp:`GPRconfig` A configuration project file generator (see :ref:`Configuring with GPRconfig`). * :samp:`GPRclean` A tool to remove compilation artifacts created by GPRbuild (see :ref:`Cleaning up with GPRclean`). * :samp:`GPRinstall` Executable and library installer using GPR files (see :ref:`Installing with GPRinstall`). * :samp:`GPRname` Naming scheme generator (see :ref:`Specifying a Naming Scheme with GPRname`). * :samp:`GPRls` Library browser (see :ref:`The Library Browser GPRls`). gprbuild-25.0.0/doc/gprbuild_ug/project-manager-figure.png000066400000000000000000000132011470075373400235300ustar00rootroot00000000000000‰PNG  IHDR@€rD--sRGB@À}ÅÐPLTEI} 8]Š9\Š<[‰;\‰=Zˆ>Z‡-U…4Z‰$M€9^Œ(P‚?Y‡8^Œ>bŽ:a;b‘?iœ=f–:`>hšVNUO[M}^K|YM~TPWN~ZM~\L|_K{BY‡FW…LT‚RP€JU„MS‚EW†HU„PRKTƒ@Z‡QQGV„ORCX†AY‡LSƒ_P€DW…FV„Kl•WvœQq™Eg‘Jl–^zŸQrš^| J~»Gx²Bp§H{¶An£Fv°Eu­I|¸HzµCq§Am£O½S„¿U†¿P‚½[‰ÁW†À[ŠÁ`J{dN~ePo[‡s_‹kV„gRjUƒhhhm•~l”taŒyfb¤j†¨p‹«w¯d¤}•³x‘±f‚¦e‚¥s…§l–ÈdÅršÊaŽÄf’ÆxŸÌ}£Îƒr˜€n•ˆxœ} ŸŸŸ‡‡‡‰Ÿºƒš¶£’ƒ¤œŽ­”†¦ƒš·€˜µ—‰©’ƒ¥¤¾’¦¿Ž£½‹ »›®Ä–©Á™¬Ä™¬ÃŽ¯Õ„§Ñ‰«ÓŸ±Ç†©Òž¹Û”³×Ÿ»Ûƒ§Ñš·Ù§›¶¥™´¡”±«Ÿ¹¦šµ···¯¤½¨¸Ë¡³È®½Ï·­Ã¨¹Í¾µÉ©¹Í´ªÁ¹¯Å¤¾Ý´ÂÓºÇÖ±ÀÒ§ÀÞªÂߺÎå»ÏæµÊã»Îå¯Æá¹ÌŽÏÁ¸ËûÍÁÌÚÇÑÞÈÀÑÈÁÑÑËÙÔÎÛÌÅÕÍÆÕ×ÒÞÒÌÚÍÖâÓÛåÊÔàÚÔàÝÙãÜ×âÏØãÝØãÆÖéÂÔèÍÛìÀÒçÌÚìÚàéÚäñÖáïÝçò×ãðáÝææëðìðôùúûàæíóõøýüýâçîúùûöõøùøúóòõêèîö÷ùðîóòðôûüü÷ùúõô÷ëèîéåìäàéíêðæãêèïöõøûùûýüýþñõúøúüæíöô÷ûîóùãëôòöúÿÿÿri]„ pHYsÄÄ•+tEXtSoftwareMicrosoft Officeí5q%IDATxÚí‹ÇaÇÝ\V¼C#;N·8B¼Šq[^-jÒ¦i°cë\°]cs< ‚’’CŒ¬Ž Ø´M…ÅŽA8Ä¥ ¶Øl ¡¦H”Ô§ô’ û/tfw裸ØÝ»Û]}¿Ÿ´·«{ìüö;3;§»{t€¸‡|èï>y€}>ùçÙý ‘€#>‘-€CîˆþìŸú                      {.´JlKf±ÌÜšÚcÞ©•C¥fz^ t¼eO*µQ±XsÊìdry*ÕÐÒÒ6`¥Q0=jmÙ›ªI®ÐòÄ‚duª±åýâÊéZ ‹¢ìËz/zQÌ 4n2)šÅ(ks™y¯A}D!é÷nH¯€µ4Ö${)¶(Ö¨httÂ1cD0“ãñò;ãXQÝÐr1dî%½‚Ôz8µ|NÖNŠM‰OŽMä‰ÑÑqñi±éY/1wYêÐ…0¨¬ôò.ÐOWÎͪ4¥ñqãbBT4ÒÝ«Ôì•{ŽYžà¥—W§º¦—Æ£c^Zë–CrÛá¶ÊÌôò&Ð…Æå]Å•ÍŸð˜ ãâ±¢®~$y‚›^^j;´1Óð.ŸMøÆØ©¥CÒ{2oec hÁN/wÚö­LWžA¿>cBÂwJ&• ÍT¥½ŠÎŸ^Žu•¿¨|¦ÅO3zFé`+…åê:†ôrèýj«üC§W§øiÆO¶FªÅÕJŽÌ‘ž{ÚöZo‘+TyzT¥™V sk†B“ž[Z·Í6ž{HÙXUËŸBqµBò¥çN Ö³õ-¥vùM&L1{ôåŠ(ªôÜd0drIŒ™:T…B–žsÚ¶L”ò›D˪}~k(té9èøœ  k„0o¯Ÿþ„/=‡]ÜÔºBXæÛјž3ŽËÁÃà™Á @2^öæÅ>5?aLÏ‘@²ÿ~ $¸ $§ÉjTã‡?áLω@5²´ýíQ–yÿ¾bHÓ³/PÛ2ÙzbT*?ý²ÀcƒB›ž}ä `ù˜à' (“ÿinóT Ð¦g[ =âae¡@0Cf£—þ„7=»µÈ–‰É¢8{¼ó'ÄéÙh¦Íšž¥b<êÝ›Ò!NϦ@‡4mPIˆHLœîá`>ÌéÙHT¡Â½¶éÒæ^¶îÖ7;x†z§/:î.MPsäDß«ÍÃ.ÛðæHûHÏž@‡Eʵ Þ­í«?}jÓ%ñ*GûàäÛe ÜýÎr»‹Óû? ʃ@Ï-:’¯ôvëúÏžR2={5ä>†8¨÷)ÐâÿxJ–á Þo9ºGÐýÎn#c‰•ö{!7éï,ùê;yIoÓ?ˆ"fʯTzöZ©iS<ýbÑx¿ýØ㈇¾½Èúý×í¦@æÖ¯ÿô¥Q‹ÛÿÉ(‹,ƒø1WEuÓë¦YÖ–zC¾ïÊGmîŠÀ¸súÙ7oºôÏ—úô³ÆjÚ‚þ95ü…Hd‹®×F"MbU:$Í«ÏŠÅ©b³~e~$»©Êæ{‹þæjÒ{Ln4P.={‰NÜÑç¾ÿì1Ù†îþù¢}5ËÌ}4×e…:¨o^Üþó'ºª…¹jݘ)lOõø¿>ѳm6_ĪCâÙújãû`¢èÆï"Ј¥Ö»,n]ùÊ+Nhº2_.N‡NÔ~êý6Bÿù·‹^ýí<¤—n&”KÏž@s4Íчw¥ÞF»ö”ù;K ±ž©õ]s}ÂX•e2Ê.©?iÄÔ£¯·^$Ó;9m4(z°—Ù5ÉÅ*éHW $”’‹æˆD´L= ^žó7å#=³øꤧiZ®i“œ<»Øéݲ˜©ÑfJoíA½]6[ÏvG/žy×Lд9wkúÈGôaMýŸ}íOrOïñ̶F½ôì ´MÓ¦9Œ@´’>híº!ЦKGÍõL#|g²,e-Ήû%þ剓V„Ý#9iµÛN##Ñ嶪ª|ãcUö]Í« Û"ïöâåÖ‘[ú~–«Ï?},éYþ¨˜ž=öiÚt'O/êÉ5« µ~'²ZÝmÝø/ó4ðÎäYŸntßÆ ¡¨Q'uóäpsVæ‹ÛÝDP®iÛl ¤¯2O¢åò›Ã/§²&ô‰ô}Ô^ÿä«íùHÏø-­P/={µkšã²<þÁQñóßÿ#w AÍ­oý®CGǽ²3Ä0B+ðw4Ž,zþjèÓ³ùNtÃJdBÖ«ôØz×÷ê™F7Ãbó­Ýú|DPÞ–¶¾9Ò³)¬D¡ù8‚djá ‘žÝÿƧ4‡ï†©M´ÈÑûйâôl LŒä‹ñU\;Œ,F¡^~¨5¼éÙ¨mÈ`R8/˜íé]ÛžýÏD_ßjŠ‡!¢.öø’A¡MÏÁ×z.ȯå–ÿƒáò»Mó<¿äTXÓsò½°‹ò«)ƒÞ_lšãÃÉCšž³¯6Ë/ÇúË•cÊ4¾VÚô^\áìÊ‹âAm‰gÈë²ÏkÐ}"Œé9½¼ËÅmÆ匠ã"ÈË|¼BPÓs~©ã+‚‚Àì}º¯„.=7—¸Ûk\X½hŠ²—½“’Éf{Út¿ Yzî.²i† Í ȘbT©¦Š>¡KÏíe~­©~ÚDbB|ˆRú„,=÷?¼RSÿZÇ£gZ?$÷)cO¸ÒËeªƒÖ†¹é¼V·+­ÏÛ¨àü¼!I/ÇÉVWϳæ)*Q¢Rñ'Ž›243_ˆ:}WøÒË}º§Cé9C´éÓ¢j”üäYšúsõ„#½|L8׶oå¼ôKÎ*›äëuÜJÆM‹uÍ™¦úla!H/_S^oèšÞ|Pų̀WÉÎìšpO[°-@³ï8½ˆéå}Þx]N~¾1™5«ýØ´™Ñ<Ÿ"ŽNǦg½Ì‚• -Au'°éB ƒ÷÷¥’³µlfÅÊâ“¢Ñ÷ŸŽ‹O‹Åzyu` ¤oÝðŒ×„†cK[¿ïñk*'е?J|\òµÄ3^_ &ÐṚ;,)rõ¸¹{Ã#‚Ûð~5ñ›šÇáL Ù.ýÑŠ~Ëå‹Ã#ëðм¯`iÞ^!Zè%a((á!!!!!!!!!!!!!!!!!! šý›+|Ìàºw­Zú!…L Ó«ë¼k(H ¶ßø®Ÿ‘·‘ÍǹæúšŽwõýÎ28½º¢"o³"?‰,ýËH¤I?5ü…Hd‹nL…ܤ·Ž|6òWóÅÍWÄï¼wuN: ë?¼Q•‡ð,P繇è;Å­]=ºýF•µ¾¦ã£GU"©O¾Zúa­Ðf•œ…]Þ4&Ú‹Ö‘r*mÙÕbNmGáíäúÇU9‡lö?F»>®²Ö×tدB"ƒ{·"ôÈœ—½V $Z¡Mâ–\´Žl²º°æì¨"OØï€gWZ ×á…E íº¾¡Ë î­«È tWtч5ùØu ”Sxaè¶wž9pî¡®uç\¯+¤@Ff­Y‰îëEq{‹íÒ.,÷ð-Ð/åyŸÈ`—|äNkÝMB¡‚ ô;ÆIt­ƒ@Ť7¸+ÇýŸÿ½ßÿÂg]=tcxjðÜ×á)6gê+Ïêúë¿ÂŽZ½¾ö=¹¸¾¾ê= 9æ[«Ó÷yãáowppÈë×ß̬ܬ[w–£ƒ@¸µº.«Ñ9»¶î&Çìr{ík=¶t|ûá78@dó•½Èr¾jýuèîÃ÷^`D@vøûµ} Ûňþ'õqSðU zT.w}ô¨è1¶wž{耾3½ÑO2{à~ÏÈö§Ó®ÅaÚ/N]÷§7ú)PfÜïy(ÐöN]7‘r¹ß3òJ ígœ{È8XVG¡Š@9íy(Ð.ùÀÛ;ižª*$û=C Z˜êœ?çvtî_蜂¾Þ!w-”õÜ|\.\.|\*\*|:=|/=|>=|<=|<<|>>|<>', Operator), # One character operators (r'&|\'|\(|\)|\*|\+|-|\.|/|:|<|=|>|\|', Operator), (r',|;', Punctuation), # Spaces (r'\s+', Text), # Builtin values (r'False|True', Keyword.Constant), # Identifiers (r'[\w\.]+', Name), (r'.', Text)]} # Insert tag highlighting before identifiers if tag_highlighting: result['root'].insert(-1, (r'\[[\w ]*\]', Name.Tag)) return result class AdaLexer(RegexLexer): """Alternate Pygments lexer for Ada source code and project files. The default pygments lexer always fails causing disabling of syntax highlighting in Sphinx. This lexer is simpler but safer. In order to use this lexer in your Sphinx project add the following code at the end of your conf.py .. code-block:: python import gnatpython.ada_pygments def setup(app): app.add_lexer('ada', gnatpython.ada_pygments.AdaLexer()) """ name = 'Ada' aliases = ['ada', 'ada83', 'ada95', 'ada2005', 'ada2012'] filenames = ['*.adb', '*.ads', '*.ada'] mimetypes = ['text/x-ada'] flags = re.MULTILINE | re.I # Ignore case tokens = get_lexer_tokens() class TaggedAdaLexer(AdaLexer): """Alternate Pygments lexer for Ada source code with tags. A tag is a string of the form:: [MY STRING] Only alphanumerical characters and spaces are considered inside the brackets. """ name = 'TaggedAda' aliases = ['tagged_ada'] tokens = get_lexer_tokens(True) class GNATProjectLexer(RegexLexer): """Pygment lexer for project files. This is the same as the AdaLexer but with support of ``project`` keyword. """ name = 'GPR' aliases = ['gpr'] filenames = ['*.gpr'] mimetypes = ['text/x-gpr'] flags = re.MULTILINE | re.I # Ignore case tokens = get_lexer_tokens(project_support=True) gprbuild-25.0.0/doc/share/conf.py000066400000000000000000000051761470075373400165770ustar00rootroot00000000000000# -*- coding: utf-8 -*- # # GNAT build configuration file import sys import os import time import re sys.path.append('.') import ada_pygments import latex_elements # Some configuration values for the various documentation handled by # this conf.py DOCS = { 'gprbuild_ug': { 'title': u'GPR Tools User\'s Guide'}} doc_name = 'gprbuild_ug' # Then retrieve the source directory root_source_dir = os.path.dirname(os.path.dirname(os.path.abspath(__file__))) gpr_version_spec = os.path.join(root_source_dir, '..', 'gpr', 'src', 'gpr-version.ads') texi_fsf = True # Set to False when FSF doc is switched to sphinx by default numfig = True # Allow automatic numbering of figures with open(gpr_version_spec, 'r') as fd: gpr_version_content = fd.read() def get_copyright(): return u'2008-%s, Free Software Foundation' % time.strftime('%Y') def get_gpr_version(): m = re.search(r'Gpr_Version : ' + r'constant String := "([^"]+)";', gpr_version_content) if m: return m.group(1).strip() print('cannot find GPR version in ' + gpr_version_spec) return 'unknown' # Exclude sources that are not part of the current documentation exclude_patterns = [] for d in os.listdir(root_source_dir): if d not in ('share', doc_name, doc_name + '.rst'): exclude_patterns.append(d) print('ignoring %s' % d) extensions = [] templates_path = ['_templates'] source_suffix = '.rst' master_doc = doc_name # General information about the project. project = DOCS[doc_name]['title'] copyright = get_copyright() version = get_gpr_version() # now = datetime.date.today() # date = now.strftime('%Y%m%d') # release = get_gpr_version() + ' (' + date + ')' release = get_gpr_version() pygments_style = None html_theme = 'sphinxdoc' if os.path.isfile('adacore_transparent.png'): html_logo = 'adacore_transparent.png' if os.path.isfile('favicon.ico'): html_favicon = 'favicon.ico' html_static_path = ['_static'] latex_elements = { 'preamble': latex_elements.TOC_DEPTH + latex_elements.PAGE_BLANK + latex_elements.TOC_CMD + latex_elements.LATEX_HYPHEN + latex_elements.doc_settings(DOCS[doc_name]['title'], version) + latex_elements.FOOTER, 'tableofcontents': latex_elements.TOC } latex_documents = [ (master_doc, '%s.tex' % doc_name, project, u'AdaCore', 'manual')] latex_table_style = ["standard", "colorrows"] texinfo_documents = [ (master_doc, doc_name, project, u'AdaCore', doc_name, doc_name, '')] def setup(app): app.add_lexer('ada', ada_pygments.AdaLexer) app.add_lexer('gpr', ada_pygments.GNATProjectLexer) gprbuild-25.0.0/doc/share/favicon.ico000066400000000000000000000015761470075373400174210ustar00rootroot00000000000000h(   Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡¼“m“Q“QñéâÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿëÞÓ“Q“QØ·¡Ø·¡ëÞÓ“Q“Qг˜ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ¼“m“Q“QØ·¡Ø·¡ÿÿÿ¡g2“Q§rAÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿš\$“Q¡g2Ø·¡Ø·¡ÿÿÿг˜“Q“QñéâÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÖ½§“Q“Qг˜Ø·¡Ø·¡ÿÿÿñéâ“Q“Qг˜ÿÿÿµˆ^“Q“Q“Q“Q“Q“QøôðØ·¡Ø·¡ÿÿÿÿÿÿµˆ^“Q¡g2ÿÿÿÝȶ®}P®}P®}P“Q“Qµˆ^ÿÿÿØ·¡Ø·¡ÿÿÿÿÿÿÝȶ“Q“QëÞÓÿÿÿÿÿÿÿÿÿÖ½§“Q“QÝȶÿÿÿØ·¡Ø·¡ÿÿÿÿÿÿÿÿÿš\$“QÂ|ÿÿÿÿÿÿÿÿÿµˆ^“Qš\$ÿÿÿÿÿÿØ·¡Ø·¡ÿÿÿÿÿÿÿÿÿÂ|“Q¡g2ÿÿÿÿÿÿñéâ“Q“QÂ|ÿÿÿÿÿÿØ·¡Ø·¡ÿÿÿÿÿÿÿÿÿëÞÓ“Q“QäÓÄÿÿÿг˜“Q“QñéâÿÿÿÿÿÿØ·¡Ø·¡ÿÿÿÿÿÿÿÿÿÿÿÿ§rA“Q¼“mÿÿÿ§rA“Q§rAÿÿÿÿÿÿÿÿÿØ·¡Ø·¡ÿÿÿÿÿÿÿÿÿÿÿÿÖ½§“Qš\$ëÞÓ“Q“QÖ½§ÿÿÿÿÿÿÿÿÿØ·¡Ø·¡ÿÿÿÿÿÿÿÿÿÿÿÿøôð“Q“Q§rA“Qš\$øôðÿÿÿÿÿÿÿÿÿØ·¡Ø·¡ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ¼“m“Q“Q“Q¼“mÿÿÿÿÿÿÿÿÿÿÿÿØ·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡le:Ph<ey <ri>fe:lolht/gBk/DAREibgprbuild-25.0.0/doc/share/gnu_free_documentation_license.rst000066400000000000000000000550701470075373400242550ustar00rootroot00000000000000.. _gnu_fdl: ****************************** GNU Free Documentation License ****************************** Version 1.3, 3 November 2008 Copyright 2000, 2001, 2002, 2007, 2008 Free Software Foundation, Inc http://fsf.org/ Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. **Preamble** The purpose of this License is to make a manual, textbook, or other functional and useful document "free" in the sense of freedom: to assure everyone the effective freedom to copy and redistribute it, with or without modifying it, either commercially or noncommercially. Secondarily, this License preserves for the author and publisher a way to get credit for their work, while not being considered responsible for modifications made by others. This License is a kind of "copyleft", which means that derivative works of the document must themselves be free in the same sense. It complements the GNU General Public License, which is a copyleft license designed for free software. We have designed this License in order to use it for manuals for free software, because free software needs free documentation: a free program should come with manuals providing the same freedoms that the software does. But this License is not limited to software manuals; it can be used for any textual work, regardless of subject matter or whether it is published as a printed book. We recommend this License principally for works whose purpose is instruction or reference. **1. APPLICABILITY AND DEFINITIONS** This License applies to any manual or other work, in any medium, that contains a notice placed by the copyright holder saying it can be distributed under the terms of this License. Such a notice grants a world-wide, royalty-free license, unlimited in duration, to use that work under the conditions stated herein. The **Document**, below, refers to any such manual or work. Any member of the public is a licensee, and is addressed as "**you**". You accept the license if you copy, modify or distribute the work in a way requiring permission under copyright law. A "**Modified Version**" of the Document means any work containing the Document or a portion of it, either copied verbatim, or with modifications and/or translated into another language. A "**Secondary Section**" is a named appendix or a front-matter section of the Document that deals exclusively with the relationship of the publishers or authors of the Document to the Document's overall subject (or to related matters) and contains nothing that could fall directly within that overall subject. (Thus, if the Document is in part a textbook of mathematics, a Secondary Section may not explain any mathematics.) The relationship could be a matter of historical connection with the subject or with related matters, or of legal, commercial, philosophical, ethical or political position regarding them. The "**Invariant Sections**" are certain Secondary Sections whose titles are designated, as being those of Invariant Sections, in the notice that says that the Document is released under this License. If a section does not fit the above definition of Secondary then it is not allowed to be designated as Invariant. The Document may contain zero Invariant Sections. If the Document does not identify any Invariant Sections then there are none. The "**Cover Texts**" are certain short passages of text that are listed, as Front-Cover Texts or Back-Cover Texts, in the notice that says that the Document is released under this License. A Front-Cover Text may be at most 5 words, and a Back-Cover Text may be at most 25 words. A "**Transparent**" copy of the Document means a machine-readable copy, represented in a format whose specification is available to the general public, that is suitable for revising the document straightforwardly with generic text editors or (for images composed of pixels) generic paint programs or (for drawings) some widely available drawing editor, and that is suitable for input to text formatters or for automatic translation to a variety of formats suitable for input to text formatters. A copy made in an otherwise Transparent file format whose markup, or absence of markup, has been arranged to thwart or discourage subsequent modification by readers is not Transparent. An image format is not Transparent if used for any substantial amount of text. A copy that is not "Transparent" is called **Opaque**. Examples of suitable formats for Transparent copies include plain ASCII without markup, Texinfo input format, LaTeX input format, SGML or XML using a publicly available DTD, and standard-conforming simple HTML, PostScript or PDF designed for human modification. Examples of transparent image formats include PNG, XCF and JPG. Opaque formats include proprietary formats that can be read and edited only by proprietary word processors, SGML or XML for which the DTD and/or processing tools are not generally available, and the machine-generated HTML, PostScript or PDF produced by some word processors for output purposes only. The "**Title Page**" means, for a printed book, the title page itself, plus such following pages as are needed to hold, legibly, the material this License requires to appear in the title page. For works in formats which do not have any title page as such, "Title Page" means the text near the most prominent appearance of the work's title, preceding the beginning of the body of the text. The "**publisher**" means any person or entity that distributes copies of the Document to the public. A section "**Entitled XYZ**" means a named subunit of the Document whose title either is precisely XYZ or contains XYZ in parentheses following text that translates XYZ in another language. (Here XYZ stands for a specific section name mentioned below, such as "**Acknowledgements**", "**Dedications**", "**Endorsements**", or "**History**".) To "**Preserve the Title**" of such a section when you modify the Document means that it remains a section "Entitled XYZ" according to this definition. The Document may include Warranty Disclaimers next to the notice which states that this License applies to the Document. These Warranty Disclaimers are considered to be included by reference in this License, but only as regards disclaiming warranties: any other implication that these Warranty Disclaimers may have is void and has no effect on the meaning of this License. **2. VERBATIM COPYING** You may copy and distribute the Document in any medium, either commercially or noncommercially, provided that this License, the copyright notices, and the license notice saying this License applies to the Document are reproduced in all copies, and that you add no other conditions whatsoever to those of this License. You may not use technical measures to obstruct or control the reading or further copying of the copies you make or distribute. However, you may accept compensation in exchange for copies. If you distribute a large enough number of copies you must also follow the conditions in section 3. You may also lend copies, under the same conditions stated above, and you may publicly display copies. **3. COPYING IN QUANTITY** If you publish printed copies (or copies in media that commonly have printed covers) of the Document, numbering more than 100, and the Document's license notice requires Cover Texts, you must enclose the copies in covers that carry, clearly and legibly, all these Cover Texts: Front-Cover Texts on the front cover, and Back-Cover Texts on the back cover. Both covers must also clearly and legibly identify you as the publisher of these copies. The front cover must present the full title with all words of the title equally prominent and visible. You may add other material on the covers in addition. Copying with changes limited to the covers, as long as they preserve the title of the Document and satisfy these conditions, can be treated as verbatim copying in other respects. If the required texts for either cover are too voluminous to fit legibly, you should put the first ones listed (as many as fit reasonably) on the actual cover, and continue the rest onto adjacent pages. If you publish or distribute Opaque copies of the Document numbering more than 100, you must either include a machine-readable Transparent copy along with each Opaque copy, or state in or with each Opaque copy a computer-network location from which the general network-using public has access to download using public-standard network protocols a complete Transparent copy of the Document, free of added material. If you use the latter option, you must take reasonably prudent steps, when you begin distribution of Opaque copies in quantity, to ensure that this Transparent copy will remain thus accessible at the stated location until at least one year after the last time you distribute an Opaque copy (directly or through your agents or retailers) of that edition to the public. It is requested, but not required, that you contact the authors of the Document well before redistributing any large number of copies, to give them a chance to provide you with an updated version of the Document. **4. MODIFICATIONS** You may copy and distribute a Modified Version of the Document under the conditions of sections 2 and 3 above, provided that you release the Modified Version under precisely this License, with the Modified Version filling the role of the Document, thus licensing distribution and modification of the Modified Version to whoever possesses a copy of it. In addition, you must do these things in the Modified Version: A. Use in the Title Page (and on the covers, if any) a title distinct from that of the Document, and from those of previous versions (which should, if there were any, be listed in the History section of the Document). You may use the same title as a previous version if the original publisher of that version gives permission. B. List on the Title Page, as authors, one or more persons or entities responsible for authorship of the modifications in the Modified Version, together with at least five of the principal authors of the Document (all of its principal authors, if it has fewer than five), unless they release you from this requirement. C. State on the Title page the name of the publisher of the Modified Version, as the publisher. D. Preserve all the copyright notices of the Document. E. Add an appropriate copyright notice for your modifications adjacent to the other copyright notices. F. Include, immediately after the copyright notices, a license notice giving the public permission to use the Modified Version under the terms of this License, in the form shown in the Addendum below. G. Preserve in that license notice the full lists of Invariant Sections and required Cover Texts given in the Document's license notice. H. Include an unaltered copy of this License. I. Preserve the section Entitled "History", Preserve its Title, and add to it an item stating at least the title, year, new authors, and publisher of the Modified Version as given on the Title Page. If there is no section Entitled "History" in the Document, create one stating the title, year, authors, and publisher of the Document as given on its Title Page, then add an item describing the Modified Version as stated in the previous sentence. J. Preserve the network location, if any, given in the Document for public access to a Transparent copy of the Document, and likewise the network locations given in the Document for previous versions it was based on. These may be placed in the "History" section. You may omit a network location for a work that was published at least four years before the Document itself, or if the original publisher of the version it refers to gives permission. K. For any section Entitled "Acknowledgements" or "Dedications", Preserve the Title of the section, and preserve in the section all the substance and tone of each of the contributor acknowledgements and/or dedications given therein. L. Preserve all the Invariant Sections of the Document, unaltered in their text and in their titles. Section numbers or the equivalent are not considered part of the section titles. M. Delete any section Entitled "Endorsements". Such a section may not be included in the Modified Version. N. Do not retitle any existing section to be Entitled "Endorsements" or to conflict in title with any Invariant Section. O. Preserve any Warranty Disclaimers. If the Modified Version includes new front-matter sections or appendices that qualify as Secondary Sections and contain no material copied from the Document, you may at your option designate some or all of these sections as invariant. To do this, add their titles to the list of Invariant Sections in the Modified Version's license notice. These titles must be distinct from any other section titles. You may add a section Entitled "Endorsements", provided it contains nothing but endorsements of your Modified Version by various parties---for example, statements of peer review or that the text has been approved by an organization as the authoritative definition of a standard. You may add a passage of up to five words as a Front-Cover Text, and a passage of up to 25 words as a Back-Cover Text, to the end of the list of Cover Texts in the Modified Version. Only one passage of Front-Cover Text and one of Back-Cover Text may be added by (or through arrangements made by) any one entity. If the Document already includes a cover text for the same cover, previously added by you or by arrangement made by the same entity you are acting on behalf of, you may not add another; but you may replace the old one, on explicit permission from the previous publisher that added the old one. The author(s) and publisher(s) of the Document do not by this License give permission to use their names for publicity for or to assert or imply endorsement of any Modified Version. **5. COMBINING DOCUMENTS** You may combine the Document with other documents released under this License, under the terms defined in section 4 above for modified versions, provided that you include in the combination all of the Invariant Sections of all of the original documents, unmodified, and list them all as Invariant Sections of your combined work in its license notice, and that you preserve all their Warranty Disclaimers. The combined work need only contain one copy of this License, and multiple identical Invariant Sections may be replaced with a single copy. If there are multiple Invariant Sections with the same name but different contents, make the title of each such section unique by adding at the end of it, in parentheses, the name of the original author or publisher of that section if known, or else a unique number. Make the same adjustment to the section titles in the list of Invariant Sections in the license notice of the combined work. In the combination, you must combine any sections Entitled "History" in the various original documents, forming one section Entitled "History"; likewise combine any sections Entitled "Acknowledgements", and any sections Entitled "Dedications". You must delete all sections Entitled "Endorsements". **6. COLLECTIONS OF DOCUMENTS** You may make a collection consisting of the Document and other documents released under this License, and replace the individual copies of this License in the various documents with a single copy that is included in the collection, provided that you follow the rules of this License for verbatim copying of each of the documents in all other respects. You may extract a single document from such a collection, and distribute it individually under this License, provided you insert a copy of this License into the extracted document, and follow this License in all other respects regarding verbatim copying of that document. **7. AGGREGATION WITH INDEPENDENT WORKS** A compilation of the Document or its derivatives with other separate and independent documents or works, in or on a volume of a storage or distribution medium, is called an "aggregate" if the copyright resulting from the compilation is not used to limit the legal rights of the compilation's users beyond what the individual works permit. When the Document is included in an aggregate, this License does not apply to the other works in the aggregate which are not themselves derivative works of the Document. If the Cover Text requirement of section 3 is applicable to these copies of the Document, then if the Document is less than one half of the entire aggregate, the Document's Cover Texts may be placed on covers that bracket the Document within the aggregate, or the electronic equivalent of covers if the Document is in electronic form. Otherwise they must appear on printed covers that bracket the whole aggregate. **8. TRANSLATION** Translation is considered a kind of modification, so you may distribute translations of the Document under the terms of section 4. Replacing Invariant Sections with translations requires special permission from their copyright holders, but you may include translations of some or all Invariant Sections in addition to the original versions of these Invariant Sections. You may include a translation of this License, and all the license notices in the Document, and any Warranty Disclaimers, provided that you also include the original English version of this License and the original versions of those notices and disclaimers. In case of a disagreement between the translation and the original version of this License or a notice or disclaimer, the original version will prevail. If a section in the Document is Entitled "Acknowledgements", "Dedications", or "History", the requirement (section 4) to Preserve its Title (section 1) will typically require changing the actual title. **9. TERMINATION** You may not copy, modify, sublicense, or distribute the Document except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, or distribute it is void, and will automatically terminate your rights under this License. However, if you cease all violation of this License, then your license from a particular copyright holder is reinstated (a) provisionally, unless and until the copyright holder explicitly and finally terminates your license, and (b) permanently, if the copyright holder fails to notify you of the violation by some reasonable means prior to 60 days after the cessation. Moreover, your license from a particular copyright holder is reinstated permanently if the copyright holder notifies you of the violation by some reasonable means, this is the first time you have received notice of violation of this License (for any work) from that copyright holder, and you cure the violation prior to 30 days after your receipt of the notice. Termination of your rights under this section does not terminate the licenses of parties who have received copies or rights from you under this License. If your rights have been terminated and not permanently reinstated, receipt of a copy of some or all of the same material does not give you any rights to use it. **10. FUTURE REVISIONS OF THIS LICENSE** The Free Software Foundation may publish new, revised versions of the GNU Free Documentation License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. See http://www.gnu.org/copyleft/. Each version of the License is given a distinguishing version number. If the Document specifies that a particular numbered version of this License "or any later version" applies to it, you have the option of following the terms and conditions either of that specified version or of any later version that has been published (not as a draft) by the Free Software Foundation. If the Document does not specify a version number of this License, you may choose any version ever published (not as a draft) by the Free Software Foundation. If the Document specifies that a proxy can decide which future versions of this License can be used, that proxy's public statement of acceptance of a version permanently authorizes you to choose that version for the Document. **11. RELICENSING** "Massive Multiauthor Collaboration Site" (or "MMC Site") means any World Wide Web server that publishes copyrightable works and also provides prominent facilities for anybody to edit those works. A public wiki that anybody can edit is an example of such a server. A "Massive Multiauthor Collaboration" (or "MMC") contained in the site means any set of copyrightable works thus published on the MMC site. "CC-BY-SA" means the Creative Commons Attribution-Share Alike 3.0 license published by Creative Commons Corporation, a not-for-profit corporation with a principal place of business in San Francisco, California, as well as future copyleft versions of that license published by that same organization. "Incorporate" means to publish or republish a Document, in whole or in part, as part of another Document. An MMC is "eligible for relicensing" if it is licensed under this License, and if all works that were first published under this License somewhere other than this MMC, and subsequently incorporated in whole or in part into the MMC, (1) had no cover texts or invariant sections, and (2) were thus incorporated prior to November 1, 2008. The operator of an MMC Site may republish an MMC contained in the site under CC-BY-SA on the same site at any time before August 1, 2009, provided the MMC is eligible for relicensing. **ADDENDUM: How to use this License for your documents** To use this License in a document you have written, include a copy of the License in the document and put the following copyright and license notices just after the title page: Copyright © YEAR YOUR NAME. Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.3 or any later version published by the Free Software Foundation; with no Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. A copy of the license is included in the section entitled "GNU Free Documentation License". If you have Invariant Sections, Front-Cover Texts and Back-Cover Texts, replace the "with ... Texts." line with this: with the Invariant Sections being LIST THEIR TITLES, with the Front-Cover Texts being LIST, and with the Back-Cover Texts being LIST. If you have Invariant Sections without Cover Texts, or some other combination of the three, merge those two alternatives to suit the situation. If your document contains nontrivial examples of program code, we recommend releasing these examples in parallel under your choice of free software license, such as the GNU General Public License, to permit their use in free software. gprbuild-25.0.0/doc/share/latex_elements.py000066400000000000000000000032361470075373400206560ustar00rootroot00000000000000# define some latex elements to be used for PDF output PAGE_BLANK = r''' \makeatletter \def\cleartooddpage{%% \cleardoublepage%% } \def\cleardoublepage{%% \clearpage%% \if@twoside%% \ifodd\c@page%% %% nothing to do \else%% \hbox{}%% \thispagestyle{plain}%% \vspace*{\fill}%% \begin{center}%% \textbf{\em This page is intentionally left blank.}%% \end{center}%% \vspace{\fill}%% \newpage%% \if@twocolumn%% \hbox{}%% \newpage%% \fi%% \fi%% \fi%% } \makeatother ''' TOC_DEPTH = r''' \pagenumbering{arabic} \setcounter{tocdepth}{3} ''' TOC_CMD = r''' \makeatletter \def\tableofcontents{%% \pagestyle{plain}%% \chapter*{\contentsname}%% \@mkboth{\MakeUppercase{\contentsname}}%% {\MakeUppercase{\contentsname}}%% \@starttoc{toc}%% } \makeatother ''' TOC = r''' \cleardoublepage \tableofcontents \cleardoublepage\pagestyle{plain} ''' LATEX_HYPHEN = r''' \hyphenpenalty=5000 \tolerance=1000 ''' FOOTER = r""" \usepackage{titleref} \makeatletter \@ifundefined{fancyhf}{}{ \fancypagestyle{normal}{ \fancyhf{} % Define footers \fancyfoot[LE,RO]{{\py@HeaderFamily\thepage}} \fancyfoot[LO,RE]{\TR@currentTitle} } \fancypagestyle{plain}{ \fancyhf{} % Define footers \fancyfoot[LE,RO]{{\py@HeaderFamily\thepage}} \fancyfoot[LO,RE]{\TR@currentTitle} } } \makeatother """ def doc_settings(full_document_name, version): return '\n'.join([ r'\newcommand*{\GNATFullDocumentName}[0]{' + full_document_name + r'}', r'\newcommand*{\GNATVersion}[0]{' + version + r'}']) gprbuild-25.0.0/doinstall000077500000000000000000000073641470075373400153510ustar00rootroot00000000000000#!/bin/sh prefix='' has_gnatpro=n machine='' installdir='' # --------------------- Actual Installation of Gprbuild -------------- do_install () { if [ ! -d $installdir ]; then mkdir -p $installdir fi if tar cf - bin libexec share | (cd $installdir && tar xf -) ; then # --------------------------- End of the script ----------------------- clear echo " " echo "gprbuild has been installed in $installdir" echo "Thank you for using gprbuild!" echo " " else echo echo "The installation of gprbuild failed." echo "Please check the error messages above." echo fi } if [ $# -eq 1 ]; then if [ "$1" = "--help" ]; then cat << EOF Usage: $0 [install_dir] When no argument is specified, runs the gprbuild installer interactively, otherwise installs automatically under install_dir. EOF else echo " installing gprbuild under $1" installdir="$1" do_install fi exit 0 fi # Otherwise perform interactive install ggd_prefix='' if [ "x$ggd_prefix" = "x" ]; then ggd_prog="gnatmake" else ggd_prog="$ggd_prefix-gnatmake" fi if type $ggd_prog > /dev/null 2>&1 && $ggd_prog -v 2>&1 | grep GNATMAKE | grep -q Pro; then has_gnatpro=y saved_IFS="$IFS" IFS=: for d in $PATH; do if [ -x "$d/$ggd_prog" ]; then prefix=$d break fi done IFS="$saved_IFS" machine=`$prefix/gcc -dumpmachine || true` fi # remove last 'bin' from prefix as it's not expected prefix=`echo $prefix | sed 's/\/bin$//'` clear cat << EOF This script is provided to simplify the installation of the $machine binary distribution of gprbuild - the multi languages project builder. For information on commercial support, please contact sales@adacore.com. This script will ask a few questions regarding the gprbuild installation. Confirmation is required before any write action is taken. Please press RETURN to continue. EOF read x # --------------------- Select installation option -------------------- clear cat << EOF There are 2 options for installation: EOF if [ "$has_gnatpro" = "y" ]; then cat < Put_Line ("and catch!"); end Raise_And_Catch; begin Put_Line ("In Call_CPP"); Raise_And_Catch; cpp_routine; Put_Line ("Back in Call_CPP"); Raise_And_Catch; end Call_CPP; gprbuild-25.0.0/examples/ada_cpp/src1/call_cpp.ads000066400000000000000000000000751470075373400217450ustar00rootroot00000000000000procedure Call_CPP; pragma Export (C, Call_CPP, "call_cpp"); gprbuild-25.0.0/examples/ada_cpp/src1/cpp_main.cpp000066400000000000000000000002761470075373400217740ustar00rootroot00000000000000#include extern "C" void call_cpp (); extern "C" void adainit (); extern "C" void adafinal (); using namespace std; int main () { adainit (); call_cpp (); adafinal (); } gprbuild-25.0.0/examples/ada_cpp/src1/cpp_routine.cpp000066400000000000000000000010351470075373400225270ustar00rootroot00000000000000#include #include "cpp_routine.h" using namespace std; void recurse_then_raise (int n); void cpp_routine () { cout << " In cpp_routine" << endl; cout << " Calling recurse_then_raise" << endl; try { recurse_then_raise (10); } catch (int except) { cout << " caught an exception: " << except << endl; } cout << " returning from cpp_routine." << endl; } void recurse_then_raise (int n) { if (n > 0) { recurse_then_raise (n - 1); } else { throw 1; } } gprbuild-25.0.0/examples/ada_cpp/src1/cpp_routine.h000066400000000000000000000000401470075373400221670ustar00rootroot00000000000000extern "C" void cpp_routine (); gprbuild-25.0.0/examples/ada_cpp/src2/000077500000000000000000000000001470075373400174765ustar00rootroot00000000000000gprbuild-25.0.0/examples/ada_cpp/src2/animals.adb000066400000000000000000000003711470075373400215730ustar00rootroot00000000000000with Ada.Text_IO; use Ada.Text_IO; package body Animals is function Vaccination_Expired (A : Vaccinated_Dog) return Boolean is begin Put_Line (" In Ada: Vaccination_Expired"); return False; end Vaccination_Expired; end Animals; gprbuild-25.0.0/examples/ada_cpp/src2/animals.ads000066400000000000000000000035021470075373400216130ustar00rootroot00000000000000with Interfaces.C.Strings; use Interfaces.C.Strings; with Animals_Interfaces; use Animals_Interfaces; package Animals is type Animal is tagged limited record Age : Natural; end record; pragma Import (CPP, Animal); -- Note that we are not allowed to initialize the record components -- since this is reponsibility of the constructor and it is imported -- from C++ procedure Set_Age (X : in out Animal; Age : Natural); pragma Import (CPP, Set_Age); function Age (X : Animal) return Natural; pragma Import (CPP, Age); function New_Animal return Animal; pragma CPP_Constructor (New_Animal); pragma Import (CPP, New_Animal, "_ZN6AnimalC2Ev"); -- We must import the constructor from C++ since all the primitives -- are defined in C++ (and hence the C++ constructor is responsible -- of building the dispatch tables). -- ----------------------------------------------------------------------- type Dog is new Animal and Carnivore and Domestic with record Tooth_Count : Natural; Owner : String (1 .. 30); end record; pragma Import (CPP, Dog); function Number_Of_Teeth (A : Dog) return Natural; pragma Import (CPP, Number_Of_Teeth); procedure Set_Owner (A : in out Dog; Name : Chars_Ptr); pragma Import (CPP, Set_Owner); function New_Dog return Dog'Class; pragma CPP_Constructor (New_Dog); pragma Import (CPP, New_Dog, "_ZN3DogC2Ev"); -- ----------------------------------------------------------------------- -- Example of a type derivation defined in the Ada side that inherites -- all the dispatching primitives of the ancestor from the C++ side. type Vaccinated_Dog is new Dog with null record; function Vaccination_Expired (A : Vaccinated_Dog) return Boolean; pragma Convention (CPP, Vaccination_Expired); end Animals; gprbuild-25.0.0/examples/ada_cpp/src2/animals.h000066400000000000000000000007001470075373400212700ustar00rootroot00000000000000//animals.h class Carnivore { public: virtual int Number_Of_Teeth () = 0; }; class Domestic { public: virtual void Set_Owner (char* Name) = 0; }; class Animal { public: int Age_Count; virtual void Set_Age (int New_Age); virtual int Age (); }; class Dog : Animal, Carnivore, Domestic { public: int Tooth_Count; char *Owner; virtual int Number_Of_Teeth (); virtual void Set_Owner (char* Name); Dog(); // Constructor }; gprbuild-25.0.0/examples/ada_cpp/src2/animals_c.cc000066400000000000000000000012421470075373400217320ustar00rootroot00000000000000//animals.cpp #include "animals.h" #include using namespace std; // ------------------------------------------------------------- void Animal::Set_Age (int New_Age) { cout << " In C++ Animal::Set_Age" << endl; Age_Count = New_Age; } int Animal:: Age (void) { cout << " In C++ Animal::Age" << endl; return Age_Count; } // ------------------------------------------------------------- int Dog::Number_Of_Teeth (void) { cout << " In C++ Dog::Number_Of_Teeth" << endl; return Tooth_Count; } void Dog::Set_Owner (char* Name) { cout << " In C++ Dog::Set_Owner" << endl; } Dog::Dog(void) { cout << "C++: Constructor of Dog called" << endl; } gprbuild-25.0.0/examples/ada_cpp/src2/animals_interfaces.ads000066400000000000000000000006471470075373400240250ustar00rootroot00000000000000with Interfaces.C.Strings; use Interfaces.C.Strings; package Animals_Interfaces is type Carnivore is limited interface; function Number_Of_Teeth (X : Carnivore) return Natural is abstract; pragma Convention (CPP, Number_Of_Teeth); -- Required by AI-430 type Domestic is limited interface; procedure Set_Owner (X : in out Domestic; Name : Chars_Ptr) is abstract; pragma Convention (CPP, Set_Owner); end; gprbuild-25.0.0/examples/ada_cpp/src2/main.adb000066400000000000000000000026631470075373400211010ustar00rootroot00000000000000with Ada.Text_IO; use Ada.Text_IO; with Animals; use Animals; with Interfaces.C.Strings; use Interfaces.C.Strings; with Animals_Interfaces; use Animals_Interfaces; procedure Main is procedure Check_Carnivore (Obj : Carnivore'Class) is Aux : Natural; begin Put_Line ("Class wide calls to Carnivore ......"); Aux := Obj.Number_Of_Teeth; end Check_Carnivore; procedure Check_Domestic (Obj : in out Domestic'Class) is begin Put_Line ("Class wide calls to Domestic ......"); Obj.Set_Owner (Null_Ptr); end Check_Domestic; procedure Check_Vaccinated_Dog (Obj : in out Vaccinated_Dog'Class) is Aux_1 : Natural; Aux_2 : Boolean; begin Put_Line ("Class wide calls to Vaccinated_Dog ......"); -- Call the inherited primitives (Age, Set_Age) Obj.Set_Age (10); if Obj.Age /= 10 then raise Program_Error; end if; -- Call the primitives that override abstract interfaces Aux_1 := Obj.Number_Of_Teeth; -- Object.Opration notation (AI-252) Obj.Set_Owner (New_String ("Owner's name")); Aux_2 := Obj.Vaccination_Expired; end Check_Vaccinated_Dog; My_Pet : Vaccinated_Dog; -- Constructor in the C++ side begin Check_Carnivore (My_Pet); -- Check secondary DT Check_Domestic (My_Pet); -- Check secondary DT Check_Vaccinated_Dog (My_Pet); -- Check primary DT end Main; gprbuild-25.0.0/examples/ada_f77/000077500000000000000000000000001470075373400164465ustar00rootroot00000000000000gprbuild-25.0.0/examples/ada_f77/Makefile000066400000000000000000000003351470075373400201070ustar00rootroot00000000000000all: default.cgpr gprbuild -p -Pft $(GPRBUILDFLAGS) default.cgpr: gprconfig --batch --config Ada --config Fortran clean: default.cgpr gprclean -r -Pft $(RM) default.cgpr run: all ./fobj/ess .PHONY: all clean run gprbuild-25.0.0/examples/ada_f77/ess.f000066400000000000000000000035031470075373400174100ustar00rootroot00000000000000C-------------------------------------------- SUBROUTINE PRINT_MATR (A,N,M) C-------------------------------------------------------------------- INTEGER N, M INTEGER A (N,M) C BEGIN DO 10 I = 1,N PRINT *, (A (I, J), J=1,M) C DO 11 J = 1,M C PRINT *, A (I, J) C 11 CONTINUE 10 CONTINUE END C-------------------------------------------- SUBROUTINE INIT (A,N, M, VAL) C-------------------------------------------------------------------- INTEGER N, M, VAL INTEGER A (N,M) C BEGIN DO 20 I = 1,N DO 21 J = 1,M A (I, J) = VAL 21 CONTINUE 20 CONTINUE END C-------------------------------------------- SUBROUTINE ADD (A,B,C,N,M, LIG) C-------------------------------------------------------------------- INTEGER N, M, LIG INTEGER A (N,M), B(N,M), C (N,M) C BEGIN DO 30 J = 1,M C (LIG, J) = A (LIG, J) + B (LIG, J) 30 CONTINUE END C-------------------------------------------- PROGRAM ESS C-------------------------------------------------------------------- C BEGIN EXTERNAL ADD INTEGER N,M, A(400, 10000), B(400, 10000), C (400, 10000) N = 400 M = 10000 C C first interface C CALL ADAINIT CALL INIT (A, N, M, 2) CALL INIT (B, N, M, 8) CALL PARLOOP6 (1, N, I, ADD, A, B, C, N, M, I) C CALL PRINT_MATR (C, N, M) C C seconde interface C CALL INIT (A, N, M, 20) CALL INIT (B, N, M, 18) call INITSYNC (ISYNCH) DO 40 I= 1,N CALL POST6 (ISYNCH, I, ADD, A, B, C, N, M, I) 40 CONTINUE CALL WAITSYNC (ISYNCH) C CALL PRINT_MATR (C, N, M) CALL STOP CALL ADAFINAL END gprbuild-25.0.0/examples/ada_f77/fm.gpr000066400000000000000000000002561470075373400175650ustar00rootroot00000000000000project FM is for Languages use ("Ada"); for Source_Dirs use ("src"); for Library_Dir use "lib"; for Object_Dir use "obj"; for Library_Name use "fm"; end Fm; gprbuild-25.0.0/examples/ada_f77/ft.gpr000066400000000000000000000002471470075373400175740ustar00rootroot00000000000000with "fm"; project ft is for Languages use ("Fortran"); for Main use ("ess.f"); for Object_Dir use "fobj"; for Roots ("ess.f") use ("*"); end ft; gprbuild-25.0.0/examples/ada_f77/src/000077500000000000000000000000001470075373400172355ustar00rootroot00000000000000gprbuild-25.0.0/examples/ada_f77/src/fm-interfac.adb000066400000000000000000000237521470075373400221110ustar00rootroot00000000000000 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- F M - I N T E R F A C E -- -- -- -- B o d y -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (C) 1995-1998 Ada Core Technologies, Inc. -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- -- -- ------------------------------------------------------------------------------ with FM.Locks; use FM.Locks; with FM.Tuple_Manager; use FM.Tuple_Manager; package body FM.Interfac is type Array_Worker is array (Natural range <>) of Worker; Workers : Array_Worker (1 .. Nb_Workers); Procedure Set_Var (V : in out Tuple; I : Param_Range; Index: Fortran_Arg; Var : Fortran_Arg) is begin if Var = Index then V.Actuals (I) := new Integer'(Var.all); V.Saved (I) := True; else V.Actuals (I) := Var; V.Saved (I) := False; end if; end Set_Var; ----------- -- Post1 -- ----------- procedure Post1 (Synch : Integer; Index : Fortran_Arg; Subr : Fortran_Subr1; Var1 : Fortran_Arg) is V : Tuple (1); begin V.Ptr := To_Addr (Subr); V.Synch := Synch; Set_Var (V, 1, Index, Var1); Tuple_Manager.Post (V); end Post1; ----------- -- Post2 -- ----------- procedure Post2 (Synch : Integer; Index : Fortran_Arg; Subr : Fortran_Subr2; Var1 : Fortran_Arg; Var2 : Fortran_Arg) is V : Tuple (2); begin V.Ptr := To_Addr (Subr); V.Synch := Synch; Set_Var (V, 1, Index, Var1); Set_Var (V, 2, Index, Var2); Tuple_Manager.Post (V); end Post2; ----------- -- Post3 -- ----------- procedure Post3 (Synch : Integer; Index : Fortran_Arg; Subr : Fortran_Subr3; Var1 : Fortran_Arg; Var2 : Fortran_Arg; Var3 : Fortran_Arg) is V : Tuple (3); begin V.Ptr := To_Addr (Subr); V.Synch := Synch; Set_Var (V, 1, Index, Var1); Set_Var (V, 2, Index, Var2); Set_Var (V, 3, Index, Var3); Tuple_Manager.Post (V); end Post3; ----------- -- Post4 -- ----------- procedure Post4 (Synch : Integer; Index : Fortran_Arg; Subr : Fortran_Subr4; Var1 : Fortran_Arg; Var2 : Fortran_Arg; Var3 : Fortran_Arg; Var4 : Fortran_Arg) is V : Tuple (4); begin V.Ptr := To_Addr (Subr); V.Synch := Synch; Set_Var (V, 1, Index, Var1); Set_Var (V, 2, Index, Var2); Set_Var (V, 3, Index, Var3); Set_Var (V, 4, Index, Var4); Tuple_Manager.Post (V); end Post4; ----------- -- Post5 -- ----------- procedure Post5 (Synch : Integer; Index : Fortran_Arg; Subr : Fortran_Subr5; Var1 : Fortran_Arg; Var2 : Fortran_Arg; Var3 : Fortran_Arg; Var4 : Fortran_Arg; Var5 : Fortran_Arg) is V : Tuple (5); begin V.Ptr := To_Addr (Subr); V.Synch := Synch; Set_Var (V, 1, Index, Var1); Set_Var (V, 2, Index, Var2); Set_Var (V, 3, Index, Var3); Set_Var (V, 4, Index, Var4); Set_Var (V, 5, Index, Var5); Tuple_Manager.Post (V); end Post5; ----------- -- Post6 -- ----------- procedure Post6 (Synch : Integer; Index : Fortran_Arg; Subr : Fortran_Subr6; Var1 : Fortran_Arg; Var2 : Fortran_Arg; Var3 : Fortran_Arg; Var4 : Fortran_Arg; Var5 : Fortran_Arg; Var6 : Fortran_Arg) is V : Tuple (6); begin V.Ptr := To_Addr (Subr); V.Synch := Synch; Set_Var (V, 1, Index, Var1); Set_Var (V, 2, Index, Var2); Set_Var (V, 3, Index, Var3); Set_Var (V, 4, Index, Var4); Set_Var (V, 5, Index, Var5); Set_Var (V, 6, Index, Var6); Tuple_Manager.Post (V); end Post6; ---------- -- Lock -- ---------- procedure Lock is begin Lock_Manager.Lock; end Lock; -------------- -- Parloop1 -- -------------- procedure Parloop1 (From : Fortran_Arg; To : Fortran_Arg; Index : Fortran_Arg; Subr : Fortran_Subr1; Var1 : Fortran_Arg) is Isync : Integer := 0; begin Initsync (Isync); Index.all := From.all; while Index.all <= To.all loop Post1 (Isync, Index, Subr, Var1); Index.all := Index.all + 1; end loop; Waitsync (Isync); end Parloop1; -------------- -- Parloop2 -- -------------- procedure Parloop2 (From : Fortran_Arg; To : Fortran_Arg; Index : Fortran_Arg; Subr : Fortran_Subr2; Var1 : Fortran_Arg; Var2 : Fortran_Arg) is Isync : aliased Integer := 0; begin Initsync (Isync); Index.all := From.all; while Index.all <= To.all loop Post2 (Isync, Index, Subr, Var1, Var2); Index.all := Index.all + 1; end loop; Waitsync (Isync); end Parloop2; -------------- -- Parloop3 -- -------------- procedure Parloop3 (From : Fortran_Arg; To : Fortran_Arg; Index : Fortran_Arg; Subr : Fortran_Subr3; Var1 : Fortran_Arg; Var2 : Fortran_Arg; Var3 : Fortran_Arg) is Isync : aliased Integer := 0; begin Initsync (Isync); Index.all := From.all; while Index.all <= To.all loop Post3 (Isync, Index, Subr, Var1, Var2, Var3); Index.all := Index.all + 1; end loop; Waitsync (Isync); end Parloop3; -------------- -- Parloop4 -- -------------- procedure Parloop4 (From : Fortran_Arg; To : Fortran_Arg; Index : Fortran_Arg; Subr : Fortran_Subr4; Var1 : Fortran_Arg; Var2 : Fortran_Arg; Var3 : Fortran_Arg; Var4 : Fortran_Arg) is Isync : aliased Integer := 0; begin Initsync (Isync); Index.all := From.all; while Index.all <= To.all loop Post4 (Isync, Index, Subr, Var1, Var2, Var3, Var4); Index.all := Index.all + 1; end loop; Waitsync (Isync); end Parloop4; -------------- -- Parloop5 -- -------------- procedure Parloop5 (From : Fortran_Arg; To : Fortran_Arg; Index : Fortran_Arg; Subr : Fortran_Subr5; Var1 : Fortran_Arg; Var2 : Fortran_Arg; Var3 : Fortran_Arg; Var4 : Fortran_Arg; Var5 : Fortran_Arg) is Isync : aliased Integer := 0; begin Initsync (Isync); Index.all := From.all; while Index.all <= To.all loop Post5 (Isync, Index, Subr, Var1, Var2, Var3, Var4, Var5); Index.all := Index.all + 1; end loop; Waitsync (Isync); end Parloop5; -------------- -- Parloop6 -- -------------- procedure Parloop6 (From : Fortran_Arg; To : Fortran_Arg; Index : Fortran_Arg; Subr : Fortran_Subr6; Var1 : Fortran_Arg; Var2 : Fortran_Arg; Var3 : Fortran_Arg; Var4 : Fortran_Arg; Var5 : Fortran_Arg; Var6 : Fortran_Arg) is Isync : aliased Integer := 0; begin Initsync (Isync); Index.all := From.all; while Index.all <= To.all loop Post6 (Isync, Index, Subr, Var1, Var2, Var3, Var4, Var5, Var6); Index.all := Index.all + 1; end loop; Waitsync (Isync); end Parloop6; --------------- -- INITSYNC -- --------------- procedure Initsync (Synch : in out Integer) is begin Lock_Manager.Get_Synch (Synch); end Initsync; ---------- -- Stop -- ---------- procedure Stop is begin Stop_Called := True; end Stop; ------------ -- Unlock -- ------------ procedure Unlock is begin Lock_Manager.Unlock; end Unlock; -------------- -- Waitsync -- -------------- procedure Waitsync (Synch : Integer) is begin Lock_Manager.Wait (Synch); end Waitsync; end FM.Interfac; gprbuild-25.0.0/examples/ada_f77/src/fm-interfac.ads000066400000000000000000000225431470075373400221270ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- F M . I N T E R F A C E -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (C) 1995-1998 Ada Core Technologies, Inc. -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- -- -- ------------------------------------------------------------------------------ -- The subprograms in this package are to be called from Fortran code in order -- to make use of multiple processors for parallel execution. The first group -- of procedures are used to parallelize simple loops. The second group gives -- the user control over the fragments to be executed in parallel, and also -- provides explicit locking mechanisms that allow the Fortran user to define -- critical sections and barrier synchronization. -- with FM.Types; use FM.Types; package FM.Interfac is ------------- -- PARLOOP -- ------------- -- Fortran use: -- CALL PARLOOP1 (I1, IN, I, SUB, VAR1) -- CALL PARLOOP2 (I1, IN, I, SUB, VAR1, VAR2) -- CALL PARLOOP3 (I1, IN, I, SUB, VAR1, VAR2, VAR3) -- CALL PARLOOP4 (I1, IN, I, SUB, VAR1, VAR2, VAR3, VAR4) -- CALL PARLOOP5 (I1, IN, I, SUB, VAR1, VAR2, VAR3, VAR4, VAR5) -- CALL PARLOOP6 (I1, IN, I, SUB, VAR1, VAR2, VAR3, VAR4, VAR5, VAR6) -- Execute in parallel, the loop equivalent to -- DO 10 I=I1,IN -- CALL SUB (VAR1 ... VARn) -- 10 CONTINUE -- -- This is semantically equivalent to using the following calls, as -- explained below: -- CALL INITSYNC (ISYNC) -- DO 10 I=I1,IN -- CALL POSTn (ISYNC, I, SUB, VAR1 ... VARn) -- 10 CONTINUE -- CALL WAITSYNC (ISYNC) procedure Parloop1 ( From : Fortran_Arg; To : Fortran_Arg; Index : Fortran_Arg; Subr : Fortran_Subr1; Var1 : Fortran_Arg); pragma Export (Fortran, ParLoop1); procedure Parloop2 ( From : Fortran_Arg; To : Fortran_Arg; Index : Fortran_Arg; Subr : Fortran_Subr2; Var1 : Fortran_Arg; Var2 : Fortran_Arg); pragma Export (Fortran, ParLoop2); procedure Parloop3 ( From : Fortran_Arg; To : Fortran_Arg; Index : Fortran_Arg; Subr : Fortran_Subr3; Var1 : Fortran_Arg; Var2 : Fortran_Arg; Var3 : Fortran_Arg); pragma Export (Fortran, ParLoop3); procedure Parloop4 ( From : Fortran_Arg; To : Fortran_Arg; Index : Fortran_Arg; Subr : Fortran_Subr4; Var1 : Fortran_Arg; Var2 : Fortran_Arg; Var3 : Fortran_Arg; Var4 : Fortran_Arg); pragma Export (Fortran, ParLoop4); procedure Parloop5 ( From : Fortran_Arg; To : Fortran_Arg; Index : Fortran_Arg; Subr : Fortran_Subr5; Var1 : Fortran_Arg; Var2 : Fortran_Arg; Var3 : Fortran_Arg; Var4 : Fortran_Arg; Var5 : Fortran_Arg); pragma Export (Fortran, ParLoop5); procedure Parloop6 ( From : Fortran_Arg; To : Fortran_Arg; Index : Fortran_Arg; Subr : Fortran_Subr6; Var1 : Fortran_Arg; Var2 : Fortran_Arg; Var3 : Fortran_Arg; Var4 : Fortran_Arg; Var5 : Fortran_Arg; Var6 : Fortran_Arg); pragma Export (Fortran, ParLoop6); --------------- -- INITSYNC -- --------------- -- Fortran use: -- CALL INITSYNC (ISYNC) -- where ISYNC is a integer variable that must not be changed by the -- fortran code and that represents this specific loop. The same -- variable must be used for the call to WAITSYNC. This procedure is -- called prior to using one of the POST routines. procedure Initsync (Synch : in out Integer); pragma Export (Fortran, Initsync); -------------- -- WAITSYNC -- -------------- -- Fortran use: -- CALL WAITSYNC (ISYNC) -- where ISYNC is a integer variable that must not be changed by the -- fortran code and that represents this specific loop. It must match -- the variable used by a former call to INITSYNC. A call to this -- procedure will block execution of the program till all the POST calls -- are completed procedure Waitsync (Synch : Integer); pragma Export (Fortran, Waitsync); ---------- -- LOCK -- ---------- -- Fortran use: -- CALL LOCK () -- This procedure must be called before entering a critical section of code -- that cannot be executed in parallel. procedure Lock; pragma Export (Fortran, Lock); ------------ -- UNLOCK -- ------------ -- Fortran use: -- CALL UNLOCK () -- This procedure must be called after exiting a critical section of code -- that cannot be executed in parallel. procedure Unlock; pragma Export (Fortran, Unlock); ---------- -- STOP -- ---------- -- Fortran use: -- CALL STOP () -- This procedure should be called before ADAFINAL () to signify to the -- Ada subsystem that the workers can be shutdown. procedure Stop; pragma Export (Fortran, Stop); ---------------------- -- POST procedures -- ---------------------- -- Fortran use: -- CALL POST1 (ISYNC, I, SUB, VAR1) -- CALL POST2 (ISYNC, I, SUB, VAR1, VAR2) -- CALL POST3 (ISYNC, I, SUB, VAR1, VAR2, VAR3) -- CALL POST4 (ISYNC, I, SUB, VAR1, VAR2, VAR3, VAR4) -- CALL POST5 (ISYNC, I, SUB, VAR1, VAR2, VAR3, VAR4, VAR5) -- CALL POST6 (ISYNC, I, SUB, VAR1, VAR2, VAR3, VAR4, VAR5, VAR6) -- Each procedure allows to put a procedure call in -- the queue of calls to be executed. Interfaces are given for -- procedures with 1 to 6 parameters. ISYNC is the parameter matching the -- previous call to INITSYNC. I is the loop index. SUB is the subprogram -- to call with paramaters VAR1, ..., VAR6 procedure Post1 (Synch : Integer; Index : Fortran_Arg; Subr : Fortran_Subr1; Var1 : Fortran_Arg); pragma Export (Fortran, Post1); procedure Post2 (Synch : Integer; Index : Fortran_Arg; Subr : Fortran_Subr2; Var1 : Fortran_Arg; Var2 : Fortran_Arg); pragma Export (Fortran, Post2); procedure Post3 (Synch : Integer; Index : Fortran_Arg; Subr : Fortran_Subr3; Var1 : Fortran_Arg; Var2 : Fortran_Arg; Var3 : Fortran_Arg); pragma Export (Fortran, Post3); procedure Post4 (Synch : Integer; Index : Fortran_Arg; Subr : Fortran_Subr4; Var1 : Fortran_Arg; Var2 : Fortran_Arg; Var3 : Fortran_Arg; Var4 : Fortran_Arg); pragma Export (Fortran, Post4); procedure Post5 (Synch : Integer; Index : Fortran_Arg; Subr : Fortran_Subr5; Var1 : Fortran_Arg; Var2 : Fortran_Arg; Var3 : Fortran_Arg; Var4 : Fortran_Arg; Var5 : Fortran_Arg); pragma Export (Fortran, Post5); procedure Post6 (Synch : Integer; Index : Fortran_Arg; Subr : Fortran_Subr6; Var1 : Fortran_Arg; Var2 : Fortran_Arg; Var3 : Fortran_Arg; Var4 : Fortran_Arg; Var5 : Fortran_Arg; Var6 : Fortran_Arg); pragma Export (Fortran, Post6); end FM.Interfac; gprbuild-25.0.0/examples/ada_f77/src/fm-locks.adb000066400000000000000000000070551470075373400214270ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- F M . L O C K S -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (C) 1995-1998 Ada Core Technologies, Inc. -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- -- -- ------------------------------------------------------------------------------ package body FM.Locks is protected body Lock_Manager is entry Barrier (for J in 1..NB_Sync) when Locks (J) = 0 is begin Available (J) := True; end; procedure Get_Synch (Synch : in out Integer) is begin for I in Locks'range loop if Available (I) then Available (I) := False; Synch := I; return; end if; end loop; raise Program_Error; end Get_Synch; procedure Inc (Synch : Integer; Val : Integer) is begin Locks (Synch) := Locks (Synch) + Val; end Inc; entry Lock when not Global_Lock is begin Global_Lock := True; end Lock; procedure Unlock is begin Global_Lock := False; end Unlock; entry Wait (I : Integer) when True is begin if Locks (I) > 0 then requeue Barrier (I); end if; end Wait; end Lock_Manager; procedure Inc (Synch : Integer; Val : Integer := 1) is begin Lock_Manager.Inc (Synch, Val); end Inc; end FM.Locks; gprbuild-25.0.0/examples/ada_f77/src/fm-locks.ads000066400000000000000000000067321470075373400214510ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- F M . L O C K S -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (C) 1995-1998 Ada Core Technologies, Inc. -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- -- -- ------------------------------------------------------------------------------ -- This package provides an array of locks to be used for multiple synchro- -- nization. Typically each lock provides barrier synchronization for the -- iterates of one loop. It is unlikely that more that two locks would ever -- be used concurrently, but this model will be just as usable on an SP2 -- with 2000 nodes as on a dual-processor SPARC. private package FM.Locks is type Lock_Type is array (Integer range <>) of Integer; type Flags is array (Integer range <>) of Boolean; procedure Inc (Synch : Integer; Val : Integer := 1); protected Lock_Manager is procedure Get_Synch (Synch : in out Integer); entry Wait (I : Integer); procedure Inc (Synch : Integer; Val : Integer); entry Lock; procedure Unlock; private Locks : Lock_Type (1.. NB_Sync) := (others => 0); Available : Flags (1 .. NB_Sync) := (others => True); Global_Lock : Boolean := False; entry Barrier (1 .. NB_Sync); end Lock_Manager; end FM.Locks; gprbuild-25.0.0/examples/ada_f77/src/fm-protected_queue.adb000066400000000000000000000057161470075373400235130ustar00rootroot00000000000000 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- F M _ P R O T E C T E D _ Q U E U E -- -- -- -- B o d y -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (C) 1995-1998 Ada Core Technologies, Inc. -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- -- -- ------------------------------------------------------------------------------ package body FM.Protected_Queue is protected body Queue is entry Insert (Object : T) when Contents < Cap is begin Pending (Back) := Object; Back := (Back + 1) mod Cap; Contents := Contents + 1; end Insert; Entry Remove (Object : out T) when Contents > 0 is begin Object := Pending (Front); Front := (Front + 1) mod Cap; Contents := Contents - 1; end Remove; end Queue; end FM.Protected_Queue; gprbuild-25.0.0/examples/ada_f77/src/fm-protected_queue.ads000066400000000000000000000060771470075373400235350ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- F M _ P R O T E C T E D _ Q U E U E -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (C) 1995-1998 Ada Core Technologies, Inc. -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- -- -- ------------------------------------------------------------------------------ -- This package provides a generic protected queue type. Insertions and -- deletions are serialized by an internal protected object. The package is -- parametrized with the total queue capacity, and with the type of the -- objects to be queued. generic Cap : integer; type T is private; package FM.Protected_Queue is type Jobs is array (0 .. Cap - 1) of T; protected Queue is entry Insert (Object : T); entry Remove (Object : out T); private Front, Back : Integer := 0; Contents : Integer := 0; Pending : Jobs; end Queue; end FM.Protected_Queue; gprbuild-25.0.0/examples/ada_f77/src/fm-system_dependant.adb000066400000000000000000000003101470075373400236450ustar00rootroot00000000000000package body FM.System_Dependant is function Thread_Setup return System.Task_Info.Task_Info_Type is begin return System.Task_Info.Unspecified_Task_Info; end; end FM.System_Dependant; gprbuild-25.0.0/examples/ada_f77/src/fm-system_dependant.ads000066400000000000000000000004231470075373400236730ustar00rootroot00000000000000with System.Task_Info; package FM.System_Dependant is function Thread_Setup return System.Task_Info.Task_Info_Type; -- This function is called at elaboration of the Worker's tasks -- and can be used to set some system specific options end FM.System_Dependant; gprbuild-25.0.0/examples/ada_f77/src/fm-tuple_manager.adb000066400000000000000000000103341470075373400231310ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- F M - T U P L E _ M A N A G E R -- -- -- -- B o d y -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (C) 1995-1998 Ada Core Technologies, Inc. -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- -- -- ------------------------------------------------------------------------------ with FM.Locks; use FM.Locks; package body FM.Tuple_Manager is procedure Post (T : Tuple) is begin Inc (T.Synch); Queue.Insert (T); end; task body Worker is T : Tuple; begin while not Stop_Called loop select Queue.Remove (T); case T.N is when 1 => To_Ptr1 (T.Ptr) (T.Actuals (1)); when 2 => To_Ptr2 (T.Ptr) ( T.Actuals (1), T.Actuals (2)); when 3 => To_Ptr3 (T.Ptr) ( T.Actuals (1), T.Actuals (2), T.Actuals (3)); when 4 => To_Ptr4 (T.Ptr) ( T.Actuals (1), T.Actuals (2), T.Actuals (3), T.Actuals (4)); when 5 => To_Ptr5 (T.Ptr) ( T.Actuals (1), T.Actuals (2), T.Actuals (3), T.Actuals (4), T.Actuals (5)); when 6 => To_Ptr6 (T.Ptr) ( T.Actuals (1), T.Actuals (2), T.Actuals (3), T.Actuals (4), T.Actuals (5), T.Actuals (6)); when others => raise Program_Error; end case; -- Indicate that iterate is complete. Inc (T.Synch, -1); -- Deallocate the saved parameters for I in 1 .. T.N loop if T.Saved (I) then Free (T.Actuals (I)); end if; end loop; or delay 0.1; end select; end loop; end Worker; end FM.Tuple_Manager; gprbuild-25.0.0/examples/ada_f77/src/fm-tuple_manager.ads000066400000000000000000000074701470075373400231610ustar00rootroot00000000000000 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- F M - T U P L E _ M A N A G E R -- -- -- -- S p e c -- -- -- -- $Revision: 1.2 $ -- -- -- -- Copyright (C) 1998-2000 Ada Core Technologies, Inc. -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- -- -- ------------------------------------------------------------------------------ -- This package specifies the management of a queue of jobs that can be -- executed concurrently. The tuple space is implemented by means of a -- protected queue that holds independent iterates. Worker tasks remove -- work items from the queue and execute them independently. with FM.Protected_Queue; with System; use System; with FM.Types; use FM.Types; with FM.System_Dependant; private package FM.Tuple_Manager is task type Worker is pragma Storage_Size (Worker_Stack_Size); pragma Task_Info (FM.System_Dependant.Thread_Setup); end; -- Worker tasks remove work items from the queue and call back the -- Fortran subprogram with the proper actuals, which have been captured -- in the interface. subtype Param_Range is Natural range 1 .. 10; type Params is array (Param_Range range <>) of Fortran_Arg; type Booleans is array (Param_Range range <>) of Boolean; type Tuple (N : Param_Range := 1) is record Ptr : Address; Synch : Integer; Actuals : Params (1 .. N); Saved : Booleans (1 .. N); end record; -- This type describes the structure of a unit of work. package Work_Queue is new Protected_Queue (Nb_Jobs, Tuple); use Work_Queue; procedure Post (T : Tuple); -- Insert work item in protected queue. Called from interface routines. end FM.Tuple_Manager; gprbuild-25.0.0/examples/ada_f77/src/fm-types.ads000066400000000000000000000122261470075373400214750ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- F M . T Y P E S -- -- -- -- S p e c -- -- -- -- $Revision: 1.1 $ -- -- -- -- Copyright (C) 1995-1998 Ada Core Technologies, Inc. -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- -- -- ------------------------------------------------------------------------------ -- This package provides the basic types used in interfacing Fortran -- routines to Ada. We declare several access to procedures with a -- variables number of formals. Given Fortran passes all parameters by -- address, the interface uses the type System.Address for all of them. -- Thus the Ada side performs no type-checking at all, and it is up to -- the Fortran programmer to insure that the proper interface procedure is -- invoked. with System; use System; with Unchecked_Conversion; with Unchecked_Deallocation; package FM.types is type Fortran_Arg is access all integer; -- A fortran argument is passed by reference procedure Free is new Unchecked_Deallocation (Integer, Fortran_Arg); type Fortran_Subr1 is access procedure (Var1 : Fortran_Arg); pragma Convention (Fortran, Fortran_Subr1); function To_Addr is new Unchecked_Conversion (Fortran_Subr1, Address); function To_Ptr1 is new Unchecked_Conversion (Address, Fortran_Subr1); type Fortran_Subr2 is access procedure (Var1 : Fortran_Arg; Var2 : Fortran_Arg); pragma Convention (Fortran, Fortran_Subr2); function To_Addr is new Unchecked_Conversion (Fortran_Subr2, Address); function To_Ptr2 is new Unchecked_Conversion (Address, Fortran_Subr2); type Fortran_Subr3 is access procedure (Var1 : Fortran_Arg; Var2 : Fortran_Arg; Var3 : Fortran_Arg); pragma Convention (Fortran, Fortran_Subr3); function To_Addr is new Unchecked_Conversion (Fortran_Subr3, Address); function To_Ptr3 is new Unchecked_Conversion (Address, Fortran_Subr3); type Fortran_Subr4 is access procedure (Var1 : Fortran_Arg; Var2 : Fortran_Arg; Var3 : Fortran_Arg; Var4 : Fortran_Arg); pragma Convention (Fortran, Fortran_Subr4); function To_Addr is new Unchecked_Conversion (Fortran_Subr4, Address); function To_Ptr4 is new Unchecked_Conversion (Address, Fortran_Subr4); type Fortran_Subr5 is access procedure (Var1 : Fortran_Arg; Var2 : Fortran_Arg; Var3 : Fortran_Arg; Var4 : Fortran_Arg; Var5 : Fortran_Arg); pragma Convention (Fortran, Fortran_Subr5); function To_Addr is new Unchecked_Conversion (Fortran_Subr5, Address); function To_Ptr5 is new Unchecked_Conversion (Address, Fortran_Subr5); type Fortran_Subr6 is access procedure (Var1 : Fortran_Arg; Var2 : Fortran_Arg; Var3 : Fortran_Arg; Var4 : Fortran_Arg; Var5 : Fortran_Arg; Var6 : Fortran_Arg); pragma Convention (Fortran, Fortran_Subr6); function To_Addr is new Unchecked_Conversion (Fortran_Subr6, Address); function To_Ptr6 is new Unchecked_Conversion (Address, Fortran_Subr6); end FM.Types; gprbuild-25.0.0/examples/ada_f77/src/fm.adb000066400000000000000000000106001470075373400203040ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- F M -- -- -- -- B o d y -- -- -- -- -- -- Copyright (C) 1995-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; use Ada.Text_IO; with Ada.Integer_Text_IO; pragma Warnings (Off, """System.Parameters"" is An Internal GNAT Unit"); pragma Warnings (Off, "use of This Unit is Non-Portable and Version-dependent"); with System.Parameters; pragma Warnings (On, """System.Parameters"" is An Internal GNAT Unit"); pragma Warnings (On, "use of This Unit is Non-Portable and Version-dependent"); package body FM is Init_Error : exception; procedure Read_Init_File; procedure Read_Init_File is F : File_Type; File_Ok : Boolean := True; begin -- Open the file if it is there otherwise, nothing needs to be done begin Open (F, In_File, "fm.ini"); exception when others => File_Ok := False; end; -- If the file is available, get the number of workers if File_Ok then begin Ada.Integer_Text_IO.Get (F, NB_Workers); exception when others => Put ("fm.ini incorrectly formatted: it must contain"); Put_Line ("1 or 2 integer values"); Close (F); raise Init_Error; end; end if; -- If there is another integer value in the file, this is the -- default stack size. Read in a temp to avoid clobbering the -- default value in case of failure if File_Ok then declare Temp : Integer; begin Ada.Integer_Text_IO.Get (F, Temp); Worker_Stack_Size := Temp; exception when others => null; end; Close (F); end if; end Read_Init_File; -------------- -- Nb_Tasks -- -------------- function Nb_Tasks return Fortran_Integer is begin return Fortran_Integer (NB_Workers); end Nb_Tasks; ---------------------- -- Set_Waiting_Time -- ---------------------- procedure Set_Waiting_Time (T : Real) is begin Waiting_Time := Duration (T); end Set_Waiting_Time; begin Worker_Stack_Size := Integer (System.Parameters.Default_Stack_Size); Read_Init_File; Ada.Integer_Text_IO.Put (NB_Workers); New_Line; Ada.Integer_Text_IO.Put (Worker_Stack_Size); New_Line; end FM; gprbuild-25.0.0/examples/ada_f77/src/fm.ads000066400000000000000000000077231470075373400203410ustar00rootroot00000000000000 ------------------------------------------------------------------------------ -- -- -- GNAT RUNTIME COMPONENTS -- -- -- -- F M -- -- -- -- S p e c -- -- -- -- $Revision: 1.3 $ -- -- -- -- Copyright (C) 1998-2000 Ada Core Technologies, Inc. -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- -- -- ------------------------------------------------------------------------------ with Interfaces.Fortran; use Interfaces.Fortran; package FM is pragma Elaborate_Body; -- Root of the FM (Fortran Multitasking) Interface -- Interface to Fortran program can be found in FM.Interface NB_Workers : Integer := 6; -- This variable determines the number of workers that will work in -- parallel to statisfy the requests from the Fortran code. It is -- reinitialized in the body of this package if a file fm.ini is found -- in the current directory. This value can be interrogated from -- Fortran by means of function Nb_Tasks. Worker_Stack_Size : Integer; -- The size of the stack for each worker. This value is -- initialized in the body of this package. NB_Jobs : constant := 500; -- This constant determines the maximum number of jobs that can be -- posted asynchronously. NB_Sync : constant := 10; -- This constant determines the maximum number of calls to INITSYNC -- that can be made before doing a WAITSYNC. i.e. how many batch of -- parallel operations can be open at the same time Waiting_Time : duration := 0.1; -- This variable determines the polling rate used by a worker task to -- retrieve a work item from the queue. Reset by Set_Waiting_Time, which -- is called from Fortran. function Nb_Tasks return Fortran_Integer; pragma Export (Fortran, Nb_Tasks); procedure Set_Waiting_Time (T : Real); pragma Export (Fortran, Set_Waiting_Time); private Stop_Called : Boolean := False; end FM; gprbuild-25.0.0/examples/extended_projects/000077500000000000000000000000001470075373400207475ustar00rootroot00000000000000gprbuild-25.0.0/examples/extended_projects/Makefile000066400000000000000000000005461470075373400224140ustar00rootroot00000000000000all: ../subsystems/default.cgpr gprbuild -p -Pnew_ada_main --config=../subsystems/default.cgpr $(GPRBUILDFLAGS) ../subsystems/default.cgpr: $(MAKE) -C ../subsystems default.cgpr clean: ../subsystems/default.cgpr gprclean -r -Pnew_ada_main --config=../subsystems/default.cgpr $(MAKE) -C ../subsystems clean run: all ./ada_main .PHONY: all clean run gprbuild-25.0.0/examples/extended_projects/new_ada_main.gpr000066400000000000000000000003361470075373400240650ustar00rootroot00000000000000with "new_common_subsystem.gpr"; project New_Ada_Main extends all "../subsystems/ada_main.gpr" is for Source_Dirs use ("new_ada_src"); for Object_Dir use "new_obj"; for Exec_Dir use "."; end New_Ada_Main; gprbuild-25.0.0/examples/extended_projects/new_ada_src/000077500000000000000000000000001470075373400232145ustar00rootroot00000000000000gprbuild-25.0.0/examples/extended_projects/new_ada_src/ada_main.adb000066400000000000000000000001511470075373400254120ustar00rootroot00000000000000with C_Lib; procedure Ada_Main is begin C_Lib.Do_Something; C_Lib.Do_Something_Else; end Ada_Main; gprbuild-25.0.0/examples/extended_projects/new_common_subsystem.gpr000066400000000000000000000002721470075373400257410ustar00rootroot00000000000000project New_Common_Subsystem extends "../subsystems/common_subsystem.gpr" is for Source_Dirs use ("new_util_src"); for Object_Dir use "new_obj_util"; end New_Common_Subsystem; gprbuild-25.0.0/examples/extended_projects/new_util_src/000077500000000000000000000000001470075373400234445ustar00rootroot00000000000000gprbuild-25.0.0/examples/extended_projects/new_util_src/c_lib.ads000066400000000000000000000002451470075373400252060ustar00rootroot00000000000000package C_Lib is procedure Do_Something; pragma Import (C, Do_Something); procedure Do_Something_Else; pragma Import (C, Do_Something_Else); end C_Lib; gprbuild-25.0.0/examples/extended_projects/new_util_src/lib2.c000066400000000000000000000001431470075373400244360ustar00rootroot00000000000000#include void do_something_else (void) { printf ("Doing something else in C \n"); } gprbuild-25.0.0/examples/first_steps/000077500000000000000000000000001470075373400176035ustar00rootroot00000000000000gprbuild-25.0.0/examples/first_steps/Makefile000066400000000000000000000004511470075373400212430ustar00rootroot00000000000000all: default.cgpr gprbuild -p -Pc_main $(GPRBUILDFLAGS) gprbuild -p -Pada_main $(GPRBUILDFLAGS) default.cgpr: gprconfig --batch --config Ada --config C clean: default.cgpr gprclean -Pc_main gprclean -Pada_main $(RM) default.cgpr run: all ./ada_main ./obj1/c_main .PHONY: all clean run gprbuild-25.0.0/examples/first_steps/ada_main.gpr000066400000000000000000000004511470075373400220460ustar00rootroot00000000000000project Ada_Main is for Languages use ("Ada", "C"); for Source_Dirs use ("ada_src", "util_src"); for Object_Dir use "obj"; for Exec_Dir use "."; for Source_Files use ("ada_main.adb", "c_lib.ads", "lib.h", "lib.c"); for Main use ("ada_main.adb"); end Ada_Main; gprbuild-25.0.0/examples/first_steps/ada_src/000077500000000000000000000000001470075373400211775ustar00rootroot00000000000000gprbuild-25.0.0/examples/first_steps/ada_src/ada_main.adb000066400000000000000000000001151470075373400233750ustar00rootroot00000000000000with C_Lib; procedure Ada_Main is begin C_Lib.Do_Something; end Ada_Main; gprbuild-25.0.0/examples/first_steps/c_main.gpr000066400000000000000000000006471470075373400215520ustar00rootroot00000000000000project C_Main is for Languages use ("Ada", "C"); for Source_Dirs use ("c_src", "util_src"); for Object_Dir use "obj1"; for Main use ("c_main.c"); package Compiler is C_Switches := ("-pedantic"); for Default_Switches ("C") use C_Switches; for Default_Switches ("Ada") use ("-gnaty"); for Switches ("c_main.c") use C_Switches & ("-g"); end Compiler; end C_Main; gprbuild-25.0.0/examples/first_steps/c_src/000077500000000000000000000000001470075373400206745ustar00rootroot00000000000000gprbuild-25.0.0/examples/first_steps/c_src/c_main.c000066400000000000000000000002751470075373400222720ustar00rootroot00000000000000#include extern void adainit (void); extern void adafinal (void); extern void do_it_in_ada(void); int main (void) { adainit(); do_it_in_ada (); adafinal(); exit (0); } gprbuild-25.0.0/examples/first_steps/util_src/000077500000000000000000000000001470075373400214275ustar00rootroot00000000000000gprbuild-25.0.0/examples/first_steps/util_src/ada_lib.adb000066400000000000000000000002431470075373400234510ustar00rootroot00000000000000with Ada.Text_IO; use Ada.Text_IO; package body Ada_Lib is procedure Do_It_In_Ada is begin Put_Line ("Done in Ada"); end Do_It_In_Ada; end Ada_Lib; gprbuild-25.0.0/examples/first_steps/util_src/ada_lib.ads000066400000000000000000000001371470075373400234740ustar00rootroot00000000000000package Ada_Lib is procedure Do_It_In_Ada; pragma Export (C, Do_It_In_Ada); end Ada_Lib; gprbuild-25.0.0/examples/first_steps/util_src/c_lib.ads000066400000000000000000000001341470075373400231660ustar00rootroot00000000000000package C_Lib is procedure Do_Something; pragma Import (C, Do_Something); end C_Lib; gprbuild-25.0.0/examples/first_steps/util_src/lib.c000066400000000000000000000001521470075373400223370ustar00rootroot00000000000000#include #include "lib.h" void do_something (void) { printf ("Doing something in C \n"); } gprbuild-25.0.0/examples/first_steps/util_src/lib.h000066400000000000000000000000421470075373400223420ustar00rootroot00000000000000extern void do_something (void); gprbuild-25.0.0/examples/libraries/000077500000000000000000000000001470075373400172125ustar00rootroot00000000000000gprbuild-25.0.0/examples/libraries/Makefile000066400000000000000000000010431470075373400206500ustar00rootroot00000000000000all: default.cgpr gprbuild -p -Pmain0 $(GPRBUILDFLAGS) gprbuild -p -Pmain1 $(GPRBUILDFLAGS) gprbuild -p -Pmain2 $(GPRBUILDFLAGS) gprbuild -p -Pmain3 $(GPRBUILDFLAGS) gprbuild -p -Pmain4 $(GPRBUILDFLAGS) default.cgpr: gprconfig --batch --config Ada --config C clean: default.cgpr gprclean -r -Pmain0 gprclean -r -Pmain1 gprclean -r -Pmain2 gprclean -r -Pmain3 gprclean -r -Pmain4 $(RM) default.cgpr run: all ./main0 ./main1 PATH="lib2:$$PATH" ./main2 PATH="lib3:$$PATH" ./main3 PATH="lib2:$$PATH" ./main4 .PHONY: all clean run gprbuild-25.0.0/examples/libraries/ada_main.adb000066400000000000000000000001211470075373400214050ustar00rootroot00000000000000with Ada_Lib; procedure Ada_Main is begin Ada_Lib.Do_It_In_Ada; end Ada_Main; gprbuild-25.0.0/examples/libraries/c_main.c000066400000000000000000000002751470075373400206100ustar00rootroot00000000000000#include extern void adainit (void); extern void adafinal (void); extern void do_it_in_ada(void); int main (void) { adainit(); do_it_in_ada (); adafinal(); exit (0); } gprbuild-25.0.0/examples/libraries/dynamic_lib.gpr000066400000000000000000000003741470075373400222020ustar00rootroot00000000000000library project Dynamic_Lib is for Languages use ("Ada", "C"); for Source_Dirs use ("lib_src"); for Object_Dir use "obj2"; for Library_Dir use "lib2"; for Library_Kind use "dynamic"; for Library_Name use "l2"; end Dynamic_Lib; gprbuild-25.0.0/examples/libraries/extern_lib.gpr000066400000000000000000000003761470075373400220650ustar00rootroot00000000000000library project Extern_Lib is for Languages use ("Ada", "C"); for Source_Dirs use ("lib_src"); for Library_Dir use "lib2"; for Library_Kind use "dynamic"; for Library_Name use "l2"; for Externally_Built use "true"; end Extern_Lib; gprbuild-25.0.0/examples/libraries/lib_src/000077500000000000000000000000001470075373400206275ustar00rootroot00000000000000gprbuild-25.0.0/examples/libraries/lib_src/ada_lib.adb000066400000000000000000000002431470075373400226510ustar00rootroot00000000000000with Ada.Text_IO; use Ada.Text_IO; package body Ada_Lib is procedure Do_It_In_Ada is begin Put_Line ("Done in Ada"); end Do_It_In_Ada; end Ada_Lib; gprbuild-25.0.0/examples/libraries/lib_src/ada_lib.ads000066400000000000000000000001371470075373400226740ustar00rootroot00000000000000package Ada_Lib is procedure Do_It_In_Ada; pragma Export (C, Do_It_In_Ada); end Ada_Lib; gprbuild-25.0.0/examples/libraries/lib_src/c_lib.ads000066400000000000000000000001341470075373400223660ustar00rootroot00000000000000package C_Lib is procedure Do_Something; pragma Import (C, Do_Something); end C_Lib; gprbuild-25.0.0/examples/libraries/lib_src/lib.c000066400000000000000000000001521470075373400215370ustar00rootroot00000000000000#include #include "lib.h" void do_something (void) { printf ("Doing something in C \n"); } gprbuild-25.0.0/examples/libraries/lib_src/lib.h000066400000000000000000000000421470075373400215420ustar00rootroot00000000000000extern void do_something (void); gprbuild-25.0.0/examples/libraries/main0.gpr000066400000000000000000000003431470075373400207300ustar00rootroot00000000000000with "static_lib.gpr"; project Main0 is for Languages use ("Ada"); for Main use ("ada_main.adb"); package Builder is for Executable ("ada_main.adb") use "main0"; end Builder; end Main0; gprbuild-25.0.0/examples/libraries/main1.gpr000066400000000000000000000004041470075373400207270ustar00rootroot00000000000000with "static_lib.gpr"; project Main1 is for Languages use ("C"); for Main use ("c_main.c"); for Roots ("c_main.c") use ("ada_lib"); package Builder is for Executable ("c_main.c") use "main1"; end Builder; end Main1; gprbuild-25.0.0/examples/libraries/main2.gpr000066400000000000000000000004661470075373400207400ustar00rootroot00000000000000with "dynamic_lib.gpr"; project Main2 is for Languages use ("C"); for Main use ("c_main.c"); for Roots ("c_main.c") use ("*"); for Object_Dir use "obj1"; for Exec_Dir use "."; package Builder is for Executable ("c_main.c") use "main2"; end Builder; end Main2; gprbuild-25.0.0/examples/libraries/main3.gpr000066400000000000000000000003211470075373400207270ustar00rootroot00000000000000with "sa_lib.gpr"; project Main3 is for Languages use ("C", "Ada"); for Main use ("c_main.c"); package Builder is for Executable ("c_main.c") use "main3"; end Builder; end Main3; gprbuild-25.0.0/examples/libraries/main4.gpr000066400000000000000000000004731470075373400207400ustar00rootroot00000000000000with "extern_lib.gpr"; project Main4 is for Languages use ("C"); for Main use ("c_main.c"); for Roots ("c_main.c") use ("ada_lib"); for Object_Dir use "obj1"; for Exec_Dir use "."; package Builder is for Executable ("c_main.c") use "main4"; end Builder; end Main4; gprbuild-25.0.0/examples/libraries/sa_lib.gpr000066400000000000000000000003641470075373400211600ustar00rootroot00000000000000project Sa_Lib is for Languages use ("Ada", "C"); for Source_Dirs use ("lib_src"); for Library_Dir use "lib3"; for Library_Kind use "dynamic"; for Library_Interface use ("ada_lib"); for Library_Name use "ada"; end Sa_Lib; gprbuild-25.0.0/examples/libraries/static_lib.gpr000066400000000000000000000003671470075373400220470ustar00rootroot00000000000000library project Static_Lib is for Languages use ("Ada", "C"); for Source_Dirs use ("lib_src"); for Object_Dir use "obj"; for Library_Dir use "lib"; for Library_Kind use "static"; for Library_Name use "l1"; end Static_Lib; gprbuild-25.0.0/examples/matrix/000077500000000000000000000000001470075373400165425ustar00rootroot00000000000000gprbuild-25.0.0/examples/matrix/Makefile000066400000000000000000000003551470075373400202050ustar00rootroot00000000000000all: default.cgpr gprbuild -p -Pmatrix $(GPRBUILDFLAGS) default.cgpr: gprconfig --batch --config Ada --config C --config Fortran clean: default.cgpr gprclean -Pmatrix $(RM) default.cgpr run: all ./obj/main .PHONY: all clean run gprbuild-25.0.0/examples/matrix/matrix.gpr000066400000000000000000000004051470075373400205570ustar00rootroot00000000000000project Matrix is for Languages use ("Ada", "C", "Fortran"); for Source_Dirs use ("src"); for Object_Dir use "obj"; for Main use ("main.adb"); package Compiler is for Default_Switches ("Ada") use ("-gnat05"); end Compiler; end Matrix; gprbuild-25.0.0/examples/matrix/src/000077500000000000000000000000001470075373400173315ustar00rootroot00000000000000gprbuild-25.0.0/examples/matrix/src/initmat.c000066400000000000000000000005001470075373400211350ustar00rootroot00000000000000 /* Initialize a matrix with random values */ #include #include void initmat (float *mat, int nb_line, int nb_column) { int column, line; for (line=0; line, Integer range <>) of Float'Base; -- Root matrix type, derived below with C and Fortran convention -- C binding type C_Matrix is new Matrix (1 .. 3, 1 .. 3); pragma Convention (C, C_Matrix); procedure initmat (M : in out C_Matrix; Line, Column : C.int); pragma Import (C, initmat, "initmat"); -- Fortran binding type F_Matrix is new Matrix (1 .. 3, 1 .. 3); pragma Convention (Fortran, F_Matrix); procedure multmat (Res : out Fortran.Logical; M1 : in F_Matrix; Line1, Column1 : Fortran.Fortran_Integer; M2 : in F_Matrix; Line2, Column2 : Fortran.Fortran_Integer; M3 : out F_Matrix); pragma Import (Fortran, Multmat); pragma Import_Valued_Procedure (Multmat); -- Ada code procedure Copy (FM : in F_Matrix; AM : out Real_Matrix) is begin -- We should check the ranges here for L in FM'Range (1) loop for C in FM'Range (2) loop AM (L, C) := FM (L, C); end loop; end loop; end Copy; procedure Display (M : in Real_Matrix) is begin for L in M'Range (1) loop Text_IO.Put ("| "); for C in M'Range (2) loop Float_Text_IO.Put (M (L , C), Fore => 3, Aft => 4, Exp => 0); Text_IO.Put (", "); end loop; Text_IO.Put_Line (" |"); end loop; Text_IO.New_Line; end Display; CM1, CM2 : C_Matrix; FM1, FM2, FM3 : F_Matrix; Res : Fortran.Logical; AM1, AM2 : Real_Matrix (1 .. 3, 1 .. 3); D : Float; begin -- Initialize matrix with the C routine initmat (CM1, C.int (CM1'Length (1)), C.int (CM1'Length (2))); initmat (CM2, C.int (CM2'Length (1)), C.int (CM2'Length (2))); -- Multiply both matrix using the Fortran routine -- The following copies encure the convertion between both convention -- (line, column order being different in C/Ada and Fortran. FM1 := F_Matrix (CM1); FM2 := F_Matrix (CM2); multmat (Res, FM1, Fortran.Fortran_Integer (FM1'Length (1)), Fortran.Fortran_Integer (FM1'Length (2)), FM2, Fortran.Fortran_Integer (FM2'Length (1)), Fortran.Fortran_Integer (FM2'Length (2)), FM3); if not Res then Text_IO.Put_Line ("Dimentions are not compatible"); return; end if; -- Transpose the matrix using Ada.Numerics support. -- We need to copy the Fortran matrix into the Ada one. Copy (FM3, AM1); AM2 := AM1 / 2.0; Text_IO.Put_Line ("Matrix :"); Display (AM1); Text_IO.Put_Line ("Matrix divided by 2 :"); Display (AM2); D := Determinant (AM2); Text_IO.Put ("Corresponding determinant :"); Float_Text_IO.Put (D, Fore => 3, Aft => 7, Exp => 0); Text_IO.New_Line; end Main; gprbuild-25.0.0/examples/matrix/src/multmat.f000066400000000000000000000010051470075373400211570ustar00rootroot00000000000000 C Simple matrix multiplication in Fortran 77 LOGICAL FUNCTION MULTMAT (A, m, n, B, o, p, C) INTEGER m, n, o, p, i, j, k REAL A(m,n), B(o,p), C(m,p) REAL t IF (n .NE. o) THEN MULTMAT = .FALSE. RETURN ENDIF DO 320 i=1, m DO 310 j=1, p t = 0 DO 300 k=1, n t = t + A(i, k) * B(k, j) 300 CONTINUE C(i, j) = t 310 CONTINUE 320 CONTINUE MULTMAT = .TRUE. RETURN END gprbuild-25.0.0/examples/namings/000077500000000000000000000000001470075373400166725ustar00rootroot00000000000000gprbuild-25.0.0/examples/namings/Makefile000066400000000000000000000006661470075373400203420ustar00rootroot00000000000000all: default.cgpr gprbuild -p -Pnamings -XC1=case1 $(GPRBUILDFLAGS) gprbuild -p -Pnamings -XC1=case2 $(GPRBUILDFLAGS) gprbuild -p -Pnamings -XC1=case3 $(GPRBUILDFLAGS) default.cgpr: gprconfig --batch --config Ada --config C clean: default.cgpr gprclean -Pnamings -XC1=case1 gprclean -Pnamings -XC1=case2 gprclean -Pnamings -XC1=case3 $(RM) default.cgpr run: all ./main-case1 ./main-case2 ./main-case3 .PHONY: all clean run gprbuild-25.0.0/examples/namings/_print2.ada000066400000000000000000000001561470075373400207200ustar00rootroot00000000000000--with Ada.Text_IO; use Ada.Text_IO; separate (Util) procedure Print2 is begin Put ("-case1"); end Print2; gprbuild-25.0.0/examples/namings/_print3.adb000066400000000000000000000001561470075373400207220ustar00rootroot00000000000000--with Ada.Text_IO; use Ada.Text_IO; separate (Util) procedure Print2 is begin Put ("-case2"); end Print2; gprbuild-25.0.0/examples/namings/main.adb000066400000000000000000000002711470075373400202660ustar00rootroot00000000000000with Util; procedure Main is A : aliased integer := 1; procedure C_Routine (x : in out Integer); pragma Import (C, C_Routine); begin C_Routine (A); Util.Print (A); end; gprbuild-25.0.0/examples/namings/my_routine.c1000066400000000000000000000000501470075373400213040ustar00rootroot00000000000000void c_routine (int *c) { *c = 1; }; gprbuild-25.0.0/examples/namings/my_routine2.c1000066400000000000000000000000501470075373400213660ustar00rootroot00000000000000void c_routine (int *c) { *c = 2; }; gprbuild-25.0.0/examples/namings/namings.gpr000066400000000000000000000030661470075373400210450ustar00rootroot00000000000000project Namings is for Languages use ("Ada", "C"); for main use ("main.adb"); type Choice is ("case1", "case2", "case3"); C1 : Choice := External ("C1", "case1"); for Exec_Dir use "."; -- Construct object dir and main executable names based on scenario for Object_Dir use "obj-" & C1; package Builder is for Executable ("main.adb") use "main-" & C1; end Builder; -- Change Source dir so that in case 3, we look for main -- in an alternate source dir: case C1 is when "case1" => for Source_Dirs use ("."); when "case2" => for Source_Dirs use ("."); when "case3" => for Source_Dirs use ("src1", "."); end case; -- We want to build with -- case1 : main.adb, util-case1.adb, my_routine.c1 -- case2 : main.adb, util-case2.adb, my_routine2.c1, _print2.adb -- case3 : src1/main.adb, util-case2.adb, my_routine2.c1, _print3.adb package Naming is -- alternate name built without a case for Body ("Util") use "util-" & C1 & ".ada"; -- alternate names built in a case case C1 is when "case1" => for Implementation_Exceptions ("C") use ("my_routine.c1"); when "case2" => for Implementation_Exceptions ("C") use ("my_routine2.c1"); for Body ("Util.Print2") use "_print2.ada"; when "case3" => for Implementation_Exceptions ("C") use ("my_routine2.c1"); for Body ("Util") use "util-case2.ada"; for Body ("Util.Print2") use "_print3.adb"; end case; end Naming; end Namings; gprbuild-25.0.0/examples/namings/src1/000077500000000000000000000000001470075373400175425ustar00rootroot00000000000000gprbuild-25.0.0/examples/namings/src1/main.adb000066400000000000000000000003561470075373400211420ustar00rootroot00000000000000with Util; with Ada.Text_IO; use Ada.TExt_IO; procedure Main is A : aliased integer := 2; procedure C_Routine (x : in out Integer); pragma Import (C, C_Routine); begin Put ("src1/"); C_Routine (A); Util.Print (A); end; gprbuild-25.0.0/examples/namings/util-case1.ada000066400000000000000000000002501470075373400213050ustar00rootroot00000000000000with Ada.Text_IO; use Ada.Text_IO; package body Util is procedure Print (X : Integer) is begin Put_Line ("case1" & X'img); end Print; end Util; gprbuild-25.0.0/examples/namings/util-case2.ada000066400000000000000000000003441470075373400213120ustar00rootroot00000000000000with Ada.Text_IO; use Ada.Text_IO; package body Util is procedure Print2 is separate; procedure Print (X : Integer) is begin Put ("case2"); Print2; Put_Line (X'img); end Print; end Util; gprbuild-25.0.0/examples/namings/util.ads000066400000000000000000000000741470075373400203410ustar00rootroot00000000000000package Util is procedure Print (X : Integer); end Util; gprbuild-25.0.0/examples/scenarios/000077500000000000000000000000001470075373400172245ustar00rootroot00000000000000gprbuild-25.0.0/examples/scenarios/Makefile000066400000000000000000000005661470075373400206730ustar00rootroot00000000000000all: default.cgpr gprbuild -p -Pmain -XLIB=static $(GPRBUILDFLAGS) gprbuild -p -Pmain -XLIB=dynamic $(GPRBUILDFLAGS) default.cgpr: gprconfig --batch --config Ada --config C clean: default.cgpr gprclean -r -Pmain -XLIB=static gprclean -r -Pmain -XLIB=dynamic $(RM) default.cgpr run: all ./obj/main PATH="../libraries/lib2:$$PATH" obj1/main .PHONY: all clean run gprbuild-25.0.0/examples/scenarios/general_lib.gpr000066400000000000000000000015551470075373400222070ustar00rootroot00000000000000library project General_Lib is type Lib_Kind is ("static", "dynamic", "extern"); Kind : Lib_Kind := external ("LIB", "static"); Prefix := "../libraries/"; for Languages use ("Ada", "C"); for Source_Dirs use (Prefix & "lib_src"); case Kind is when "static" => for Object_Dir use Prefix & "obj"; for Library_Dir use Prefix & "lib"; for Library_Kind use "static"; for Library_Name use "l1"; when "dynamic" => for Object_Dir use Prefix & "obj2"; for Library_Dir use Prefix & "lib2"; for Library_Kind use "dynamic"; for Library_Name use "l2"; when "extern" => for Library_Dir use Prefix & "lib2"; for Library_Kind use "dynamic"; for Library_Name use "l2"; for Externally_Built use "true"; end case; end General_Lib; gprbuild-25.0.0/examples/scenarios/main.gpr000066400000000000000000000007141470075373400206640ustar00rootroot00000000000000with "general_lib.gpr"; project Main is for Languages use ("C"); for Source_dirs use ("../libraries"); for Main use ("c_main.c"); case General_Lib.Kind is when "static" => for Object_Dir use "obj"; when "dynamic" | "extern" => for Object_Dir use "obj1"; end case; for Roots ("c_main.c") use ("ada_lib"); package Builder is for Executable ("c_main.c") use "main"; end Builder; end Main; gprbuild-25.0.0/examples/subsystems/000077500000000000000000000000001470075373400174575ustar00rootroot00000000000000gprbuild-25.0.0/examples/subsystems/Makefile000066400000000000000000000004521470075373400211200ustar00rootroot00000000000000all: default.cgpr gprbuild -p -Pc_main $(GPRBUILDFLAGS) gprbuild -p -Pada_main $(GPRBUILDFLAGS) default.cgpr: gprconfig --batch --config Ada --config C clean: default.cgpr gprclean -r -Pc_main gprclean -r -Pada_main $(RM) default.cgpr run: all ./ada_main ./c_main .PHONY: all clean run gprbuild-25.0.0/examples/subsystems/ada_main.gpr000066400000000000000000000005021470075373400217170ustar00rootroot00000000000000with "attribute_sharing.gpr"; with "common_subsystem.gpr"; project Ada_Main is for Languages use ("Ada"); for Source_Dirs use ("ada_src"); for Object_Dir use "obj"; for Exec_Dir use "."; for Main use ("ada_main.adb"); package Compiler renames Attribute_Sharing.Compiler; end Ada_Main; gprbuild-25.0.0/examples/subsystems/ada_src/000077500000000000000000000000001470075373400210535ustar00rootroot00000000000000gprbuild-25.0.0/examples/subsystems/ada_src/ada_main.adb000066400000000000000000000001151470075373400232510ustar00rootroot00000000000000with C_Lib; procedure Ada_Main is begin C_Lib.Do_Something; end Ada_Main; gprbuild-25.0.0/examples/subsystems/attribute_sharing.gpr000066400000000000000000000003521470075373400237070ustar00rootroot00000000000000abstract project Attribute_Sharing is for Source_Files use (); package Compiler is for Default_Switches ("C") use ("-pedantic"); for Default_Switches ("Ada") use ("-gnaty"); end Compiler; end Attribute_Sharing; gprbuild-25.0.0/examples/subsystems/c_main.gpr000066400000000000000000000010111470075373400214100ustar00rootroot00000000000000with "attribute_sharing.gpr"; with "common_subsystem.gpr"; project C_Main is for Languages use ("C"); for Source_Dirs use ("c_src"); for Object_Dir use "obj1"; for Main use ("c_main.c"); for Roots ("c_main.c") use ("*"); for Exec_Dir use "."; package Compiler is for Default_Switches ("C") use Attribute_Sharing.Compiler'Default_Switches ("C"); for Switches ("c_main.c") use Compiler'Default_Switches ("C") & ("-g"); end Compiler; end C_Main; gprbuild-25.0.0/examples/subsystems/c_src/000077500000000000000000000000001470075373400205505ustar00rootroot00000000000000gprbuild-25.0.0/examples/subsystems/c_src/c_main.c000066400000000000000000000037031470075373400221450ustar00rootroot00000000000000/**************************************************************************** * * * GPR TECHNOLOGY * * * * Copyright (C) 1992-2021, Free Software Foundation, Inc. * * * * This library is free software; you can redistribute it and/or modify it * * under terms of the GNU General Public License as published by the Free * * Software Foundation; either version 3, or (at your option) any later * * version. This library is distributed in the hope that it will be useful, * * but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- * * TABILITY or FITNESS FOR A PARTICULAR PURPOSE. * * * * As a special exception under Section 7 of GPL version 3, you are granted * * additional permissions described in the GCC Runtime Library Exception, * * version 3.1, as published by the Free Software Foundation. * * * * You should have received a copy of the GNU General Public License and * * a copy of the GCC Runtime Library Exception along with this program; * * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * * . * * * ****************************************************************************/ #include extern void adainit (void); extern void adafinal (void); extern void do_it_in_ada(void); int main (void) { adainit(); do_it_in_ada (); adafinal(); exit (0); } gprbuild-25.0.0/examples/subsystems/common_subsystem.gpr000066400000000000000000000003711470075373400236000ustar00rootroot00000000000000with "attribute_sharing.gpr"; project Common_Subsystem is for Languages use ("Ada", "C"); for Source_Dirs use ("util_src"); for Object_Dir use "obj_util"; package Compiler renames Attribute_Sharing.Compiler; end Common_Subsystem; gprbuild-25.0.0/examples/subsystems/util_src/000077500000000000000000000000001470075373400213035ustar00rootroot00000000000000gprbuild-25.0.0/examples/subsystems/util_src/ada_lib.adb000066400000000000000000000002431470075373400233250ustar00rootroot00000000000000with Ada.Text_IO; use Ada.Text_IO; package body Ada_Lib is procedure Do_It_In_Ada is begin Put_Line ("Done in Ada"); end Do_It_In_Ada; end Ada_Lib; gprbuild-25.0.0/examples/subsystems/util_src/ada_lib.ads000066400000000000000000000001371470075373400233500ustar00rootroot00000000000000package Ada_Lib is procedure Do_It_In_Ada; pragma Export (C, Do_It_In_Ada); end Ada_Lib; gprbuild-25.0.0/examples/subsystems/util_src/c_lib.ads000066400000000000000000000001341470075373400230420ustar00rootroot00000000000000package C_Lib is procedure Do_Something; pragma Import (C, Do_Something); end C_Lib; gprbuild-25.0.0/examples/subsystems/util_src/lib.c000066400000000000000000000001521470075373400222130ustar00rootroot00000000000000#include #include "lib.h" void do_something (void) { printf ("Doing something in C \n"); } gprbuild-25.0.0/examples/subsystems/util_src/lib.h000066400000000000000000000000421470075373400222160ustar00rootroot00000000000000extern void do_something (void); gprbuild-25.0.0/gpr/000077500000000000000000000000001470075373400142105ustar00rootroot00000000000000gprbuild-25.0.0/gpr/debug.adc000066400000000000000000000000331470075373400157430ustar00rootroot00000000000000pragma Initialize_Scalars; gprbuild-25.0.0/gpr/gpr.gpr000066400000000000000000000071271470075373400155210ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2004-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ with "xmlada"; library project GPR is for languages use ("Ada", "C"); type Build_Type is ("debug", "production", "coverage", "profiling"); Bld : Build_Type := external ("GPR_BUILD", external ("BUILD", "production")); type Target_type is ("Windows_NT", "UNIX"); Target : Target_Type := external ("OS", "UNIX"); type Library_Type_Type is ("relocatable", "static", "static-pic"); Gnat_Lib_Type : Library_Type_Type := external ("GPR_LIBRARY_TYPE", external ("LIBRARY_TYPE", "static")); Root_Obj_Dir := external ("OBJDIR", "."); for Library_Kind use Gnat_Lib_Type; for Source_Dirs use ("src"); for Library_Name use "gpr"; for Object_Dir use "libobj/" & Bld & "/" & Gnat_Lib_Type; for Library_Dir use "lib/" & Bld & "/" & Gnat_Lib_Type; -------------- -- Compiler -- -------------- package Compiler is Common_Switches := ("-gnat2020", "-gnaty", "-gnatQ", "-gnata"); case Bld is when "debug" => for Default_Switches ("Ada") use Common_Switches & ("-g", "-gnata", "-gnatVa", "-gnatwaCJI", "-gnatwe", "-gnatyg", "-fstack-check"); for Local_Configuration_Pragmas use "debug.adc"; when "coverage" => for Default_Switches ("Ada") use Common_Switches & ("-ftest-coverage", "-fprofile-arcs"); when "profiling" => for Default_Switches ("Ada") use Common_Switches & ("-pg", "-g"); when "production" => for Default_Switches ("Ada") use Common_Switches & ("-O2", "-gnatn", "-gnatws"); -- Compile all Ada sources to support symbolic-traceback for Switches ("gpr*.ad?") use Compiler'Default_Switches ("Ada") & ("-g1"); end case; end Compiler; ------------ -- Naming -- ------------ package Naming is case Target is when "Windows_NT" => for Body ("GPR.Util.Put_Resource_Usage") use "gpr-util-put_resource_usage__null.adb"; for Body ("GPR.Jobserver") use "gpr-jobserver__win.adb"; when "UNIX" => for Body ("GPR.Util.Put_Resource_Usage") use "gpr-util-put_resource_usage__unix.adb"; end case; end Naming; end GPR; gprbuild-25.0.0/gpr/src/000077500000000000000000000000001470075373400147775ustar00rootroot00000000000000gprbuild-25.0.0/gpr/src/gpr-ali.adb000066400000000000000000001304611470075373400170070ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Strings.Fixed; use Ada.Strings.Fixed; with GPR.Names; use GPR.Names; with GPR.Output; use GPR.Output; with GPR.Opt; package body GPR.ALI is use ASCII; -- Make control characters visible -- The following array records which characters currently are used as line -- type markers in the ALI file. This is used in Scan_ALI to detect (or -- skip) invalid lines. Known_ALI_Lines : constant array (Character range 'A' .. 'Z') of Boolean := ('V' => True, -- version 'M' => True, -- main program 'A' => True, -- argument 'P' => True, -- program 'R' => True, -- restriction 'I' => True, -- interrupt 'U' => True, -- unit 'W' => True, -- with 'L' => True, -- linker option 'N' => True, -- notes 'E' => True, -- external 'D' => True, -- dependency 'X' => True, -- xref 'S' => True, -- specific dispatching 'Y' => True, -- limited_with 'Z' => True, -- implicit with from instantiation 'C' => True, -- SCO information 'F' => True, -- SPARK cross-reference information others => False); Spark_End_Marker : constant Text_Buffer := "GG EK_END_MARKER"; -------------------- -- Initialize_ALI -- -------------------- procedure Initialize_ALI is begin -- When (re)initializing ALI data structures the ALI user expects to -- get a fresh set of data structures. Thus we first need to erase the -- marks put in the name table by the previous set of ALI routine calls. -- These two loops are empty and harmless the first time in. for J in ALIs.First .. ALIs.Last loop Set_Name_Table_Int (ALIs.Table (J).Afile, 0); end loop; for J in Units.First .. Units.Last loop Set_Name_Table_Int (Units.Table (J).Uname, 0); end loop; -- Free argument table strings for J in Args.First .. Args.Last loop Free (Args.Table (J)); end loop; -- Initialize all tables ALIs.Init; -- No_Deps.Init; Units.Init; Withs.Init; Sdep.Init; -- Linker_Options.Init; -- Notes.Init; -- Xref_Section.Init; -- Xref_Entity.Init; -- Xref.Init; -- Version_Ref.Reset; -- Add dummy zero'th item in Linker_Options and Notes for sort calls -- Linker_Options.Increment_Last; -- Notes.Increment_Last; -- Initialize global variables recording cumulative options in all -- ALI files that are read for a given processing run in gnatbind. end Initialize_ALI; -------------- -- Scan_ALI -- -------------- function Scan_ALI (F : File_Name_Type; T : Text_Buffer_Ptr; Ignore_ED : Boolean; Err : Boolean; Read_Lines : String; Object_Path : File_Name_Type := No_File) return ALI_Id is P : Text_Ptr := T'First; Line : Line_Number := 1; Id : ALI_Id; C : Character; First_Arg : Arg_Id; First_P : Text_Ptr := T'First; Last_P : Text_Ptr := T'First; Ignore : array (Character range 'A' .. 'Z') of Boolean; -- Ignore (X) is set to True if lines starting with X are to -- be ignored by Scan_ALI and skipped, and False if the lines -- are to be read and processed. function At_Eol return Boolean; -- Test if at end of line function At_End_Of_Field return Boolean; -- Test if at end of line, or if at blank or horizontal tab procedure Check_At_End_Of_Field; -- Check if we are at end of field, fatal error if not procedure Checkc (C : Character); -- Check next character is C. If so bump past it, if not fatal error procedure Check_Unknown_Line; -- If Ignore_Errors mode, then checks C to make sure that it is not -- an unknown ALI line type characters, and if so, skips lines -- until the first character of the line is one of these characters, -- at which point it does a Getc to put that character in C. The -- call has no effect if C is already an appropriate character. -- If not in Ignore_Errors mode, a fatal error is signalled if the -- line is unknown. Note that if C is an EOL on entry, the line is -- skipped (it is assumed that blank lines are never significant). -- If C is EOF on entry, the call has no effect (it is assumed that -- the caller will properly handle this case). function Getc return Character; -- Get next character, bumping P past the character obtained function Get_File_Name (Lower : Boolean := False; May_Be_Quoted : Boolean := False) return File_Name_Type; -- Skip blanks, then scan out a file name (name is left in Name_Buffer -- with length in Name_Len, as well as returning a File_Name_Type value. -- If May_Be_Quoted is True and the first non blank character is '"', -- then remove starting and ending quotes and undoubled internal quotes. -- If lower is false, the case is unchanged, if Lower is True then the -- result is forced to all lower case for systems where file names are -- not case sensitive. This ensures that gnatbind works correctly -- regardless of the case of the file name on all systems. The scan -- is terminated by a end of line, space or horizontal tab. Any other -- special characters are included in the returned name. function Get_Name (Ignore_Spaces : Boolean := False; Ignore_Special : Boolean := False; May_Be_Quoted : Boolean := False) return Name_Id; -- Skip blanks, then scan out a name (name is left in Name_Buffer with -- length in Name_Len, as well as being returned in Name_Id form). -- If Lower is set to True then the Name_Buffer will be converted to -- all lower case, for systems where file names are not case sensitive. -- This ensures that gnatbind works correctly regardless of the case -- of the file name on all systems. The termination condition depends -- on the settings of Ignore_Spaces and Ignore_Special: -- -- If Ignore_Spaces is False (normal case), then scan is terminated -- by the normal end of field condition (EOL, space, horizontal tab) -- -- If Ignore_Special is False (normal case), the scan is terminated by -- a typeref bracket or an equal sign except for the special case of -- an operator name starting with a double quote which is terminated -- by another double quote. -- -- If May_Be_Quoted is True and the first non blank character is '"' -- the name is 'unquoted'. In this case Ignore_Special is ignored and -- assumed to be True. -- -- It is an error to set both Ignore_Spaces and Ignore_Special to True. -- This function handles wide characters properly. function Get_Nat return Nat; -- Skip blanks, then scan out an unsigned integer value in Nat range -- raises ALI_Reading_Error if the encoutered type is not natural. function Get_Stamp return Time_Stamp_Type; -- Skip blanks, then scan out a time stamp function Get_Unit_Name return Unit_Name_Type; -- Skip blanks, then scan out a file name (name is left in Name_Buffer -- with length in Name_Len, as well as returning a Unit_Name_Type value. -- The case is unchanged and terminated by a normal end of field. function Nextc return Character; -- Return current character without modifying pointer P -- procedure Get_Typeref -- (Current_File_Num : Sdep_Id; -- Ref : out Tref_Kind; -- File_Num : out Sdep_Id; -- Line : out Nat; -- Ref_Type : out Character; -- Col : out Nat; -- Standard_Entity : out Name_Id); -- Parse the definition of a typeref (<...>, {...} or (...)) procedure Skip_Eol; -- Skip past spaces, then skip past end of line (fatal error if not -- at end of line). Also skips past any following blank lines. procedure Skip_Next_Line; -- Skip rest of current line and any following blank lines procedure Skip_Space; -- Skip past white space (blanks or horizontal tab) --------------------- -- At_End_Of_Field -- --------------------- function At_End_Of_Field return Boolean is begin return Nextc <= ' '; end At_End_Of_Field; ------------ -- At_Eol -- ------------ function At_Eol return Boolean is begin return Nextc = EOF or else Nextc = CR or else Nextc = LF; end At_Eol; --------------------------- -- Check_At_End_Of_Field -- --------------------------- procedure Check_At_End_Of_Field is begin if not At_End_Of_Field then while Nextc > ' ' loop P := P + 1; end loop; end if; end Check_At_End_Of_Field; ------------------------ -- Check_Unknown_Line -- ------------------------ procedure Check_Unknown_Line is begin while C not in 'A' .. 'Z' or else not Known_ALI_Lines (C) loop if C = CR or else C = LF then Skip_Next_Line; C := Nextc; elsif C = EOF then return; else Skip_Next_Line; C := Getc; end if; end loop; end Check_Unknown_Line; ------------ -- Checkc -- ------------ procedure Checkc (C : Character) is pragma Unreferenced (C); begin P := P + 1; end Checkc; ------------------- -- Get_File_Name -- ------------------- function Get_File_Name (Lower : Boolean := False; May_Be_Quoted : Boolean := False) return File_Name_Type is F : Name_Id; begin F := Get_Name (Ignore_Special => True, May_Be_Quoted => May_Be_Quoted); -- Convert file name to all lower case if file names are not case -- sensitive. This ensures that we handle names in the canonical -- lower case format, regardless of the actual case. if Lower and not File_Names_Case_Sensitive then Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); return Name_Find; else return File_Name_Type (F); end if; end Get_File_Name; -------------- -- Get_Name -- -------------- function Get_Name (Ignore_Spaces : Boolean := False; Ignore_Special : Boolean := False; May_Be_Quoted : Boolean := False) return Name_Id is Char : Character; begin Name_Len := 0; Skip_Space; if At_Eol then return Error_Name; end if; Char := Getc; -- Deal with quoted characters if May_Be_Quoted and then Char = '"' then loop if At_Eol then return Error_Name; end if; Char := Getc; if Char = '"' then if At_Eol then exit; else Char := Getc; if Char /= '"' then P := P - 1; exit; end if; end if; end if; Add_Char_To_Name_Buffer (Char); end loop; -- Other than case of quoted character else P := P - 1; loop Add_Char_To_Name_Buffer (Getc); exit when At_End_Of_Field and then not Ignore_Spaces; if not Ignore_Special then if Name_Buffer (1) = '"' then exit when Name_Len > 1 and then Name_Buffer (Name_Len) = '"'; else -- Terminate on parens or angle brackets or equal sign exit when Nextc = '(' or else Nextc = ')' or else Nextc = '{' or else Nextc = '}' or else Nextc = '<' or else Nextc = '>' or else Nextc = '='; -- Terminate on comma exit when Nextc = ','; -- Terminate if left bracket not part of wide char -- sequence Note that we only recognize brackets -- notation so far ??? exit when Nextc = '[' and then T (P + 1) /= '"'; -- Terminate if right bracket not part of wide char -- sequence. exit when Nextc = ']' and then T (P - 1) /= '"'; end if; end if; end loop; end if; return Name_Find; end Get_Name; ------------------- -- Get_Unit_Name -- ------------------- function Get_Unit_Name return Unit_Name_Type is begin return Unit_Name_Type (Get_Name); end Get_Unit_Name; ------------- -- Get_Nat -- ------------- function Get_Nat return Nat is V : Nat; begin Skip_Space; -- Check if we are on a number. In the case of bad ALI files, this -- may not be true. if not (Nextc in '0' .. '9') then return 0; end if; V := 0; loop V := V * 10 + (Character'Pos (Getc) - Character'Pos ('0')); exit when At_End_Of_Field; exit when Nextc < '0' or else Nextc > '9'; end loop; return V; end Get_Nat; --------------- -- Get_Stamp -- --------------- function Get_Stamp return Time_Stamp_Type is T : Time_Stamp_Type; Start : Integer; begin Skip_Space; if At_Eol then return Dummy_Time_Stamp; end if; -- Following reads old style time stamp missing first two digits if Nextc in '7' .. '9' then T (1) := '1'; T (2) := '9'; Start := 3; -- Normal case of full year in time stamp else Start := 1; end if; for J in Start .. T'Last loop T (J) := Getc; end loop; return T; end Get_Stamp; ----------------- -- Get_Typeref -- ----------------- -- procedure Get_Typeref -- (Current_File_Num : Sdep_Id; -- Ref : out Tref_Kind; -- File_Num : out Sdep_Id; -- Line : out Nat; -- Ref_Type : out Character; -- Col : out Nat; -- Standard_Entity : out Name_Id) -- is -- N : Nat; -- begin -- case Nextc is -- when '<' => Ref := Tref_Derived; -- when '(' => Ref := Tref_Access; -- when '{' => Ref := Tref_Type; -- when others => Ref := Tref_None; -- end case; -- -- -- Case of typeref field present -- -- if Ref /= Tref_None then -- P := P + 1; -- skip opening bracket -- -- if Nextc in 'a' .. 'z' then -- File_Num := No_Sdep_Id; -- Line := 0; -- Ref_Type := ' '; -- Col := 0; -- Standard_Entity := Get_Name (Ignore_Spaces => True); -- else -- N := Get_Nat; -- -- if Nextc = '|' then -- File_Num := Sdep_Id (N + Nat (First_Sdep_Entry) - 1); -- P := P + 1; -- N := Get_Nat; -- else -- File_Num := Current_File_Num; -- end if; -- -- Line := N; -- Ref_Type := Getc; -- Col := Get_Nat; -- Standard_Entity := No_Name; -- end if; -- -- -- ??? Temporary workaround for nested generics case: -- -- 4i4 Directories{1|4I9[4|6[3|3]]} -- -- See C918-002 -- -- declare -- Nested_Brackets : Natural := 0; -- -- begin -- loop -- case Nextc is -- when '[' => -- Nested_Brackets := Nested_Brackets + 1; -- when ']' => -- Nested_Brackets := Nested_Brackets - 1; -- when others => -- if Nested_Brackets = 0 then -- exit; -- end if; -- end case; -- -- Skipc; -- end loop; -- end; -- -- P := P + 1; -- skip closing bracket -- Skip_Space; -- -- -- No typeref entry present -- -- else -- File_Num := No_Sdep_Id; -- Line := 0; -- Ref_Type := ' '; -- Col := 0; -- Standard_Entity := No_Name; -- end if; -- end Get_Typeref; ---------- -- Getc -- ---------- function Getc return Character is begin if P = T'Last then return EOF; else P := P + 1; return T (P - 1); end if; end Getc; ----------- -- Nextc -- ----------- function Nextc return Character is begin return T (P); end Nextc; -------------- -- Skip_Eol -- -------------- procedure Skip_Eol is begin Skip_Space; if not At_Eol then while not At_Eol loop P := P + 1; end loop; end if; -- Loop to skip past blank lines (first time through skips this EOL) while Nextc < ' ' and then Nextc /= EOF loop if Nextc = LF then Line := Line + 1; end if; P := P + 1; end loop; end Skip_Eol; --------------- -- Skip_Next_Line -- --------------- procedure Skip_Next_Line is begin First_P := P; while not At_Eol loop P := P + 1; end loop; Last_P := P - 1; Skip_Eol; end Skip_Next_Line; ---------------- -- Skip_Space -- ---------------- procedure Skip_Space is begin while Nextc = ' ' or else Nextc = HT loop P := P + 1; end loop; end Skip_Space; -- Start of processing for Scan_ALI begin -- -- Return the ALI_Id if already in the ALIs table -- -- for J in 1 .. ALIs.Last loop -- if F = ALIs.Table (J).Afile then -- return J; -- end if; -- end loop; First_Sdep_Entry := Sdep.Last + 1; -- Acquire lines to be read Ignore := ('U' => False, others => True); for J in Read_Lines'Range loop Ignore (Read_Lines (J)) := False; end loop; -- Setup ALI Table entry with appropriate defaults ALIs.Increment_Last; Id := ALIs.Last; Set_Name_Table_Int (F, Int (Id)); ALIs.Table (Id) := (Afile => F, Compile_Errors => False, First_Sdep => No_Sdep_Id, First_Unit => No_Unit_Id, Last_Sdep => No_Sdep_Id, Last_Unit => No_Unit_Id, Locking_Policy => ' ', Main_Priority => -1, Main_CPU => -1, GNAT_Version => No_Name, Main_Program => None, No_Object => False, Normalize_Scalars => False, Ofile_Full_Name => Object_Path, Partition_Elaboration_Policy => ' ', Queuing_Policy => ' ', SAL_Interface => False, Sfile => No_File, SSO_Default => ' ', Task_Dispatching_Policy => ' ', Time_Slice_Value => -1, WC_Encoding => 'b', Unit_Exception_Table => False, Zero_Cost_Exceptions => False, Restrictions => No_Restrictions); -- Now we acquire the input lines from the ALI file. Note that the -- convention in the following code is that as we enter each section, -- C is set to contain the first character of the following line. C := Getc; Check_Unknown_Line; -- Acquire library version if C /= 'V' then -- The V line missing really indicates trouble, most likely it -- means we don't have an ALI file at all, so here we give a -- fatal error even if we are in Ignore_Errors mode. return No_ALI_Id; else Checkc (' '); Checkc ('"'); Name_Len := 0; while not At_Eol and not (Nextc = '"') loop Add_Char_To_Name_Buffer (Getc); end loop; -- Check that we exited on a closing double quote if Nextc /= '"' then return No_ALI_Id; end if; -- Check length compatibility if Name_Len > GNAT_Version_Max_Len then return No_ALI_Id; end if; -- ??? Duplicate code from: -- GPR.Nmsc.Check_Configuration. -- Process_Project_Level_Array_Attributes declare Raw : String (1 .. GNAT_Version_Max_Len); Last : constant Natural := Name_Len; Start : Natural; begin Raw (1 .. Last) := Name_Buffer (1 .. Last); Start := Index (Name_Buffer (1 .. Last), " v"); if Start /= 0 then Set_Name_Buffer (GNAT_And_Space); Add_Str_To_Name_Buffer (Raw (Start + 2 .. Last)); ALIs.Table (Id).GNAT_Version := Name_Find; end if; end; Skip_Eol; end if; C := Getc; Check_Unknown_Line; -- Acquire main program line if present if C = 'M' then Checkc (' '); Skip_Space; C := Getc; if C = 'F' then ALIs.Table (Id).Main_Program := Func; elsif C = 'P' then ALIs.Table (Id).Main_Program := Proc; end if; Skip_Next_Line; C := Getc; end if; -- Acquire argument lines First_Arg := Args.Last + 1; A_Loop : loop Check_Unknown_Line; exit A_Loop when C /= 'A'; if Ignore ('A') then Skip_Next_Line; else Checkc (' '); -- Scan out argument Name_Len := 0; while not At_Eol loop Add_Char_To_Name_Buffer (Getc); end loop; -- If -fstack-check, record that it occurred. Note that an -- additional string parameter can be specified, in the form of -- -fstack-check={no|generic|specific}. "no" means no checking, -- "generic" means force the use of old-style checking, and -- "specific" means use the best checking method. if Name_Len >= 13 and then Name_Buffer (1 .. 13) = "-fstack-check" and then Name_Buffer (1 .. Name_Len) /= "-fstack-check=no" then Stack_Check_Switch_Set := True; end if; -- Store the argument Args.Increment_Last; Args.Table (Args.Last) := new String'(Name_Buffer (1 .. Name_Len)); Skip_Eol; end if; C := Getc; end loop A_Loop; -- Acquire P line Check_Unknown_Line; while C /= 'P' loop if C = EOF then return No_ALI_Id; else Skip_Next_Line; C := Nextc; end if; end loop; Skip_Next_Line; C := Getc; Check_Unknown_Line; -- Loop to skip to first restrictions line while C /= 'R' loop if C = EOF then return No_ALI_Id; else Skip_Next_Line; C := Nextc; end if; end loop; -- Ignore all 'R' lines while C = 'R' loop Skip_Next_Line; C := Getc; end loop; -- Acquire 'I' lines if present Check_Unknown_Line; while C = 'I' loop Skip_Next_Line; C := Getc; end loop; -- Acquire 'S' lines if present Check_Unknown_Line; while C = 'S' loop Skip_Next_Line; C := Getc; end loop; -- Loop to acquire unit entries U_Loop : loop Check_Unknown_Line; exit U_Loop when C /= 'U'; -- Note: as per spec, we never ignore U lines Checkc (' '); Skip_Space; Units.Increment_Last; if ALIs.Table (Id).First_Unit = No_Unit_Id then ALIs.Table (Id).First_Unit := Units.Last; end if; declare UL : Unit_Record renames Units.Table (Units.Last); begin UL.Uname := Get_Unit_Name; UL.Predefined := False; UL.My_ALI := Id; UL.Sfile := Get_File_Name (Lower => True); UL.Pure := False; UL.Preelab := False; UL.No_Elab := False; UL.Shared_Passive := False; UL.RCI := False; UL.Remote_Types := False; UL.Serious_Errors := False; UL.Has_RACW := False; UL.Init_Scalars := False; UL.Is_Generic := False; UL.Icasing := Mixed_Case; UL.Kcasing := All_Lower_Case; UL.Dynamic_Elab := False; UL.Elaborate_Body := False; UL.Set_Elab_Entity := False; UL.Version := "00000000"; UL.First_With := Withs.Last + 1; UL.First_Arg := First_Arg; UL.Elab_Position := 0; UL.SAL_Interface := ALIs.Table (Id).SAL_Interface; UL.Directly_Scanned := False; UL.Body_Needed_For_SAL := False; UL.Elaborate_Body_Desirable := False; UL.Optimize_Alignment := 'O'; UL.Has_Finalizer := False; end; -- Check for duplicated unit in different files declare Info : constant Int := Get_Name_Table_Int (Units.Table (Units.Last).Uname); begin if Info /= 0 and then Units.Table (Units.Last).Sfile /= Units.Table (Unit_Id (Info)).Sfile then -- If Err is set then ignore duplicate unit name if Err then null; -- If Err is not set, then this is a fatal error. This is -- the case of being called from the binder, where we must -- definitely diagnose this as an error. else Set_Standard_Error; Write_Str ("error: duplicate unit name: "); Write_Eol; Write_Str ("error: unit """); Write_Unit_Name (Units.Table (Units.Last).Uname); Write_Str (""" found in file """); Write_Name (Units.Table (Units.Last).Sfile); Write_Char ('"'); Write_Eol; Write_Str ("error: unit """); Write_Unit_Name (Units.Table (Unit_Id (Info)).Uname); Write_Str (""" found in file """); Write_Name (Units.Table (Unit_Id (Info)).Sfile); Write_Char ('"'); Write_Eol; Set_Standard_Output; return No_ALI_Id; end if; end if; end; Set_Name_Table_Int (Units.Table (Units.Last).Uname, Int (Units.Last)); -- Scan out possible version and other parameters loop Skip_Space; exit when At_Eol; C := Getc; -- Version field if C in '0' .. '9' or else C in 'a' .. 'f' then Units.Table (Units.Last).Version (1) := C; for J in 2 .. 8 loop C := Getc; Units.Table (Units.Last).Version (J) := C; end loop; -- BD/BN parameters elsif C = 'B' then C := Getc; if C = 'D' then Check_At_End_Of_Field; Units.Table (Units.Last).Elaborate_Body_Desirable := True; elsif C = 'N' then Check_At_End_Of_Field; Units.Table (Units.Last).Body_Needed_For_SAL := True; end if; -- DE parameter (Dynamic elaboration checks) elsif C = 'D' then C := Getc; if C = 'E' then Check_At_End_Of_Field; Units.Table (Units.Last).Dynamic_Elab := True; end if; -- EB/EE parameters elsif C = 'E' then C := Getc; if C = 'B' then Units.Table (Units.Last).Elaborate_Body := True; elsif C = 'E' then Units.Table (Units.Last).Set_Elab_Entity := True; end if; Check_At_End_Of_Field; -- GE parameter (generic) elsif C = 'G' then C := Getc; if C = 'E' then Check_At_End_Of_Field; Units.Table (Units.Last).Is_Generic := True; end if; -- IL/IS/IU parameters elsif C = 'I' then C := Getc; if C = 'L' then Units.Table (Units.Last).Icasing := All_Lower_Case; elsif C = 'S' then Units.Table (Units.Last).Init_Scalars := True; elsif C = 'U' then Units.Table (Units.Last).Icasing := All_Upper_Case; end if; Check_At_End_Of_Field; -- KM/KU parameters elsif C = 'K' then C := Getc; if C = 'M' then Units.Table (Units.Last).Kcasing := Mixed_Case; elsif C = 'U' then Units.Table (Units.Last).Kcasing := All_Upper_Case; end if; Check_At_End_Of_Field; -- NE parameter elsif C = 'N' then C := Getc; if C = 'E' then Units.Table (Units.Last).No_Elab := True; Check_At_End_Of_Field; end if; -- PF/PR/PU/PK parameters elsif C = 'P' then C := Getc; if C = 'F' then Units.Table (Units.Last).Has_Finalizer := True; elsif C = 'R' then Units.Table (Units.Last).Preelab := True; elsif C = 'U' then Units.Table (Units.Last).Pure := True; elsif C = 'K' then Units.Table (Units.Last).Unit_Kind := 'p'; end if; Check_At_End_Of_Field; -- OL/OO/OS/OT parameters elsif C = 'O' then C := Getc; if C = 'L' or else C = 'O' or else C = 'S' or else C = 'T' then Units.Table (Units.Last).Optimize_Alignment := C; end if; Check_At_End_Of_Field; -- RC/RT parameters elsif C = 'R' then C := Getc; if C = 'C' then Units.Table (Units.Last).RCI := True; elsif C = 'T' then Units.Table (Units.Last).Remote_Types := True; elsif C = 'A' then Units.Table (Units.Last).Has_RACW := True; end if; Check_At_End_Of_Field; -- SE/SP/SU parameters elsif C = 'S' then C := Getc; if C = 'E' then Units.Table (Units.Last).Serious_Errors := True; elsif C = 'P' then Units.Table (Units.Last).Shared_Passive := True; elsif C = 'U' then Units.Table (Units.Last).Unit_Kind := 's'; end if; Check_At_End_Of_Field; else C := Getc; end if; end loop; Skip_Eol; C := Getc; -- Scan out With lines for this unit With_Loop : loop Check_Unknown_Line; exit With_Loop when C /= 'W' and then C /= 'Y' and then C /= 'Z'; if Ignore ('W') then Skip_Next_Line; else Checkc (' '); Skip_Space; Withs.Increment_Last; Withs.Table (Withs.Last).Uname := Get_Unit_Name; Withs.Table (Withs.Last).Elaborate := False; Withs.Table (Withs.Last).Elaborate_All := False; Withs.Table (Withs.Last).Elab_Desirable := False; Withs.Table (Withs.Last).Elab_All_Desirable := False; Withs.Table (Withs.Last).SAL_Interface := False; Withs.Table (Withs.Last).Limited_With := (C = 'Y'); Withs.Table (Withs.Last).Implicit_With_From_Instantiation := (C = 'Z'); -- Generic case with no object file available if At_Eol then Withs.Table (Withs.Last).Sfile := No_File; Withs.Table (Withs.Last).Afile := No_File; -- Normal case else Withs.Table (Withs.Last).Sfile := Get_File_Name (Lower => True); Withs.Table (Withs.Last).Afile := Get_File_Name (Lower => True); -- Scan out possible E, EA, ED, and AD parameters while not At_Eol loop Skip_Space; if Nextc = 'A' then P := P + 1; Checkc ('D'); Check_At_End_Of_Field; -- Store AD indication unless ignore required if not Ignore_ED then Withs.Table (Withs.Last).Elab_All_Desirable := True; end if; elsif Nextc = 'E' then P := P + 1; if At_End_Of_Field then Withs.Table (Withs.Last).Elaborate := True; elsif Nextc = 'A' then P := P + 1; Check_At_End_Of_Field; Withs.Table (Withs.Last).Elaborate_All := True; else Checkc ('D'); Check_At_End_Of_Field; -- Store ED indication unless ignore required if not Ignore_ED then Withs.Table (Withs.Last).Elab_Desirable := True; end if; end if; else return No_ALI_Id; end if; end loop; end if; Skip_Eol; end if; C := Getc; end loop With_Loop; Units.Table (Units.Last).Last_With := Withs.Last; Units.Table (Units.Last).Last_Arg := Args.Last; -- Ignore linker options lines Name_Len := 0; Linker_Options_Loop : loop Check_Unknown_Line; exit Linker_Options_Loop when C /= 'L'; Skip_Next_Line; C := Getc; end loop Linker_Options_Loop; -- Ignore notes lines Notes_Loop : loop Check_Unknown_Line; exit Notes_Loop when C /= 'N'; Skip_Next_Line; C := Getc; end loop Notes_Loop; end loop U_Loop; -- End loop through units for one ALI file ALIs.Table (Id).Last_Unit := Units.Last; ALIs.Table (Id).Sfile := Units.Table (ALIs.Table (Id).First_Unit).Sfile; -- Set types of the units (there can be at most 2 of them) if ALIs.Table (Id).First_Unit /= ALIs.Table (Id).Last_Unit then Units.Table (ALIs.Table (Id).First_Unit).Utype := Is_Body; Units.Table (ALIs.Table (Id).Last_Unit).Utype := Is_Spec; else -- Deal with body only and spec only cases, note that the reason we -- do our own checking of the name (rather than using Is_Body_Name) -- is that Uname drags in far too much compiler junk. Get_Name_String (Units.Table (Units.Last).Uname); if Name_Buffer (Name_Len) = 'b' then Units.Table (Units.Last).Utype := Is_Body_Only; else Units.Table (Units.Last).Utype := Is_Spec_Only; end if; end if; -- Ignore external version lines E_Loop : loop Check_Unknown_Line; exit E_Loop when C /= 'E'; Skip_Next_Line; C := Getc; end loop E_Loop; -- Scan out source dependency lines for this ALI file ALIs.Table (Id).First_Sdep := Sdep.Last + 1; D_Loop : loop Check_Unknown_Line; exit D_Loop when C /= 'D'; if Ignore ('D') then Skip_Next_Line; else Checkc (' '); Skip_Space; Sdep.Increment_Last; -- In the following call, Lower is not set to True, this is either -- a bug, or it deserves a special comment as to why this is so??? -- The file/path name may be quoted Sdep.Table (Sdep.Last).Sfile := Get_File_Name (May_Be_Quoted => True); Sdep.Table (Sdep.Last).Stamp := Get_Stamp; Sdep.Table (Sdep.Last).Dummy_Entry := (Sdep.Table (Sdep.Last).Stamp = Dummy_Time_Stamp); -- Acquire checksum value Skip_Space; declare Ctr : Natural; Chk : Word; begin Ctr := 0; Chk := 0; loop exit when At_Eol or else Ctr = 8; if Nextc in '0' .. '9' then Chk := Chk * 16 + Character'Pos (Nextc) - Character'Pos ('0'); elsif Nextc in 'a' .. 'f' then Chk := Chk * 16 + Character'Pos (Nextc) - Character'Pos ('a') + 10; else exit; end if; Ctr := Ctr + 1; P := P + 1; end loop; if Ctr = 8 and then At_End_Of_Field then Sdep.Table (Sdep.Last).Checksum := Chk; else return No_ALI_Id; end if; end; -- Acquire (sub)unit and reference file name entries Sdep.Table (Sdep.Last).Subunit_Name := No_Name; Sdep.Table (Sdep.Last).Unit_Name := No_Name; Sdep.Table (Sdep.Last).Rfile := Sdep.Table (Sdep.Last).Sfile; Sdep.Table (Sdep.Last).Start_Line := 1; if not At_Eol then Skip_Space; -- Here for (sub)unit name if Nextc not in '0' .. '9' then Name_Len := 0; while not At_End_Of_Field loop Add_Char_To_Name_Buffer (Getc); end loop; -- Set the (sub)unit name. Note that we use Name_Find rather -- than Name_Enter here as the subunit name may already -- have been put in the name table by the Project Manager. if Name_Len <= 2 or else Name_Buffer (Name_Len - 1) /= '%' then Sdep.Table (Sdep.Last).Subunit_Name := Name_Find; else Name_Len := Name_Len - 2; Sdep.Table (Sdep.Last).Unit_Name := Name_Find; end if; Skip_Space; end if; -- Here for reference file name entry if Nextc in '0' .. '9' then Sdep.Table (Sdep.Last).Start_Line := Get_Nat; Checkc (':'); Name_Len := 0; while not At_End_Of_Field loop Add_Char_To_Name_Buffer (Getc); end loop; Sdep.Table (Sdep.Last).Rfile := File_Name_Type (Name_Enter); end if; end if; Skip_Eol; end if; C := Getc; end loop D_Loop; ALIs.Table (Id).Last_Sdep := Sdep.Last; -- We must at this stage be at an Xref line or the end of file if C = EOF then -- Check that gnatprove generated .ali files ended with right marker if Opt.GnatProve_Mode and then T (First_P .. Last_P) /= Spark_End_Marker then return No_ALI_Id; end if; return Id; end if; Check_Unknown_Line; if C /= 'X' then return No_ALI_Id; end if; if Opt.GnatProve_Mode then -- Check that gnatprove generated .ali files ended with right marker while P < T'Last loop Skip_Next_Line; end loop; if T (First_P .. Last_P) /= Spark_End_Marker then return No_ALI_Id; end if; end if; return Id; exception when others => return No_ALI_Id; end Scan_ALI; end GPR.ALI; gprbuild-25.0.0/gpr/src/gpr-ali.ads000066400000000000000000000540631470075373400170330ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package defines the internal data structures used for representation -- of Ada Library Information (ALI) acquired from the ALI files generated by -- the front end. with System.Rident; with GNAT.Table; with GPR.Osint; use GPR.Osint; package GPR.ALI is package Rident is new System.Rident; use Rident; -------------- -- Id Types -- -------------- -- The various entries are stored in tables with distinct subscript ranges. -- The following type definitions show the ranges used for the subscripts -- (Id values) for the various tables. type ALI_Id is range 0 .. 99_999_999; -- Id values used for ALIs table entries type Unit_Id is range 0 .. 99_999_999; -- Id values used for Unit table entries type With_Id is range 0 .. 99_999_999; -- Id values used for Withs table entries type Arg_Id is range 0 .. 99_999_999; -- Id values used for argument table entries type Sdep_Id is range 0 .. 99_999_999; -- Id values used for Sdep table entries -------------------- -- ALI File Table -- -------------------- -- Each ALI file read generates an entry in the ALIs table No_ALI_Id : constant ALI_Id := ALI_Id'First; -- Special value indicating no ALI entry First_ALI_Entry : constant ALI_Id := No_ALI_Id + 1; -- Id of first actual entry in table GNAT_Version_Max_Len : constant Natural := 32; -- "Safe" length for GNAT Version type Main_Program_Type is (None, Proc, Func); -- Indicator of whether unit can be used as main program type ALIs_Record is record Afile : File_Name_Type; -- Name of ALI file Ofile_Full_Name : File_Name_Type; -- Full name of object file corresponding to the ALI file Sfile : File_Name_Type; -- Name of source file that generates this ALI file (which is equal -- to the name of the source file in the first unit table entry for -- this ALI file, since the body if present is always first). SAL_Interface : Boolean; -- Set True when this is an interface to a standalone library First_Unit : Unit_Id; -- Id of first Unit table entry for this file Last_Unit : Unit_Id; -- Id of last Unit table entry for this file First_Sdep : Sdep_Id; -- Id of first Sdep table entry for this file Last_Sdep : Sdep_Id; -- Id of last Sdep table entry for this file GNAT_Version : Name_Id; -- GNAT version used to generate this file (first line in ALI) Main_Program : Main_Program_Type; -- Indicator of whether first unit can be used as main program. Not set -- if 'M' appears in Ignore_Lines. Main_Priority : Int; -- Indicates priority value if Main_Program field indicates that this -- can be a main program. A value of -1 (No_Main_Priority) indicates -- that no parameter was found, or no M line was present. Not set if -- 'M' appears in Ignore_Lines. Main_CPU : Int; -- Indicates processor if Main_Program field indicates that this can -- be a main program. A value of -1 (No_Main_CPU) indicates that no C -- parameter was found, or no M line was present. Not set if 'M' appears -- in Ignore_Lines. Time_Slice_Value : Int; -- Indicates value of time slice parameter from T=xxx on main program -- line. A value of -1 indicates that no T=xxx parameter was found, or -- no M line was present. Not set if 'M' appears in Ignore_Lines. WC_Encoding : Character; -- Wide character encoding if main procedure. Otherwise not relevant. -- Not set if 'M' appears in Ignore_Lines. Locking_Policy : Character; -- Indicates locking policy for units in this file. Space means tasking -- was not used, or that no Locking_Policy pragma was present or that -- this is a language defined unit. Otherwise set to first character -- (upper case) of policy name. Not set if 'P' appears in Ignore_Lines. Partition_Elaboration_Policy : Character; -- Indicates partition elaboration policy for units in this file. Space -- means that no Partition_Elaboration_Policy pragma was present or that -- this is a language defined unit. Otherwise set to first character -- (upper case) of policy name. Not set if 'P' appears in Ignore_Lines. Queuing_Policy : Character; -- Indicates queuing policy for units in this file. Space means tasking -- was not used, or that no Queuing_Policy pragma was present or that -- this is a language defined unit. Otherwise set to first character -- (upper case) of policy name. Not set if 'P' appears in Ignore_Lines. Task_Dispatching_Policy : Character; -- Indicates task dispatching policy for units in this file. Space means -- tasking was not used, or that no Task_Dispatching_Policy pragma was -- present or that this is a language defined unit. Otherwise set to -- first character (upper case) of policy name. Not set if 'P' appears -- in Ignore_Lines. Compile_Errors : Boolean; -- Set to True if compile errors for unit. Note that No_Object will -- always be set as well in this case. Not set if 'P' appears in -- Ignore_Lines. No_Object : Boolean; -- Set to True if no object file generated. Not set if 'P' appears in -- Ignore_Lines. Normalize_Scalars : Boolean; -- Set to True if file was compiled with Normalize_Scalars. Not set if -- 'P' appears in Ignore_Lines. SSO_Default : Character; -- Set to 'H' or 'L' if file was compiled with a configuration pragma -- file containing Default_Scalar_Storage_Order (High/Low_Order_First). -- Set to ' ' if neither pragma was present. Not set if 'P' appears in -- Ignore_Lines. Unit_Exception_Table : Boolean; -- Set to True if unit exception table pointer generated. Not set if 'P' -- appears in Ignore_Lines. Zero_Cost_Exceptions : Boolean; -- Set to True if file was compiled with zero cost exceptions. Not set -- if 'P' appears in Ignore_Lines. Restrictions : Restrictions_Info; -- Restrictions information reconstructed from R lines end record; No_Main_Priority : constant Int := -1; -- Code for no main priority set No_Main_CPU : constant Int := -1; -- Code for no main cpu set package ALIs is new GNAT.Table ( Table_Component_Type => ALIs_Record, Table_Index_Type => ALI_Id, Table_Low_Bound => First_ALI_Entry, Table_Initial => 500, Table_Increment => 200); ---------------- -- Unit Table -- ---------------- -- Each unit within an ALI file generates an entry in the unit table No_Unit_Id : constant Unit_Id := Unit_Id'First; -- Special value indicating no unit table entry First_Unit_Entry : constant Unit_Id := No_Unit_Id + 1; -- Id of first actual entry in table type Unit_Type is (Is_Spec, Is_Body, Is_Spec_Only, Is_Body_Only); -- Indicates type of entry, if both body and spec appear in the ALI file, -- then the first unit is marked Is_Body, and the second is marked Is_Spec. -- If only a spec appears, then it is marked as Is_Spec_Only, and if only -- a body appears, then it is marked Is_Body_Only). subtype Version_String is String (1 .. 8); -- Version string, taken from unit record type Unit_Record is record My_ALI : ALI_Id; -- Corresponding ALI entry Uname : Unit_Name_Type; -- Name of Unit Sfile : File_Name_Type; -- Name of source file Preelab : Boolean; -- Indicates presence of PR parameter for a preelaborated package No_Elab : Boolean; -- Indicates presence of NE parameter for a unit that has does not -- have an elaboration routine (since it has no elaboration code). Pure : Boolean; -- Indicates presence of PU parameter for a package having pragma Pure Dynamic_Elab : Boolean; -- Set to True if the unit was compiled with dynamic elaboration checks -- (i.e. either -gnatE or pragma Elaboration_Checks (RM) was used to -- compile the unit). Elaborate_Body : Boolean; -- Indicates presence of EB parameter for a package which has a pragma -- Elaborate_Body, and also for generic package instantiations. Set_Elab_Entity : Boolean; -- Indicates presence of EE parameter for a unit which has an -- elaboration entity which must be set true as part of the -- elaboration of the unit. Has_RACW : Boolean; -- Indicates presence of RA parameter for a package that declares at -- least one Remote Access to Class_Wide (RACW) object. Remote_Types : Boolean; -- Indicates presence of RT parameter for a package which has a -- pragma Remote_Types. Serious_Errors : Boolean; -- Indicates presence of SE parameter indicating that compilation of -- the unit encountered as serious error. Shared_Passive : Boolean; -- Indicates presence of SP parameter for a package which has a pragma -- Shared_Passive. RCI : Boolean; -- Indicates presence of RC parameter for a package which has a pragma -- Remote_Call_Interface. Predefined : Boolean; -- Indicates if unit is language predefined (or a child of such a unit) First_With : With_Id; -- Id of first withs table entry for this file Last_With : With_Id; -- Id of last withs table entry for this file First_Arg : Arg_Id; -- Id of first args table entry for this file Last_Arg : Arg_Id; -- Id of last args table entry for this file Utype : Unit_Type; -- Type of entry Is_Generic : Boolean; -- True for generic unit (i.e. a generic declaration, or a generic -- body). False for a non-generic unit. Unit_Kind : Character; -- Indicates the nature of the unit. 'p' for Packages and 's' for -- subprograms. Version : Version_String; -- Version of unit Icasing : Casing_Type; -- Indicates casing of identifiers in source file for this unit. This -- is used for informational output, and also for constructing the main -- unit if it is being built in Ada. Kcasing : Casing_Type; -- Indicates casing of keywords in source file for this unit. This is -- used for informational output, and also for constructing the main -- unit if it is being built in Ada. Elab_Position : aliased Natural; -- Initialized to zero. Set non-zero when a unit is chosen and -- placed in the elaboration order. The value represents the -- ordinal position in the elaboration order. Init_Scalars : Boolean; -- Set True if IS qualifier appears in ALI file, indicating that -- an Initialize_Scalars pragma applies to the unit. SAL_Interface : Boolean; -- Set True when this is an interface to a standalone library Directly_Scanned : Boolean; -- True iff it is a unit from an ALI file specified to gnatbind Body_Needed_For_SAL : Boolean; -- Indicates that the source for the body of the unit (subprogram, -- package, or generic unit) must be included in a standalone library. Elaborate_Body_Desirable : Boolean; -- Indicates that the front end elaboration circuitry decided that it -- would be a good idea if this package had Elaborate_Body. The binder -- will attempt, but does not promise, to place the elaboration call -- for the body right after the call for the spec, or at least as close -- together as possible. Optimize_Alignment : Character; -- Optimize_Alignment setting. Set to L/S/T/O for OL/OS/OT/OO present Has_Finalizer : Boolean; -- Indicates whether a package body or a spec has a library-level -- finalization routine. end record; package Units is new GNAT.Table ( Table_Component_Type => Unit_Record, Table_Index_Type => Unit_Id, Table_Low_Bound => First_Unit_Entry, Table_Initial => 100, Table_Increment => 200); Stack_Check_Switch_Set : Boolean := False; -- Set to True if at least one ALI file contains '-fstack-check' in its -- argument list. ----------------- -- Withs Table -- ----------------- -- Each With line (W line) in an ALI file generates a Withs table entry -- Note: there will be no entries in this table if 'W' lines are ignored No_With_Id : constant With_Id := With_Id'First; -- Special value indicating no withs table entry First_With_Entry : constant With_Id := No_With_Id + 1; -- Id of first actual entry in table type With_Record is record Uname : Unit_Name_Type; -- Name of Unit Sfile : File_Name_Type; -- Name of source file, set to No_File in generic case Afile : File_Name_Type; -- Name of ALI file, set to No_File in generic case Elaborate : Boolean; -- Indicates presence of E parameter Elaborate_All : Boolean; -- Indicates presence of EA parameter Elab_All_Desirable : Boolean; -- Indicates presence of AD parameter Elab_Desirable : Boolean; -- Indicates presence of ED parameter SAL_Interface : Boolean := False; -- True if the Unit is an Interface of a Stand-Alone Library Limited_With : Boolean := False; -- True if unit is named in a limited_with_clause Implicit_With_From_Instantiation : Boolean := False; -- True if this is an implicit with from a generic instantiation end record; package Withs is new GNAT.Table ( Table_Component_Type => With_Record, Table_Index_Type => With_Id, Table_Low_Bound => First_With_Entry, Table_Initial => 5000, Table_Increment => 200); --------------------- -- Arguments Table -- --------------------- -- Each Arg line (A line) in an ALI file generates an Args table entry -- Note: there will be no entries in this table if 'A' lines are ignored No_Arg_Id : constant Arg_Id := Arg_Id'First; -- Special value indicating no args table entry First_Arg_Entry : constant Arg_Id := No_Arg_Id + 1; -- Id of first actual entry in table package Args is new GNAT.Table ( Table_Component_Type => String_Access, Table_Index_Type => Arg_Id, Table_Low_Bound => First_Arg_Entry, Table_Initial => 1000, Table_Increment => 100); ------------------------------------ -- Sdep (Source Dependency) Table -- ------------------------------------ -- Each source dependency (D line) in an ALI file generates an entry in the -- Sdep table. -- Note: there will be no entries in this table if 'D' lines are ignored No_Sdep_Id : constant Sdep_Id := Sdep_Id'First; -- Special value indicating no Sdep table entry First_Sdep_Entry : Sdep_Id := No_Sdep_Id + 1; -- Id of first Sdep entry for current ali file. This is initialized to the -- first Sdep entry in the table, and then incremented appropriately as -- successive ALI files are scanned. type Sdep_Record is record Sfile : File_Name_Type; -- Name of source file Stamp : Time_Stamp_Type; -- Time stamp value. Note that this will be all zero characters for the -- dummy entries for missing or non-dependent files. Checksum : Word; -- Checksum value. Note that this will be all zero characters for the -- dummy entries for missing or non-dependent files Dummy_Entry : Boolean; -- Set True for dummy entries that correspond to missing files or files -- where no dependency relationship exists. Subunit_Name : Name_Id; -- Name_Id for subunit name if present, else No_Name Unit_Name : Name_Id; -- Name_Id for the unit name if not a subunit (No_Name for a subunit) Rfile : File_Name_Type; -- Reference file name. Same as Sfile unless a Source_Reference pragma -- was used, in which case it reflects the name used in the pragma. Start_Line : Nat; -- Starting line number in file. Always 1, unless a Source_Reference -- pragma was used, in which case it reflects the line number value -- given in the pragma. end record; package Sdep is new GNAT.Table ( Table_Component_Type => Sdep_Record, Table_Index_Type => Sdep_Id, Table_Low_Bound => First_Sdep_Entry, Table_Initial => 5000, Table_Increment => 200); ---------------------------- -- Use of Name Table Info -- ---------------------------- -- All unit names and file names are entered into the Names table. The Info -- fields of these entries are used as follows: -- Unit name Info field has Unit_Id of unit table entry -- ALI file name Info field has ALI_Id of ALI table entry -- Source file name Info field has Source_Id of source table entry -------------------------------------- -- Subprograms for Reading ALI File -- -------------------------------------- procedure Initialize_ALI; -- Initialize the ALI tables. Also resets all switch values to defaults function Scan_ALI (F : File_Name_Type; T : Text_Buffer_Ptr; Ignore_ED : Boolean; Err : Boolean; Read_Lines : String; Object_Path : File_Name_Type := No_File) return ALI_Id; -- Given the text, T, of an ALI file, F, scan and store the information -- from the file, and return the Id of the resulting entry in the ALI -- table. Switch settings may be modified as described above in the -- switch description settings. -- -- Ignore_ED is normally False. If set to True, it indicates that -- all AD/ED (elaboration desirable) indications in the ALI file are -- to be ignored. This parameter is obsolete now that the -f switch -- is removed from gnatbind, and should be removed ??? -- -- Err determines the action taken on an incorrectly formatted file. -- If Err is False, then an error message is output, and the program -- is terminated. If Err is True, then no error message is output, -- and No_ALI_Id is returned. -- -- Ignore_Lines requests that Scan_ALI ignore any lines that start -- with any given key character. The default value of X causes all -- Xref lines to be ignored. The corresponding data in the ALI -- tables will not be filled in this case. It is not possible -- to ignore U (unit) lines, they are always read. -- -- Read_Lines requests that Scan_ALI process only lines that start -- with one of the given characters. The corresponding data in the -- ALI file for any characters not given in the list will not be -- set. The default value of the null string indicates that all -- lines should be read (unless Ignore_Lines is specified). U -- (unit) lines are always read regardless of the value of this -- parameter. -- -- Note: either Ignore_Lines or Read_Lines should be non-null, but not -- both. If both are provided then only the Read_Lines value is used, -- and the Ignore_Lines parameter is ignored. -- -- Read_XREF is set True to read and acquire the cross-reference -- information. If Read_XREF is set to True, then the effect is to ignore -- all lines other than U, W, D and X lines and the Ignore_Lines and -- Read_Lines parameters are ignored (i.e. the use of True for Read_XREF -- is equivalent to specifying an argument of "UWDX" for Read_Lines. -- -- Ignore_Errors is normally False. If it is set True, then Scan_ALI -- will do its best to scan through a file and extract all information -- it can, even if there are errors. In this case Err is only set if -- Scan_ALI was completely unable to process the file (e.g. it did not -- look like an ALI file at all). Ignore_Errors is intended to improve -- the downward compatibility of new compilers with old tools. -- -- Directly_Scanned is normally False. If it is set to True, then the -- units (spec and/or body) corresponding to the ALI file are marked as -- such. It is used to decide for what units gnatbind should generate -- the symbols corresponding to 'Version or 'Body_Version in -- Stand-Alone Libraries. end GPR.ALI; gprbuild-25.0.0/gpr/src/gpr-attr-pm.adb000066400000000000000000000073211470075373400176240ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2004-2021, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ package body GPR.Attr.PM is Last_Known_Package : Pkg_Node_Id := Empty_Pkg; ------------------- -- Add_Attribute -- ------------------- procedure Add_Attribute (To_Package : Package_Node_Id; Attribute_Name : Name_Id; Attribute_Node : out Attribute_Node_Id) is begin -- Only add attribute if package is already defined and is not unknown if To_Package not in Empty_Package | Unknown_Package then Attrs.Append ((Name => Attribute_Name, Var_Kind => Undefined, Optional_Index => False, Attr_Kind => Unknown, Read_Only => False, Others_Allowed => False, Default => Empty_Value, Config_Concat => False, Next => Package_Attributes.Table (To_Package.Value).First_Attribute)); Package_Attributes.Table (To_Package.Value).First_Attribute := Attrs.Last; Attribute_Node := (Value => Attrs.Last); end if; end Add_Attribute; ------------------------- -- Add_Unknown_Package -- ------------------------- procedure Add_Unknown_Package (Name : Name_Id; Id : out Package_Node_Id) is begin if Last_Known_Package = Empty_Pkg then Last_Known_Package := Package_Attributes.Last; end if; Package_Attributes.Increment_Last; Id := (Value => Package_Attributes.Last); Package_Attributes.Table (Id.Value) := (Name => Name, Known => False, First_Attribute => Empty_Attr); end Add_Unknown_Package; ----------------------------- -- Remove_Unknown_Packages -- ----------------------------- procedure Remove_Unknown_Packages is begin if Last_Known_Package /= Empty_Pkg then Package_Attributes.Set_Last (Last_Known_Package); end if; end Remove_Unknown_Packages; end GPR.Attr.PM; gprbuild-25.0.0/gpr/src/gpr-attr-pm.ads000066400000000000000000000055161470075373400176510ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2005-2021, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package contains insecure procedures that are intended to be used -- only inside the GPR hierarchy. It should not be imported by other tools, -- such as GPS. package GPR.Attr.PM is -- The following procedures should only be used by the Project Manager, as -- duplicate names are not checked. procedure Add_Unknown_Package (Name : Name_Id; Id : out Package_Node_Id); -- Add a new unknown package. The Name cannot be the name of a predefined -- or already registered package, but this is not checked. procedure Remove_Unknown_Packages; -- Remove from the package table all packages that have been added using -- procedure Add_Unknown_Package above. procedure Add_Attribute (To_Package : Package_Node_Id; Attribute_Name : Name_Id; Attribute_Node : out Attribute_Node_Id); -- Add an attribute to the list for package To_Package. Attribute_Name -- cannot be the name of an existing attribute of the package, but this is -- not checked. Does nothing if To_Package is Empty_Package. end GPR.Attr.PM; gprbuild-25.0.0/gpr/src/gpr-attr.adb000066400000000000000000001575231470075373400172240ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2022, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with GPR.Names; use GPR.Names; with GPR.Osint; use GPR.Osint; with GPR.Snames; use GPR.Snames; with GPR.Err; use GPR.Err; package body GPR.Attr is use GNAT; Initialized : Boolean := False; -- A flag to avoid multiple initialization Package_Names : String_List_Access := new Strings.String_List (1 .. 20); Last_Package_Name : Natural := 0; -- Package_Names (1 .. Last_Package_Name) contains the list of the known -- package names, coming from the Initialization_Data string or from -- calls to one of the two procedures Register_New_Package. procedure Add_Package_Name (Name : String); -- Add a package name in the Package_Name list, extending it, if necessary function Name_Id_Of (Name : String) return Name_Id renames Get_Lower_Name_Id; -- Returns the Name_Id for Name in lower case ---------------------- -- Add_Package_Name -- ---------------------- procedure Add_Package_Name (Name : String) is begin if Last_Package_Name = Package_Names'Last then declare New_List : constant Strings.String_List_Access := new Strings.String_List (1 .. Package_Names'Last * 2); begin New_List (Package_Names'Range) := Package_Names.all; Package_Names := New_List; end; end if; Last_Package_Name := Last_Package_Name + 1; Package_Names (Last_Package_Name) := new String'(Name); end Add_Package_Name; -------------------------- -- Attribute_Default_Of -- -------------------------- function Attribute_Default_Of (Attribute : Attribute_Node_Id) return Attribute_Default_Value is begin if Attribute = Empty_Attribute then return Empty_Value; else return Attrs.Table (Attribute.Value).Default; end if; end Attribute_Default_Of; ----------------------- -- Attribute_Kind_Of -- ----------------------- function Attribute_Kind_Of (Attribute : Attribute_Node_Id) return Attribute_Kind is begin if Attribute = Empty_Attribute then return Unknown; else return Attrs.Table (Attribute.Value).Attr_Kind; end if; end Attribute_Kind_Of; ----------------------- -- Attribute_Name_Of -- ----------------------- function Attribute_Name_Of (Attribute : Attribute_Node_Id) return Name_Id is begin if Attribute = Empty_Attribute then return No_Name; else return Attrs.Table (Attribute.Value).Name; end if; end Attribute_Name_Of; -------------------------- -- Attribute_Node_Id_Of -- -------------------------- function Attribute_Node_Id_Of (Name : Name_Id; Starting_At : Attribute_Node_Id) return Attribute_Node_Id is Id : Attr_Node_Id := Starting_At.Value; begin while Id /= Empty_Attr and then Attrs.Table (Id).Name /= Name loop Id := Attrs.Table (Id).Next; end loop; return (Value => Id); end Attribute_Node_Id_Of; ---------------- -- Initialize -- ---------------- procedure Initialize is Current_Package : Pkg_Node_Id := Empty_Pkg; Pack_Set : Name_Id_Set.Set; Attr_Set : Name_Id_Set.Set; Position : Name_Id_Set.Cursor; Inserted : Boolean; function Attribute_Location return String; -- Returns a string depending if we are in the project level attributes -- or in the attributes of a package. procedure Add_Package (Name : Name_Id); procedure Add_Attribute (Name : Name_Id; Var_Kind : Variable_Kind; Opt_Index : Boolean := False; Attr_Kind : Attribute_Kind; Read_Only : Boolean := False; Others_Can : Boolean := False; Default : Attribute_Default_Value := Empty_Value; Conf_Conc : Boolean); ------------------- -- Add_Attribute -- ------------------- procedure Add_Attribute (Name : Name_Id; Var_Kind : Variable_Kind; Opt_Index : Boolean := False; Attr_Kind : Attribute_Kind; Read_Only : Boolean := False; Others_Can : Boolean := False; Default : Attribute_Default_Value := Empty_Value; Conf_Conc : Boolean) is Tab : constant Package_Attributes.Table_Ptr := Package_Attributes.Table; begin Attr_Set.Insert (Name, Position, Inserted); if not Inserted then Error_Msg ("duplicate attribute """ & Get_Name_String_Safe (Name) & """ in " & Attribute_Location, No_Location); return; end if; Attrs.Increment_Last; if Current_Package /= Empty_Pkg and then Tab (Current_Package).First_Attribute = Empty_Attr then Tab (Current_Package).First_Attribute := Attrs.Last; elsif Attrs.Last > Attrs.First then Attrs.Table (Attrs.Last - 1).Next := Attrs.Last; end if; Attrs.Table (Attrs.Last) := (Name => Name, Var_Kind => Var_Kind, Optional_Index => Opt_Index, Attr_Kind => Attr_Kind, Read_Only => Read_Only, Others_Allowed => Others_Can, Default => Default, Config_Concat => Conf_Conc, Next => Empty_Attr); end Add_Attribute; ------------------------ -- Attribute_Location -- ------------------------ function Attribute_Location return String is begin if Current_Package = Empty_Pkg then return "project level attributes"; else return "attribute of package """ & Get_Name_String_Safe (Package_Attributes.Table (Current_Package).Name) & '"'; end if; end Attribute_Location; ----------------- -- Add_Package -- ----------------- procedure Add_Package (Name : Name_Id) is Name_Str : constant String := Get_Name_String (Name); begin Attr_Set.Clear; Pack_Set.Insert (Name, Position, Inserted); if not Inserted then Error_Msg ("duplicate name """ & Name_Str & """ in predefined packages.", No_Location); return; end if; Package_Attributes.Increment_Last; Current_Package := Package_Attributes.Last; Package_Attributes.Table (Current_Package) := (Name => Name, Known => True, First_Attribute => Empty_Attr); Add_Package_Name (Name_Str); end Add_Package; Opt_Idx_AA : constant Attribute_Kind := (if Osint.File_Names_Case_Sensitive then Optional_Index_Associative_Array else Optional_Index_Case_Insensitive_Associative_Array); Assoc_Array : constant Attribute_Kind := (if Osint.File_Names_Case_Sensitive then Associative_Array else Case_Insensitive_Associative_Array); -- Start of processing for Initialize begin -- Don't allow Initialize action to be repeated if Initialized then return; end if; -- Make sure the two tables are empty Attrs.Init; Package_Attributes.Init; Add_Attribute (Name_Name, Var_Kind => Single, Attr_Kind => Single, Read_Only => True, Default => Read_Only_Value, Conf_Conc => False); Add_Attribute (Name_Project_Dir, Var_Kind => Single, Attr_Kind => Single, Read_Only => True, Default => Read_Only_Value, Conf_Conc => False); Add_Attribute (Name_Main, Var_Kind => List, Opt_Index => True, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Languages, Var_Kind => List, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Roots, Var_Kind => List, Attr_Kind => Assoc_Array, Conf_Conc => False); Add_Attribute (Name_Externally_Built, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Origin_Project, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Create_Missing_Dirs, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Warning_Message, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Object_Dir, Var_Kind => Single, Attr_Kind => Single, Default => Dot_Value, Conf_Conc => False); Add_Attribute (Name_Exec_Dir, Var_Kind => Single, Attr_Kind => Single, Default => Object_Dir_Value, Conf_Conc => False); Add_Attribute (Name_Source_Dirs, Var_Kind => List, Attr_Kind => Single, Default => Dot_Value, Conf_Conc => False); Add_Attribute (Name_Inherit_Source_Path, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Excluded_Source_Dirs, Var_Kind => List, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Ignore_Source_Sub_Dirs, Var_Kind => List, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Only_Dirs_With_Sources, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Source_Files, Var_Kind => List, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Locally_Removed_Files, Var_Kind => List, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Excluded_Source_Files, Var_Kind => List, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Source_List_File, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Excluded_Source_List_File, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Interfaces, Var_Kind => List, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Project_Files, Var_Kind => List, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Project_Path, Var_Kind => List, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_External, Var_Kind => Single, Attr_Kind => Associative_Array, Conf_Conc => False); Add_Attribute (Name_Library_Dir, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Library_Name, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Library_Kind, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Library_Version, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Library_Interface, Var_Kind => List, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Library_Standalone, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Library_Encapsulated_Options, Var_Kind => List, Attr_Kind => Single, Conf_Conc => True); Add_Attribute (Name_Library_Encapsulated_Supported, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Library_Auto_Init, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Leading_Library_Options, Var_Kind => List, Attr_Kind => Single, Conf_Conc => True); Add_Attribute (Name_Library_Options, Var_Kind => List, Attr_Kind => Single, Conf_Conc => True); Add_Attribute (Name_Library_Rpath_Options, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => True); Add_Attribute (Name_Library_Src_Dir, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Library_Ali_Dir, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Library_GCC, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Library_Symbol_File, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Library_Symbol_Policy, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Library_Reference_Symbol_File, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Default_Language, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Run_Path_Option, Var_Kind => List, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Run_Path_Origin, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Separate_Run_Path_Options, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Toolchain_Version, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Toolchain_Description, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Toolchain_Name, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Toolchain_Path, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Object_Generated, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Objects_Linked, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Target, Var_Kind => Single, Attr_Kind => Single, Default => Target_Value, Conf_Conc => False); Add_Attribute (Name_Canonical_Target, Var_Kind => Single, Attr_Kind => Single, Default => Canonical_Target_Value, Conf_Conc => False); Add_Attribute (Name_Runtime, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Default => Runtime_Value, Conf_Conc => False); Add_Attribute (Name_Runtime_Library_Dir, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Runtime_Library_Dirs, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Runtime_Source_Dir, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Runtime_Source_Dirs, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Runtime_Dir, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Runtime_Library_Version, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Required_Toolchain_Version, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Library_Builder, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Library_Support, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Archive_Builder, Var_Kind => List, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Archive_Builder_Append_Option, Var_Kind => List, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Archive_Indexer, Var_Kind => List, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Archive_Suffix, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Library_Partial_Linker, Var_Kind => List, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Object_Lister, Var_Kind => List, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Object_Lister_Matcher, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Shared_Library_Prefix, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Shared_Library_Suffix, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Symbolic_Link_Supported, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Library_Major_Minor_Id_Supported, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Library_Auto_Init_Supported, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Shared_Library_Minimum_Switches, Var_Kind => List, Attr_Kind => Single, Conf_Conc => True); Add_Attribute (Name_Library_Version_Switches, Var_Kind => List, Attr_Kind => Single, Conf_Conc => True); Add_Attribute (Name_Library_Install_Name_Option, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Config_Prj_File, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Package (Name_Naming); Add_Attribute (Name_Specification_Suffix, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Spec_Suffix, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Implementation_Suffix, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Body_Suffix, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Separate_Suffix, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Casing, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Dot_Replacement, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Specification, Var_Kind => Single, Opt_Index => True, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Spec, Var_Kind => Single, Opt_Index => True, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Implementation, Var_Kind => Single, Opt_Index => True, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Body, Var_Kind => Single, Opt_Index => True, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Specification_Exceptions, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Implementation_Exceptions, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Package (Name_Compiler); Add_Attribute (Name_Default_Switches, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => True); Add_Attribute (Name_Switches, Var_Kind => List, Attr_Kind => Opt_Idx_AA, Others_Can => True, Conf_Conc => True); Add_Attribute (Name_Local_Configuration_Pragmas, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Local_Config_File, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Driver, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Language_Kind, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Dependency_Kind, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Required_Switches, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => True); Add_Attribute (Name_Leading_Required_Switches, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => True); Add_Attribute (Name_Trailing_Required_Switches, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => True); Add_Attribute (Name_Pic_Option, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Source_File_Switches, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => True); Add_Attribute (Name_Object_File_Suffix, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Object_File_Switches, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => True); Add_Attribute (Name_Multi_Unit_Switches, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => True); Add_Attribute (Name_Multi_Unit_Object_Separator, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Mapping_File_Switches, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => True); Add_Attribute (Name_Mapping_Spec_Suffix, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Mapping_Body_Suffix, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Config_File_Switches, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => True); Add_Attribute (Name_Config_Body_File_Name, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Config_Body_File_Name_Index, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Config_Body_File_Name_Pattern, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Config_Spec_File_Name, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Config_Spec_File_Name_Index, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Config_Spec_File_Name_Pattern, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Config_File_Unique, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Config_File_Dependency_Support, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Dependency_Switches, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => True); Add_Attribute (Name_Dependency_Driver, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Include_Switches, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => True); Add_Attribute (Name_Include_Switches_Via_Spec, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Include_Path, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Include_Path_File, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Object_Path_Switches, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => True); Add_Attribute (Name_Max_Command_Line_Length, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Response_File_Format, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Response_File_Switches, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => True); Add_Package (Name_Builder); Add_Attribute (Name_Default_Switches, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => True); Add_Attribute (Name_Switches, Var_Kind => List, Attr_Kind => Opt_Idx_AA, Others_Can => True, Conf_Conc => True); Add_Attribute (Name_Global_Compilation_Switches, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => True); Add_Attribute (Name_Executable, Var_Kind => Single, Attr_Kind => Opt_Idx_AA, Conf_Conc => False); Add_Attribute (Name_Executable_Suffix, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Global_Configuration_Pragmas, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Global_Config_File, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Package (Name_Gnatls); Add_Attribute (Name_Switches, Var_Kind => List, Attr_Kind => Single, Conf_Conc => False); Add_Package (Name_Binder); Add_Attribute (Name_Default_Switches, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => True); Add_Attribute (Name_Switches, Var_Kind => List, Attr_Kind => Opt_Idx_AA, Others_Can => True, Conf_Conc => True); Add_Attribute (Name_Driver, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Required_Switches, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => True); Add_Attribute (Name_Prefix, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Objects_Path, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Objects_Path_File, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Bindfile_Option_Substitution, Var_Kind => List, Attr_Kind => Associative_Array, Conf_Conc => False); Add_Package (Name_Linker); Add_Attribute (Name_Required_Switches, Var_Kind => List, Attr_Kind => Single, Conf_Conc => True); Add_Attribute (Name_Default_Switches, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => True); Add_Attribute (Name_Leading_Switches, Var_Kind => List, Attr_Kind => Opt_Idx_AA, Others_Can => True, Conf_Conc => True); Add_Attribute (Name_Switches, Var_Kind => List, Attr_Kind => Opt_Idx_AA, Others_Can => True, Conf_Conc => True); Add_Attribute (Name_Trailing_Switches, Var_Kind => List, Attr_Kind => Opt_Idx_AA, Others_Can => True, Conf_Conc => True); Add_Attribute (Name_Linker_Options, Var_Kind => List, Attr_Kind => Single, Conf_Conc => True); Add_Attribute (Name_Map_File_Option, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Driver, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Max_Command_Line_Length, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Response_File_Format, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Response_File_Switches, Var_Kind => List, Attr_Kind => Single, Conf_Conc => True); Add_Attribute (Name_Export_File_Format, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Export_File_Switch, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Unconditional_Linking, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Package (Name_Clean); Add_Attribute (Name_Switches, Var_Kind => List, Attr_Kind => Single, Conf_Conc => True); Add_Attribute (Name_Source_Artifact_Extensions, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Object_Artifact_Extensions, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Artifacts_In_Exec_Dir, Var_Kind => List, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Artifacts_In_Object_Dir, Var_Kind => List, Attr_Kind => Single, Conf_Conc => False); Add_Package (Name_Cross_Reference); Add_Attribute (Name_Default_Switches, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => True); Add_Attribute (Name_Switches, Var_Kind => List, Attr_Kind => Assoc_Array, Others_Can => True, Conf_Conc => True); Add_Package (Name_Finder); Add_Attribute (Name_Default_Switches, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => True); Add_Attribute (Name_Switches, Var_Kind => List, Attr_Kind => Assoc_Array, Others_Can => True, Conf_Conc => True); Add_Package (Name_Pretty_Printer); Add_Attribute (Name_Default_Switches, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => True); Add_Attribute (Name_Switches, Var_Kind => List, Attr_Kind => Assoc_Array, Others_Can => True, Conf_Conc => True); Add_Package (Name_Gnatstub); Add_Attribute (Name_Default_Switches, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => True); Add_Attribute (Name_Switches, Var_Kind => List, Attr_Kind => Assoc_Array, Others_Can => True, Conf_Conc => True); Add_Package (Name_Check); Add_Attribute (Name_Default_Switches, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => True); Add_Attribute (Name_Switches, Var_Kind => List, Attr_Kind => Assoc_Array, Others_Can => True, Conf_Conc => True); Add_Package (Name_Eliminate); Add_Attribute (Name_Default_Switches, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => True); Add_Attribute (Name_Switches, Var_Kind => List, Attr_Kind => Assoc_Array, Others_Can => True, Conf_Conc => True); Add_Package (Name_Metrics); Add_Attribute (Name_Default_Switches, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => True); Add_Attribute (Name_Switches, Var_Kind => List, Attr_Kind => Assoc_Array, Others_Can => True, Conf_Conc => True); Add_Package (Name_Ide); Add_Attribute (Name_Default_Switches, Var_Kind => List, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => True); Add_Attribute (Name_Remote_Host, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Program_Host, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Communication_Protocol, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Compiler_Command, Var_Kind => Single, Attr_Kind => Case_Insensitive_Associative_Array, Conf_Conc => False); Add_Attribute (Name_Debugger_Command, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Gnatlist, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Vcs_Kind, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Vcs_File_Check, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Vcs_Log_Check, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Documentation_Dir, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Package (Name_Install); Add_Attribute (Name_Prefix, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Sources_Subdir, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Exec_Subdir, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_ALI_Subdir, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Lib_Subdir, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Project_Subdir, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Active, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Install_Project, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Artifacts, Var_Kind => List, Attr_Kind => Associative_Array, Conf_Conc => False); Add_Attribute (Name_Required_Artifacts, Var_Kind => List, Attr_Kind => Associative_Array, Conf_Conc => False); Add_Attribute (Name_Mode, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Install_Name, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Side_Debug, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Package (Name_Remote); Add_Attribute (Name_Root_Dir, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Excluded_Patterns, Var_Kind => List, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Included_Patterns, Var_Kind => List, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Included_Artifact_Patterns, Var_Kind => List, Attr_Kind => Single, Conf_Conc => False); Add_Package (Name_Stack); Add_Attribute (Name_Switches, Var_Kind => List, Attr_Kind => Single, Conf_Conc => True); Add_Package (Name_Codepeer); Add_Attribute (Name_Output_Directory, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Database_Directory, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Message_Patterns, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Additional_Patterns, Var_Kind => Single, Attr_Kind => Single, Conf_Conc => False); Add_Attribute (Name_Switches, Var_Kind => List, Attr_Kind => Single, Conf_Conc => True); Add_Attribute (Name_Excluded_Source_Files, Var_Kind => List, Attr_Kind => Single, Conf_Conc => False); Initialized := True; end Initialize; ---------------------------- -- Is_Config_Concatenable -- ---------------------------- function Is_Config_Concatenable (Attribute : Attribute_Node_Id) return Boolean is begin if Attribute = Empty_Attribute then return False; else return Attrs.Table (Attribute.Value).Config_Concat; end if; end Is_Config_Concatenable; ------------------ -- Is_Read_Only -- ------------------ function Is_Read_Only (Attribute : Attribute_Node_Id) return Boolean is begin return Attrs.Table (Attribute.Value).Read_Only; end Is_Read_Only; -------------------- -- Next_Attribute -- -------------------- function Next_Attribute (After : Attribute_Node_Id) return Attribute_Node_Id is begin if After = Empty_Attribute then return Empty_Attribute; else return (Value => Attrs.Table (After.Value).Next); end if; end Next_Attribute; ----------------------- -- Optional_Index_Of -- ----------------------- function Optional_Index_Of (Attribute : Attribute_Node_Id) return Boolean is begin if Attribute = Empty_Attribute then return False; else return Attrs.Table (Attribute.Value).Optional_Index; end if; end Optional_Index_Of; function Others_Allowed_For (Attribute : Attribute_Node_Id) return Boolean is begin if Attribute = Empty_Attribute then return False; else return Attrs.Table (Attribute.Value).Others_Allowed; end if; end Others_Allowed_For; ----------------------- -- Package_Name_List -- ----------------------- function Package_Name_List return Strings.String_List is begin return Package_Names (1 .. Last_Package_Name); end Package_Name_List; ------------------------ -- Package_Node_Id_Of -- ------------------------ function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id is begin for Index in Package_Attributes.First .. Package_Attributes.Last loop if Package_Attributes.Table (Index).Name = Name then if Package_Attributes.Table (Index).Known then return (Value => Index); else return Unknown_Package; end if; end if; end loop; -- If there is no package with this name, return Empty_Package return Empty_Package; end Package_Node_Id_Of; -------------------------- -- Attribute_Registered -- -------------------------- function Attribute_Registered (Name : String; In_Package : Package_Node_Id) return Boolean is Attr_Name : Name_Id; First_Attr : Attr_Node_Id := Empty_Attr; Curr_Attr : Attr_Node_Id; begin if Name'Length = 0 then Error_Msg ("cannot check an attribute with no name", No_Location); return False; end if; if In_Package = Empty_Package then Error_Msg ("cannot check an attribute """ & Name & """ from an undefined package", No_Location); return False; end if; Attr_Name := Name_Id_Of (Name); First_Attr := Package_Attributes.Table (In_Package.Value).First_Attribute; -- Check if attribute name is a duplicate Curr_Attr := First_Attr; while Curr_Attr /= Empty_Attr loop if Attrs.Table (Curr_Attr).Name = Attr_Name then return True; end if; Curr_Attr := Attrs.Table (Curr_Attr).Next; end loop; return False; end Attribute_Registered; ---------------------------- -- Register_New_Attribute -- ---------------------------- procedure Register_New_Attribute (Name : String; In_Package : Package_Node_Id; Attr_Kind : Defined_Attribute_Kind; Var_Kind : Defined_Variable_Kind; Index_Is_File_Name : Boolean := False; Opt_Index : Boolean := False; Default : Attribute_Default_Value := Empty_Value; Config_Concatenable : Boolean := False) is Attr_Name : Name_Id; First_Attr : Attr_Node_Id := Empty_Attr; Curr_Attr : Attr_Node_Id; Real_Attr_Kind : Attribute_Kind; begin if Name'Length = 0 then Error_Msg ("cannot register an attribute with no name", No_Location); return; end if; if In_Package = Empty_Package then Error_Msg ("attempt to add attribute """ & Name & """ to an undefined package", No_Location); return; end if; Attr_Name := Name_Id_Of (Name); First_Attr := Package_Attributes.Table (In_Package.Value).First_Attribute; -- Check if attribute name is a duplicate Curr_Attr := First_Attr; while Curr_Attr /= Empty_Attr loop if Attrs.Table (Curr_Attr).Name = Attr_Name then Error_Msg ("duplicate attribute name """ & Name & """ in package """ & Get_Name_String_Safe (Package_Attributes.Table (In_Package.Value).Name) & """", No_Location); return; end if; Curr_Attr := Attrs.Table (Curr_Attr).Next; end loop; Real_Attr_Kind := Attr_Kind; -- If Index_Is_File_Name, change the attribute kind if necessary if Index_Is_File_Name and then not Osint.File_Names_Case_Sensitive then case Attr_Kind is when Associative_Array => Real_Attr_Kind := Case_Insensitive_Associative_Array; when Optional_Index_Associative_Array => Real_Attr_Kind := Optional_Index_Case_Insensitive_Associative_Array; when others => null; end case; end if; -- Add the new attribute Attrs.Increment_Last; Attrs.Table (Attrs.Last) := (Name => Attr_Name, Var_Kind => Var_Kind, Optional_Index => Opt_Index, Attr_Kind => Real_Attr_Kind, Read_Only => False, Others_Allowed => False, Default => Default, Config_Concat => Config_Concatenable, Next => First_Attr); Package_Attributes.Table (In_Package.Value).First_Attribute := Attrs.Last; end Register_New_Attribute; -------------------------- -- Register_New_Package -- -------------------------- procedure Register_New_Package (Name : String; Id : out Package_Node_Id) is Pkg_Name : Name_Id; Found : Boolean := False; begin if Name'Length = 0 then Error_Msg ("cannot register a package with no name", No_Location); Id := Empty_Package; return; end if; Pkg_Name := Name_Id_Of (Name); for Index in Package_Attributes.First .. Package_Attributes.Last loop if Package_Attributes.Table (Index).Name = Pkg_Name then if Package_Attributes.Table (Index).Known then Error_Msg ("cannot register a package with a non unique name """ & Name & """", No_Location); Id := Empty_Package; return; else Found := True; Id := (Value => Index); exit; end if; end if; end loop; if not Found then Package_Attributes.Increment_Last; Id := (Value => Package_Attributes.Last); end if; Package_Attributes.Table (Id.Value) := (Name => Pkg_Name, Known => True, First_Attribute => Empty_Attr); Add_Package_Name (Get_Name_String (Pkg_Name)); end Register_New_Package; procedure Register_New_Package (Name : String; Attributes : Attribute_Data_Array) is Pkg_Name : Name_Id; Attr_Name : Name_Id; First_Attr : Attr_Node_Id := Empty_Attr; Curr_Attr : Attr_Node_Id; Attr_Kind : Attribute_Kind; begin if Name'Length = 0 then Error_Msg ("cannot register a package with no name", No_Location); return; end if; Pkg_Name := Name_Id_Of (Name); for Index in Package_Attributes.First .. Package_Attributes.Last loop if Package_Attributes.Table (Index).Name = Pkg_Name then Error_Msg ("cannot register a package with a non unique name """ & Name & '"', No_Location); return; end if; end loop; for Index in Attributes'Range loop Attr_Name := Name_Id_Of (Attributes (Index).Name); Curr_Attr := First_Attr; while Curr_Attr /= Empty_Attr loop if Attrs.Table (Curr_Attr).Name = Attr_Name then Error_Msg ("duplicate attribute name """ & Attributes (Index).Name & """ in new package """ & Name & '"', No_Location); return; end if; Curr_Attr := Attrs.Table (Curr_Attr).Next; end loop; Attr_Kind := Attributes (Index).Attr_Kind; if Attributes (Index).Index_Is_File_Name and then not Osint.File_Names_Case_Sensitive then case Attr_Kind is when Associative_Array => Attr_Kind := Case_Insensitive_Associative_Array; when Optional_Index_Associative_Array => Attr_Kind := Optional_Index_Case_Insensitive_Associative_Array; when others => null; end case; end if; Attrs.Increment_Last; Attrs.Table (Attrs.Last) := (Name => Attr_Name, Var_Kind => Attributes (Index).Var_Kind, Optional_Index => Attributes (Index).Opt_Index, Attr_Kind => Attr_Kind, Read_Only => False, Others_Allowed => False, Default => Attributes (Index).Default, Config_Concat => Attributes (Index).Config_Concatenable, Next => First_Attr); First_Attr := Attrs.Last; end loop; Package_Attributes.Increment_Last; Package_Attributes.Table (Package_Attributes.Last) := (Name => Pkg_Name, Known => True, First_Attribute => First_Attr); Add_Package_Name (Get_Name_String (Pkg_Name)); end Register_New_Package; --------------------------- -- Set_Attribute_Kind_Of -- --------------------------- procedure Set_Attribute_Kind_Of (Attribute : Attribute_Node_Id; To : Attribute_Kind) is begin if Attribute /= Empty_Attribute then Attrs.Table (Attribute.Value).Attr_Kind := To; end if; end Set_Attribute_Kind_Of; -------------------------- -- Set_Variable_Kind_Of -- -------------------------- procedure Set_Variable_Kind_Of (Attribute : Attribute_Node_Id; To : Variable_Kind) is begin if Attribute /= Empty_Attribute then Attrs.Table (Attribute.Value).Var_Kind := To; end if; end Set_Variable_Kind_Of; ---------------------- -- Variable_Kind_Of -- ---------------------- function Variable_Kind_Of (Attribute : Attribute_Node_Id) return Variable_Kind is begin if Attribute = Empty_Attribute then return Undefined; else return Attrs.Table (Attribute.Value).Var_Kind; end if; end Variable_Kind_Of; ------------------------ -- First_Attribute_Of -- ------------------------ function First_Attribute_Of (Pkg : Package_Node_Id) return Attribute_Node_Id is begin if Pkg = Empty_Package or else Pkg = Unknown_Package then return Empty_Attribute; else return (Value => Package_Attributes.Table (Pkg.Value).First_Attribute); end if; end First_Attribute_Of; ---------------------- -- Is_Package_Known -- ---------------------- function Is_Package_Known (Pkg : Package_Node_Id) return Boolean is begin if Pkg = Empty_Package or else Pkg = Unknown_Package then return False; else return Package_Attributes.Table (Pkg.Value).Known; end if; end Is_Package_Known; end GPR.Attr; gprbuild-25.0.0/gpr/src/gpr-attr.ads000066400000000000000000000347101470075373400172350ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2021, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package defines packages and attributes in GNAT project files. -- There are predefined packages and attributes. -- It is also possible to define new packages with their attributes with GNAT.Strings; with GNAT.Table; package GPR.Attr is function Package_Name_List return GNAT.Strings.String_List; -- Returns the list of valid package names, including those added by -- procedures Register_New_Package below. The String_Access components of -- the returned String_List should never be freed. procedure Initialize; -- Initialize the predefined project level attributes and the predefined -- packages and their attribute. This procedure should be called by -- Prj.Initialize. type Attribute_Kind is ( Unknown, -- The attribute does not exist Single, -- Single variable attribute (not an associative array) Associative_Array, -- Associative array attribute with a case sensitive index Optional_Index_Associative_Array, -- Associative array attribute with a case sensitive index and an -- optional source index. Case_Insensitive_Associative_Array, -- Associative array attribute with a case insensitive index Optional_Index_Case_Insensitive_Associative_Array -- Associative array attribute with a case insensitive index and an -- optional source index. ); -- Characteristics of an attribute. Optional_Index indicates that there -- may be an optional index in the index of the associative array, as in -- for Switches ("files.ada" at 2) use ... subtype Defined_Attribute_Kind is Attribute_Kind range Single .. Optional_Index_Case_Insensitive_Associative_Array; -- Subset of Attribute_Kinds that may be used for the attributes that is -- used when defining a new package. subtype All_Case_Insensitive_Associative_Array is Attribute_Kind range Case_Insensitive_Associative_Array .. Optional_Index_Case_Insensitive_Associative_Array; -- Subtype including both cases of Case_Insensitive_Associative_Array Max_Attribute_Name_Length : constant := 64; -- The maximum length of attribute names subtype Attribute_Name_Length is Positive range 1 .. Max_Attribute_Name_Length; type Attribute_Data (Name_Length : Attribute_Name_Length := 1) is record Name : String (1 .. Name_Length); -- The name of the attribute Attr_Kind : Defined_Attribute_Kind; -- The type of the attribute Index_Is_File_Name : Boolean; -- For associative arrays, indicate if the index is a file name, so -- that the attribute kind may be modified depending on the case -- sensitivity of file names. This is only taken into account when -- Attr_Kind is Associative_Array or Optional_Index_Associative_Array. Opt_Index : Boolean; -- True if there may be an optional index in the value of the index, -- as in: -- "file.ada" at 2 -- ("main.adb", "file.ada" at 1) Var_Kind : Defined_Variable_Kind; -- The attribute value kind: single or list Default : Attribute_Default_Value := Empty_Value; -- The value of the attribute when referenced if the attribute has not -- yet been declared. Config_Concatenable : Boolean := False; end record; -- Name and characteristics of an attribute in a package registered -- explicitly with Register_New_Package (see below). type Attribute_Data_Array is array (Positive range <>) of Attribute_Data; -- A list of attribute name/characteristics to be used as parameter of -- procedure Register_New_Package below. -- In the subprograms below, when it is specified that the subprogram -- "fails", procedure Prj.Com.Fail is called. Unless it is specified -- otherwise, if Prj.Com.Fail returns, exception Prj.Prj_Error is raised. procedure Register_New_Package (Name : String; Attributes : Attribute_Data_Array); -- Add a new package with its attributes. This procedure can only be -- called after Initialize, but before any other call to a service of -- the Project Manager. Fail if the name of the package is empty or not -- unique, or if the names of the attributes are not different. ---------------- -- Attributes -- ---------------- type Attribute_Node_Id is private; -- The type to refers to an attribute, self-initialized Empty_Attribute : constant Attribute_Node_Id; -- Indicates no attribute. Default value of Attribute_Node_Id objects Attribute_First : constant Attribute_Node_Id; -- First attribute node id of project level attributes function Attribute_Node_Id_Of (Name : Name_Id; Starting_At : Attribute_Node_Id) return Attribute_Node_Id; -- Returns the node id of an attribute at the project level or in -- a package. Starting_At indicates the first known attribute node where -- to start the search. Returns Empty_Attribute if the attribute cannot -- be found. function Attribute_Kind_Of (Attribute : Attribute_Node_Id) return Attribute_Kind; -- Returns the attribute kind of a known attribute. Returns Unknown if -- Attribute is Empty_Attribute. -- -- To use this function, the following code should be used: -- -- Pkg : constant Package_Node_Id := -- Prj.Attr.Package_Node_Id_Of (Name => ); -- Att : constant Attribute_Node_Id := -- Prj.Attr.Attribute_Node_Id_Of -- (Name => , -- Starting_At => First_Attribute_Of (Pkg)); -- Kind : constant Attribute_Kind := Attribute_Kind_Of (Att); -- -- However, do not use this function once you have an already parsed -- project tree. Instead, given a Project_Node_Id corresponding to the -- attribute declaration ("for Attr (index) use ..."), use for example: -- -- if Case_Insensitive (Attr, Tree) then ... procedure Set_Attribute_Kind_Of (Attribute : Attribute_Node_Id; To : Attribute_Kind); -- Set the attribute kind of a known attribute. Does nothing if -- Attribute is Empty_Attribute. function Attribute_Name_Of (Attribute : Attribute_Node_Id) return Name_Id; -- Returns the name of a known attribute. Returns No_Name if Attribute is -- Empty_Attribute. function Variable_Kind_Of (Attribute : Attribute_Node_Id) return Variable_Kind; -- Returns the variable kind of a known attribute. Returns Undefined if -- Attribute is Empty_Attribute. procedure Set_Variable_Kind_Of (Attribute : Attribute_Node_Id; To : Variable_Kind); -- Set the variable kind of a known attribute. Does nothing if Attribute is -- Empty_Attribute. function Attribute_Default_Of (Attribute : Attribute_Node_Id) return Attribute_Default_Value; -- Returns the default of the attribute, Read_Only_Value for read only -- attributes, Empty_Value when default not specified, or specified value. function Optional_Index_Of (Attribute : Attribute_Node_Id) return Boolean; -- Returns True if Attribute is a known attribute and may have an -- optional index. Returns False otherwise. function Is_Read_Only (Attribute : Attribute_Node_Id) return Boolean; function Next_Attribute (After : Attribute_Node_Id) return Attribute_Node_Id; -- Returns the attribute that follow After in the list of project level -- attributes or the list of attributes in a package. -- Returns Empty_Attribute if After is either Empty_Attribute or is the -- last of the list. function Others_Allowed_For (Attribute : Attribute_Node_Id) return Boolean; -- True iff the index for an associative array attributes may be others function Is_Config_Concatenable (Attribute : Attribute_Node_Id) return Boolean; -- True iff the values in configuration project and user project are -- concatenated when both are not empty. -------------- -- Packages -- -------------- procedure Register_New_Package (Name : String; Id : out Package_Node_Id); -- Add a new package. Fails if Name (the package name) is empty or is -- already the name of a package, and set Id to Empty_Package, -- if Prj.Com.Fail returns. Initially, the new package has no attributes. -- Id may be used to add attributes using procedure Register_New_Attribute -- below. procedure Register_New_Attribute (Name : String; In_Package : Package_Node_Id; Attr_Kind : Defined_Attribute_Kind; Var_Kind : Defined_Variable_Kind; Index_Is_File_Name : Boolean := False; Opt_Index : Boolean := False; Default : Attribute_Default_Value := Empty_Value; Config_Concatenable : Boolean := False); -- Add a new attribute to registered package In_Package. Fails if Name -- (the attribute name) is empty, if In_Package is Empty_Package or if -- the attribute name has a duplicate name. See definition of type -- Attribute_Data above for the meaning of parameters Attr_Kind, Var_Kind, -- Index_Is_File_Name, Opt_Index, Default and Config_Concatenable. function Attribute_Registered (Name : String; In_Package : Package_Node_Id) return Boolean; -- Checks if corresponding attribute has already been registered. -- Fails if Name (the attribute name) is empty or if In_Package is -- Empty_Package. function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id; -- Returns the package node id of the package with name Name. Returns -- Empty_Package if there is no package with this name. function First_Attribute_Of (Pkg : Package_Node_Id) return Attribute_Node_Id; -- Returns the first attribute in the list of attributes of package Pkg. -- Returns Empty_Attribute if Pkg is Empty_Package or Unknown_Package. function Is_Package_Known (Pkg : Package_Node_Id) return Boolean; -- Returns True if package is known for the tool private ---------------- -- Attributes -- ---------------- Attributes_Initial : constant := 50; Attributes_Increment : constant := 100; Attribute_Node_Low_Bound : constant := 0; Attribute_Node_High_Bound : constant := 099_999_999; type Attr_Node_Id is range Attribute_Node_Low_Bound .. Attribute_Node_High_Bound; -- Index type for table Attrs in the body type Attribute_Node_Id is record Value : Attr_Node_Id := Attribute_Node_Low_Bound; end record; -- Full declaration of self-initialized private type Empty_Attr : constant Attr_Node_Id := Attribute_Node_Low_Bound; Empty_Attribute : constant Attribute_Node_Id := (Value => Empty_Attr); First_Attribute : constant Attr_Node_Id := Attribute_Node_Low_Bound + 1; First_Attribute_Node_Id : constant Attribute_Node_Id := (Value => First_Attribute); Attribute_First : constant Attribute_Node_Id := First_Attribute_Node_Id; -------------- -- Packages -- -------------- First_Package : constant Pkg_Node_Id := Package_Node_Low_Bound + 1; First_Package_Node_Id : constant Package_Node_Id := (Value => First_Package); Package_First : constant Package_Node_Id := First_Package_Node_Id; -- The following tables are here, because they are also used in package -- GPR.Attr.PM. ---------------- -- Attributes -- ---------------- type Attribute_Record is record Name : Name_Id; Var_Kind : Variable_Kind; Optional_Index : Boolean; Attr_Kind : Attribute_Kind; Read_Only : Boolean; Others_Allowed : Boolean; Default : Attribute_Default_Value; Config_Concat : Boolean; Next : Attr_Node_Id; end record; -- Data for an attribute package Attrs is new GNAT.Table (Table_Component_Type => Attribute_Record, Table_Index_Type => Attr_Node_Id, Table_Low_Bound => First_Attribute, Table_Initial => Attributes_Initial, Table_Increment => Attributes_Increment); -- The table of the attributes -------------- -- Packages -- -------------- type Package_Record is record Name : Name_Id; Known : Boolean := True; First_Attribute : Attr_Node_Id; end record; -- Data for a package package Package_Attributes is new GNAT.Table (Table_Component_Type => Package_Record, Table_Index_Type => Pkg_Node_Id, Table_Low_Bound => First_Package, Table_Initial => Packages_Initial, Table_Increment => Packages_Increment); -- The table of the packages end GPR.Attr; gprbuild-25.0.0/gpr/src/gpr-com.ads000066400000000000000000000044021470075373400170340ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2015, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- The following package declares a Fail procedure that is used in the -- Project Manager. with GPR.Osint; package GPR.Com is type Fail_Proc is access procedure (S : String); Fail : Fail_Proc := GPR.Osint.Fail'Access; -- This procedure is used in the project facility, instead of directly -- calling Project.Osint.Fail. It may be specified by tools to do clean -- up before calling Project.Osint.Fail, or to simply report an error and -- return. end GPR.Com; gprbuild-25.0.0/gpr/src/gpr-compilation-process-waiter.adb000066400000000000000000000046411470075373400235250ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2015-2017, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; use Ada.Exceptions; with Ada.Text_IO; use Ada.Text_IO; package body GPR.Compilation.Process.Waiter is task Wait_Local; ---------------- -- Wait_Local -- ---------------- task body Wait_Local is Pid : Process_Id; Status : Boolean; begin loop Local_Process.Wait_Non_Zero; Wait_Process (Pid, Status); Local_Process.Decrement; Add_Result (Create_Local (Pid), Status); end loop; exception when E : others => Put_Line (Exception_Information (E)); OS_Exit (1); end Wait_Local; end GPR.Compilation.Process.Waiter; gprbuild-25.0.0/gpr/src/gpr-compilation-process-waiter.ads000066400000000000000000000040071470075373400235420ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2015-2017, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- The waiter task is responsible of getting the local process job's statuses. -- This unit must only be withed in GPRbuild main. package GPR.Compilation.Process.Waiter is pragma Elaborate_Body; end GPR.Compilation.Process.Waiter; gprbuild-25.0.0/gpr/src/gpr-compilation-process.adb000066400000000000000000000255651470075373400222440ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2012-2021, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Containers.Doubly_Linked_Lists; with Ada.Containers.Indefinite_Ordered_Maps; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with GPR.Compilation.Slave; with GPR.Names; use GPR.Names; with GPR.Opt; use GPR.Opt; with GPR.Script; use GPR.Script; package body GPR.Compilation.Process is use Ada; use type Containers.Count_Type; package Env_Maps is new Containers.Indefinite_Ordered_Maps (String, String); -- A set of key=value package Prj_Maps is new Containers.Indefinite_Ordered_Maps (String, Env_Maps.Map, Env_Maps."<", Env_Maps."="); -- A set of project+language=map function "<" (Left, Right : Id) return Boolean is (Left.R_Pid < Right.R_Pid); package Failures_Slave_Set is new Containers.Indefinite_Ordered_Maps (Id, String); function Get_Env (Project : Project_Id; Language : String) return String; -- Get the environment for a specific project and language Environments : Prj_Maps.Map; type Process_Data is record Process : Id; Status : Boolean; end record; package Endded_Process is new Containers.Doubly_Linked_Lists (Process_Data); protected Results is procedure Add (Result : Process_Data); entry Get (Result : out Process_Data); procedure Record_Remote_Failure (Pid : Id; Slave : String); -- This is to be able to display on which slaves a specific compilation -- has failed. function Get_Slave_For (Pid : Id) return String; -- Returns the remote slave for the given compilation, or the empty -- string if the compilation was successful. private List : Endded_Process.List; Failed_Proc : Failures_Slave_Set.Map; end Results; ---------------- -- Add_Result -- ---------------- procedure Add_Result (Process : Id; Status : Boolean; Slave : String := "") is begin Results.Add (Process_Data'(Process, Status)); -- For a compilation failure records the slave to be able to report it if not Status and then Slave /= "" then Results.Record_Remote_Failure (Process, Slave); end if; end Add_Result; ------------------ -- Create_Local -- ------------------ function Create_Local (Pid : Process_Id) return Id is begin return Id'(Local, Pid); end Create_Local; ------------------- -- Create_Remote -- ------------------- function Create_Remote (Pid : Remote_Id) return Id is begin return Id'(Remote, Pid); end Create_Remote; --------------------------- -- Get_Maximum_Processes -- --------------------------- function Get_Maximum_Processes return Positive is begin return Opt.Maximum_Compilers + Slave.Get_Max_Processes; end Get_Maximum_Processes; ------------- -- Get_Env -- ------------- function Get_Env (Project : Project_Id; Language : String) return String is Key : constant String := Get_Name_String (Project.Name) & "+" & Language; Res : Unbounded_String; begin if Environments.Contains (Key) then for C in Environments (Key).Iterate loop if Res /= Null_Unbounded_String then Res := Res & Opts_Sep; end if; Res := Res & Env_Maps.Key (C) & '=' & Env_Maps.Element (C); end loop; end if; return To_String (Res); end Get_Env; ------------------- -- Get_Slave_For -- ------------------- function Get_Slave_For (Pid : Id) return String is begin if Pid.Kind = Local then return ""; else return Results.Get_Slave_For (Pid); end if; end Get_Slave_For; ---------- -- Hash -- ---------- function Hash (Process : Id) return Header_Num is Modulo : constant Integer := Integer (Header_Num'Last) + 1; begin if Process.Kind = Local then return Header_Num (Pid_To_Integer (Process.Pid) mod Modulo); else return Header_Num (Process.R_Pid mod Remote_Id (Modulo)); end if; end Hash; ------------------------ -- Record_Environment -- ------------------------ procedure Record_Environment (Project : Project_Id; Language : Name_Id; Name, Value : String) is Lang : constant String := Get_Name_String (Language); Key : constant String := Get_Name_String (Project.Name) & "+" & Lang; New_Item : Env_Maps.Map; begin -- Create new item, variable association New_Item.Include (Name, Value); if Environments.Contains (Key) then if Environments (Key).Contains (Name) then Environments (Key).Replace (Name, Value); else Environments (Key).Insert (Name, Value); end if; else Environments.Insert (Key, New_Item); end if; end Record_Environment; ------------- -- Results -- ------------- protected body Results is --------- -- Add -- --------- procedure Add (Result : Process_Data) is begin List.Append (Result); end Add; --------- -- Get -- --------- entry Get (Result : out Process_Data) when List.Length /= 0 is begin Result := List.First_Element; List.Delete_First; end Get; ------------------- -- Get_Slave_For -- ------------------- function Get_Slave_For (Pid : Id) return String is use type Failures_Slave_Set.Cursor; Pos : constant Failures_Slave_Set.Cursor := Failed_Proc.Find (Pid); begin if Pos = Failures_Slave_Set.No_Element then return ""; else return Failures_Slave_Set.Element (Pos); end if; end Get_Slave_For; --------------------------- -- Record_Remote_Failure -- --------------------------- procedure Record_Remote_Failure (Pid : Id; Slave : String) is begin Failed_Proc.Insert (Pid, Slave); end Record_Remote_Failure; end Results; --------- -- Run -- --------- function Run (Executable : String; Options : String_Vectors.Vector; Project : Project_Id; Obj_Name : String; Source : String := ""; Language : String := ""; Dep_Name : String := ""; Output_File : String := ""; Err_To_Out : Boolean := False; Force_Local : Boolean := False; Response_File : Path_Name_Type := No_Path) return Id is Env : constant String := Get_Env (Project, Language); Success : Boolean; begin -- Run locally first, then send jobs to remote slaves. Note that to -- build remotely we need an output file and a language, if one of -- this requirement is not fulfilled we just run the process locally. if Force_Local or else not Distributed_Mode or else Local_Process.Count < Opt.Maximum_Compilers or else Output_File /= "" or else Language = "" then Run_Local : declare P : Id (Local); Args : String_List_Access := new String_List'(To_Argument_List (Options)); begin Set_Env (Env, Fail => True); if Response_File /= No_Path then declare Opts : constant GNAT.OS_Lib.Argument_List := (1 => new String'("@" & Get_Name_String (Response_File))); begin P.Pid := Non_Blocking_Spawn (Executable, Opts); end; elsif Output_File /= "" then P.Pid := Non_Blocking_Spawn (Executable, Args.all, Output_File, Err_To_Out); elsif Source /= "" and then not No_Complete_Output then P.Pid := Non_Blocking_Spawn (Executable, Args.all, Stdout_File => Source & ".stdout", Stderr_File => Source & ".stderr"); else if Source /= "" then Delete_File (Source & ".stdout", Success); Delete_File (Source & ".stderr", Success); end if; P.Pid := Non_Blocking_Spawn (Executable, Args.all); end if; Check_Local_Process (P, Executable, Options); Script_Write (Executable, Options); Free (Args); Local_Process.Increment; return P; end Run_Local; else -- Even if the compilation is done remotely make sure that any -- .stderr/.stdout from a previous local compilation are removed. if Source /= "" then Delete_File (Source & ".stdout", Success); Delete_File (Source & ".stderr", Success); end if; return Slave.Run (Project, Language, Options, Obj_Name, Dep_Name, Env); end if; end Run; ----------------- -- Wait_Result -- ----------------- procedure Wait_Result (Process : out Id; Status : out Boolean) is Data : Process_Data; begin Results.Get (Data); Process := Data.Process; Status := Data.Status; end Wait_Result; end GPR.Compilation.Process; gprbuild-25.0.0/gpr/src/gpr-compilation-process.ads000066400000000000000000000104151470075373400222510ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2012-2019, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package abstract out a process which can be either local or remote. -- The communication with the remote instances are done through sockets. with GNAT.OS_Lib; with GPR.Util; use GPR.Util; package GPR.Compilation.Process is function Create_Local (Pid : GNAT.OS_Lib.Process_Id) return Id; -- Returns a local process for Pid function Create_Remote (Pid : Remote_Id) return Id; -- Returns a remote process (one running on a slave) for Pid procedure Record_Environment (Project : Project_Id; Language : Name_Id; Name, Value : String); -- Record an environment variable to set when spawning a compilation. This -- is for example to set CPATH if needed for the compilation of C sources. function Run (Executable : String; Options : String_Vectors.Vector; Project : Project_Id; Obj_Name : String; Source : String := ""; Language : String := ""; Dep_Name : String := ""; Output_File : String := ""; Err_To_Out : Boolean := False; Force_Local : Boolean := False; Response_File : Path_Name_Type := No_Path) return Id; -- Run Executable with the given options locally or on a remote slave. -- Dep_File name is the name of the file that is expected to be generated -- if the compilation is successful. If Force_Local is set then the -- compilation will happen on the local machine. If Response_File is -- not No_Path, use it to invoke the compiler, instead of the Options. function Get_Maximum_Processes return Positive; -- The maximum number of simultaneous compilation supported. This is the -- sum of the local parallelism and the sum of remote slaves supported -- processes. -- For the hash table of jobs type Header_Num is range 0 .. 2047; function Hash (Process : Id) return Header_Num; function Get_Slave_For (Pid : Id) return String; -- Returns the slave for the given compilation, or the empty string if the -- compilation was successful or conducted locally. procedure Add_Result (Process : Id; Status : Boolean; Slave : String := ""); -- Add process Id with the given status into the list of results procedure Wait_Result (Process : out Id; Status : out Boolean); -- Wait for a process to terminate (so a compilation process result) to be -- available and returns the process Id and the corresponding status. private Local_Process : Shared_Counter; end GPR.Compilation.Process; gprbuild-25.0.0/gpr/src/gpr-compilation-protocol.adb000066400000000000000000001107241470075373400224170ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2012-2022, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Calendar.Conversions; use Ada.Calendar; with Ada.Calendar.Formatting; use Ada.Calendar.Formatting; with Ada.Characters.Handling; with Ada.Directories; use Ada.Directories; with Ada.Streams.Stream_IO; use Ada.Streams; with Ada.Strings.Fixed; use Ada.Strings.Fixed; with Ada.Strings.Maps.Constants; use Ada.Strings.Maps; with Ada.Unchecked_Deallocation; with GNAT.Rewrite_Data; with GNAT.String_Split; use GNAT.String_Split; with GPR.Version; use GPR.Version; package body GPR.Compilation.Protocol is Args_Sep : constant Character := '|'; -- Channel's argument separator function Image (N : Natural) return String; -- Returns string representation of N without leading space procedure Send_File_Internal (Channel : Communication_Channel; Path_Name : String; Cmd : Command_Kind; Time_Stamp : Time_Stamp_Type); -- Send file Path_Name over the channel with rewritting if needed procedure Send_RAW_File_Content (Channel : Communication_Channel; Path_Name : String); -- Send the file content untranslated procedure Set_File_Stamp (Path_Name : String; Time_Stamp : Time_Stamp_Type) with Inline; -- Set modification time stamp to the given file Buffer_Size : constant := 256 * 1_024; -- 256Kb type Buffer_Access is access Stream_Element_Array; -- Used for RAW data procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Stream_Element_Array, Buffer_Access); ---------- -- Args -- ---------- function Args (Cmd : Command) return Argument_List_Access is begin return Cmd.Args; end Args; ------------ -- Adjust -- ------------ overriding procedure Adjust (Channel : in out Communication_Channel) is begin Channel.Refs.Increment; end Adjust; overriding procedure Adjust (Cmd : in out Command) is begin Cmd.Refs.Increment; end Adjust; ------------------- -- Clear_Rewrite -- ------------------- procedure Clear_Rewrite (Channel : in out Communication_Channel) is begin Channel.WD_From := Null_Unbounded_String; Channel.WD_To := Null_Unbounded_String; Channel.CD_From := Null_Unbounded_String; Channel.CD_To := Null_Unbounded_String; end Clear_Rewrite; ----------- -- Close -- ----------- procedure Close (Channel : in out Communication_Channel) is begin begin -- Make sure we never fail, the other end-point could have already -- closed the channel (hard ctrl-c). Shutdown_Socket (Channel.Sock); exception when others => null; end; -- Now close associated socket begin Close_Socket (Channel.Sock); exception when others => null; end; Channel.Sock := No_Socket; Clear_Rewrite (Channel); end Close; ------------ -- Create -- ------------ function Create (Sock : Socket_Type; Virtual : Boolean := False) return Communication_Channel is begin return Communication_Channel' (Finalization.Controlled with Sock, (if Virtual then null else Stream (Sock)), Null_Unbounded_String, Null_Unbounded_String, Null_Unbounded_String, Null_Unbounded_String, new Shared_Counter (1)); end Create; -------------- -- Finalize -- -------------- overriding procedure Finalize (Channel : in out Communication_Channel) is procedure Unchecked_Free is new Unchecked_Deallocation (Shared_Counter, Shared_Counter_Access); C : Shared_Counter_Access := Channel.Refs; begin Channel.Refs := null; C.Decrement; if C.Count = 0 then Free (Channel.Channel); Unchecked_Free (C); end if; end Finalize; overriding procedure Finalize (Cmd : in out Command) is procedure Unchecked_Free is new Unchecked_Deallocation (Shared_Counter, Shared_Counter_Access); C : Shared_Counter_Access := Cmd.Refs; begin Cmd.Refs := null; C.Decrement; if C.Count = 0 then Free (Cmd.Args); Unchecked_Free (C); end if; end Finalize; ----------------- -- Get_Command -- ----------------- function Get_Command (Channel : Communication_Channel'Class) return Command is use Ada.Streams.Stream_IO; function Handle_File (Cmd : Command) return Command; -- A file has been recieved, write it to disk function Handle_RAW_File (Cmd : Command) return Command; -- A file has been recieved, write it to disk, no rewritte taking place procedure Handle_Output (Cmd : in out Command); -- A display output is received, read it and store it into the command ----------------- -- Handle_File -- ----------------- function Handle_File (Cmd : Command) return Command is procedure Input (Item : out Stream_Element_Array; Last : out Stream_Element_Offset); -- Read and return some data from channel procedure Output (Item : Stream_Element_Array); -- Write data to file File_Name : constant String := Translate_Receive (Channel, Cmd.Args (2).all); Dir : constant String := Containing_Directory (File_Name); Size : Stream_Element_Count := Stream_Element_Count'Value (Cmd.Args (1).all); -- Number of bytes remaining to be read from channel Rewriter : Rewrite_Data.Buffer := Rewrite_Data.Create (To_String (Channel.WD_To), To_String (Channel.WD_From)); Rewriter_CD : aliased Rewrite_Data.Buffer := Rewrite_Data.Create (To_String (Channel.CD_To), To_String (Channel.CD_From)); File : File_Type; ----------- -- Input -- ----------- procedure Input (Item : out Stream_Element_Array; Last : out Stream_Element_Offset) is begin if Size = 0 then Last := 0; else Last := Stream_Element_Count'Min (Item'Length, Size); Stream_Element_Array'Read (Channel.Channel, Item (Item'First .. Last)); Size := Size - Last; end if; end Input; ------------ -- Output -- ------------ procedure Output (Item : Stream_Element_Array) is begin Write (File, Item); end Output; begin Rewrite_Data.Link (Rewriter, Rewriter_CD'Unchecked_Access); if Dir /= "" and then not Exists (Dir) then Create_Directory (Dir); end if; begin Create (File, Out_File, File_Name); Rewrite_Data.Rewrite (Rewriter, Input'Access, Output'Access); Close (File); -- Set time stamp if any if Cmd.Args'Length = 3 then Set_File_Stamp (File_Name, Time_Stamp_Type (Args (Cmd) (3).all)); end if; exception when others => if Is_Open (File) then Close (File); end if; end; return Get_Command (Channel); end Handle_File; --------------------- -- Handle_RAW_File -- --------------------- function Handle_RAW_File (Cmd : Command) return Command is File_Name : constant String := Translate_Receive (Channel, Cmd.Args (1).all); Dir : constant String := Containing_Directory (File_Name); Time_Stamp : Time_Stamp_Type := Empty_Time_Stamp; begin if Dir /= "" and then not Exists (Dir) then Create_Directory (Dir); end if; if Cmd.Args'Length = 2 then -- We have a time-stamp, use it Time_Stamp := Time_Stamp_Type (Args (Cmd) (2).all); end if; Get_RAW_File_Content (Channel, File_Name, Time_Stamp); return Get_Command (Channel); end Handle_RAW_File; ------------------- -- Handle_Output -- ------------------- procedure Handle_Output (Cmd : in out Command) is function Is_Number (Cmd : Command) return Boolean is (Is_Subset (To_Set (Cmd.Args (1).all), Constants.Decimal_Digit_Set)); begin if Cmd.Args'Length = 2 and then Is_Number (Cmd) then declare Size : constant Natural := Natural'Value (Cmd.Args (1).all); Result : String (1 .. Size); begin if Size = 0 then Cmd.Output := Null_Unbounded_String; else String'Read (Channel.Channel, Result); Cmd.Output := To_Unbounded_String (Result); end if; end; else raise Wrong_Command with "Expected DP found " & Command_Kind'Image (Cmd.Cmd); end if; end Handle_Output; Result : Command; Args : Slice_Set; begin declare Line : constant String := String'Input (Channel.Channel); C : constant String := (if Line'Length >= 2 then Line (Line'First .. Line'First + 1) else ""); begin if C in "EX" | "AK" | "TS" | "ES" | "FL" | "FR" | "OK" | "KO" | "CX" | "CU" | "DP" | "EC" | "PG" | "SY" | "IR" then Result.Cmd := Command_Kind'Value (C); -- Slice arguments Create (Args, Line (Line'First + 2 .. Line'Last), String'(1 => Args_Sep)); Result.Args := new Argument_List (1 .. Integer (Slice_Count (Args))); for K in Result.Args'Range loop Result.Args (K) := new String'(Slice (Args, Slice_Number (K))); end loop; if Result.Cmd = FL then -- We got some file data to write return Handle_File (Result); elsif Result.Cmd = FR then return Handle_RAW_File (Result); elsif Result.Cmd = DP then -- We got an output to display Handle_Output (Result); elsif Result.Cmd = EX then -- Last - 1 parameter is the compiler options, ensure that we -- are using native directory separator. This is a requirement -- to have a cross compilation from a Windows builder to a -- Linux slave. declare F_Idx : constant Positive := Result.Args'Last - 1; Filename : constant String := To_Native_Directory_Separator (Result.Args (F_Idx).all); begin Free (Result.Args (F_Idx)); Result.Args (F_Idx) := new String'(Filename); end; end if; else if Line'Length > 0 then raise Wrong_Command with Line; else raise Wrong_Command with "empty command line"; end if; end if; return Result; end; exception when others => -- Any exception means that the channel has been closed. Return an -- EC command (which has no parameter). Result.Cmd := SI; Free (Result.Args); Result.Args := new Argument_List (1 .. 0); return Result; end Get_Command; ----------------- -- Get_Context -- ----------------- procedure Get_Context (Channel : Communication_Channel; Target : out Unbounded_String; Project_Name : out Unbounded_String; Build_Env : out Unbounded_String; Sync : out Boolean; Timestamp : out Time_Stamp_Type; Version : out Unbounded_String; Hash : out Unbounded_String; Included_Artifact_Patterns : out Unbounded_String; Is_Ping : out Boolean) is Line : constant Command := Get_Command (Channel); begin Is_Ping := False; -- Note that to ensure GPRslave stays compatible with old -- version of GNAT Pro and GPRbuild all parameters after the -- 6th must be optional when retrieving the context. Note doing -- that will make GPRslave raise an exception instead of -- reporting a proper non-compatible context. if Line.Cmd = CX and then Line.Args'Length >= 6 then Target := To_Unbounded_String (Line.Args (1).all); Project_Name := To_Unbounded_String (Line.Args (2).all); Build_Env := To_Unbounded_String (Line.Args (3).all); Sync := Boolean'Value (Line.Args (4).all); Timestamp := Time_Stamp_Type (Line.Args (5).all); Version := To_Unbounded_String (Line.Args (6).all); if Line.Args'Length > 6 then Hash := To_Unbounded_String (Line.Args (7).all); else Hash := Null_Unbounded_String; end if; if Line.Args'Length > 7 then Included_Artifact_Patterns := To_Unbounded_String (Line.Args (8).all); else Included_Artifact_Patterns := Null_Unbounded_String; end if; elsif Line.Cmd = PG then Is_Ping := True; else raise Wrong_Command with "Expected CX found " & Command_Kind'Image (Line.Cmd); end if; end Get_Context; ----------------------- -- Get_Info_Response -- ----------------------- procedure Get_Info_Response (Channel : Communication_Channel; Version_String : out Unbounded_String; Current_UTC_Time : out Stamps.Time_Stamp_Type; GPR_Hash : out Unbounded_String; Success : out Boolean) is Cmd : constant Command := Get_Command (Channel); begin if Cmd.Args'Length = 3 and then Cmd.Cmd in OK | KO then Version_String := To_Unbounded_String (Cmd.Args (1).all); Current_UTC_Time := Stamps.Time_Stamp_Type (Cmd.Args (2).all); GPR_Hash := To_Unbounded_String (Cmd.Args (3).all); Success := (if Kind (Cmd) = KO then False); else Success := False; end if; end Get_Info_Response; ------------- -- Get_Pid -- ------------- procedure Get_Pid (Channel : Communication_Channel; Pid : out Remote_Id; Success : out Boolean) is Cmd : constant Command := Get_Command (Channel); begin if Cmd.Args'Length = 1 and then Cmd.Cmd in OK | KO then Pid := Remote_Id'Value (Cmd.Args (1).all); Success := (if Kind (Cmd) = KO then False); else Success := False; end if; end Get_Pid; -------------------------- -- Get_RAW_File_Content -- -------------------------- procedure Get_RAW_File_Content (Channel : Communication_Channel; Path_Name : String; Timestamp : Time_Stamp_Type := Empty_Time_Stamp) is Buffer : Buffer_Access; Last : Stream_Element_Offset; Size : Stream_Element_Offset; File : Stream_IO.File_Type; begin Buffer := new Stream_Element_Array (1 .. Buffer_Size); Stream_IO.Create (File, Stream_IO.Out_File, Path_Name); loop -- Get the size Stream_Element_Offset'Read (Channel.Channel, Size); exit when Size = 0; -- Read this chunk while Size > 0 loop Receive_Socket (Channel.Sock, Buffer (1 .. Size), Last); if Last = 0 then -- Last = First - 1 then socket closed by peer raise Socket_Error; end if; Stream_IO.Write (File, Buffer (1 .. Last)); Size := Size - Last; end loop; end loop; Stream_IO.Close (File); if Timestamp /= Empty_Time_Stamp then Set_File_Stamp (Path_Name, Timestamp); end if; Unchecked_Free (Buffer); exception when others => -- If the file was opened, let's close it if Stream_IO.Is_Open (File) then Stream_IO.Delete (File); elsif Exists (Path_Name) then -- If the file has been created, make sure it is deleted as the -- content may be truncated. Delete_File (Path_Name); end if; Unchecked_Free (Buffer); raise; end Get_RAW_File_Content; ----------- -- Image -- ----------- function Image (N : Natural) return String is N_Img : constant String := Natural'Image (N); begin return N_Img (N_Img'First + 1 .. N_Img'Last); end Image; ---------------- -- Initialize -- ---------------- overriding procedure Initialize (Channel : in out Communication_Channel) is begin Channel.Refs := new Shared_Counter (1); end Initialize; overriding procedure Initialize (Cmd : in out Command) is begin Cmd.Refs := new Shared_Counter (1); end Initialize; ---------- -- Kind -- ---------- function Kind (Cmd : Command) return Command_Kind is begin return Cmd.Cmd; end Kind; ------------ -- Output -- ------------ function Output (Cmd : Command) return Unbounded_String is begin return Cmd.Output; end Output; -------------- -- Send_Ack -- -------------- procedure Send_Ack (Channel : Communication_Channel; Pid : Remote_Id) is begin String'Output (Channel.Channel, Command_Kind'Image (AK) & Image (Pid)); end Send_Ack; ------------------- -- Send_Clean_Up -- ------------------- procedure Send_Clean_Up (Channel : Communication_Channel; Project_Name : String) is begin String'Output (Channel.Channel, Command_Kind'Image (CU) & Project_Name); end Send_Clean_Up; ------------------ -- Send_Context -- ------------------ procedure Send_Context (Channel : Communication_Channel; Target : String; Project_Name : String; Build_Env : String; Sync : Boolean; Hash : String; Included_Artifact_Patterns : String) is begin String'Output (Channel.Channel, Command_Kind'Image (CX) & Target & Args_Sep & Project_Name & Args_Sep & Build_Env & Args_Sep & Boolean'Image (Sync) & Args_Sep & String (GPR.Util.UTC_Time) & Args_Sep & Gpr_Version_String (Host => False) & Args_Sep & Hash & Args_Sep & Included_Artifact_Patterns); end Send_Context; ----------------------------- -- Send_End_Of_Compilation -- ----------------------------- procedure Send_End_Of_Compilation (Channel : Communication_Channel) is begin String'Output (Channel.Channel, Command_Kind'Image (EC)); end Send_End_Of_Compilation; --------------------------- -- Send_End_Of_File_List -- --------------------------- procedure Send_End_Of_File_List (Channel : Communication_Channel) is begin String'Output (Channel.Channel, Command_Kind'Image (ES)); end Send_End_Of_File_List; --------------- -- Send_Exec -- --------------- procedure Send_Exec (Channel : Communication_Channel; Project : String; Dir : String; Language : String; Target : String; Runtime : String; Options : String_Vectors.Vector; Obj_Name : String; Dep_Name : String; Env : String; Filter : access function (Str, Sep : String) return String := null) is function Filter_Wrapper (Str, Sep : String) return String is (if Filter = null then Str else Filter (Str, Sep)); R_Cmd : Unbounded_String; begin -- Options are serialized into a string and separated with Opts_Sep for K in Options.First_Index .. Options.Last_Index loop Append (R_Cmd, Filter_Wrapper (Options (K), WD_Path_Tag)); if K /= Options.Last_Index then Append (R_Cmd, Opts_Sep); end if; end loop; -- Send the command over the channel String'Output (Channel.Channel, Command_Kind'Image (EX) & Filter_Wrapper (Project, WD_Path_Tag) & Args_Sep & Dir & Args_Sep & Language & Args_Sep & Target & Args_Sep & Runtime & Args_Sep & Obj_Name & Args_Sep & Dep_Name & Args_Sep & To_String (R_Cmd) & Args_Sep & Filter_Wrapper (Env, WD_Path_Tag)); end Send_Exec; --------------- -- Send_File -- --------------- procedure Send_File (Channel : Communication_Channel; Path_Name : String; Rewrite : Boolean; Keep_Time_Stamp : Boolean := False) is Time_Stamp : Time_Stamp_Type := Empty_Time_Stamp; begin if Keep_Time_Stamp then Time_Stamp := GPR.Util.To_UTC_Time_Stamp (Modification_Time (Path_Name)); end if; if Rewrite then Send_File_Internal (Channel, Path_Name, FL, Time_Stamp); else if Exists (Path_Name) then String'Output (Channel.Channel, Command_Kind'Image (FR) & Translate_Send (Channel, Path_Name) & (if Keep_Time_Stamp then Args_Sep & String (Time_Stamp) else "")); Send_RAW_File_Content (Channel, Path_Name); end if; end if; end Send_File; ---------------- -- Sync_Files -- ---------------- procedure Sync_Files (Channel : Communication_Channel; Root_Dir : String; Files : File_Data_Set.Vector) is begin Create_Args : declare Args : Unbounded_String; First : Boolean := True; begin for F of Files loop if First then First := False; else Append (Args, Args_Sep); end if; Append (Args, F.Path_Name); Append (Args, Args_Sep); Append (Args, String (F.Timestamp)); Append (Args, Args_Sep); Append (Args, Boolean'Image (F.Is_Executable)); end loop; String'Output (Channel.Channel, Command_Kind'Image (TS) & To_String (Args)); end Create_Args; declare Cmd : constant Command := Get_Command (Channel); begin if Kind (Cmd) = KO then for Filename of Args (Cmd).all loop Send_RAW_File_Content (Channel, (if Root_Dir = "" then "" else Root_Dir & Directory_Separator) & Filename.all); end loop; end if; end; end Sync_Files; ------------------------ -- Send_File_Internal -- ------------------------ procedure Send_File_Internal (Channel : Communication_Channel; Path_Name : String; Cmd : Command_Kind; Time_Stamp : Time_Stamp_Type) is use Ada.Streams.Stream_IO; procedure Input (Item : out Stream_Element_Array; Last : out Stream_Element_Offset); -- Get input data from file procedure Output (Item : Stream_Element_Array); -- Send data to channel function File_Size return Natural; -- Compute the size of the file as rewritten File : File_Type; F_Size : Natural; Rewriter : Rewrite_Data.Buffer := Rewrite_Data.Create (To_String (Channel.WD_From), To_String (Channel.WD_To)); Rewriter_CD : aliased Rewrite_Data.Buffer := Rewrite_Data.Create (To_String (Channel.CD_From), To_String (Channel.CD_To)); --------------- -- File_Size -- --------------- function File_Size return Natural is procedure Count (Item : Stream_Element_Array); -- Count bytes Result : Natural := Natural (Size (Path_Name)); ----------- -- Count -- ----------- procedure Count (Item : Stream_Element_Array) is begin Result := Result + Item'Length; end Count; begin if Channel.WD_From /= Null_Unbounded_String and then Length (Channel.WD_From) <= Result then Result := 0; Rewrite_Data.Rewrite (Rewriter, Input'Access, Count'Access); Reset (File); end if; return Result; end File_Size; ----------- -- Input -- ----------- procedure Input (Item : out Stream_Element_Array; Last : out Stream_Element_Offset) is begin if End_Of_File (File) then Last := 0; else Read (File, Item, Last); end if; end Input; ------------ -- Output -- ------------ procedure Output (Item : Stream_Element_Array) is begin Stream_Element_Array'Write (Channel.Channel, Item); end Output; begin Rewrite_Data.Link (Rewriter, Rewriter_CD'Unchecked_Access); if Exists (Path_Name) then begin Open (File, In_File, Path_Name); -- First compute the file size as translated, note that this -- means that we are parsing the file twice. F_Size := File_Size; String'Output (Channel.Channel, Command_Kind'Image (Cmd) & Image (F_Size) & Args_Sep & Translate_Send (Channel, Path_Name) & (if Time_Stamp /= Empty_Time_Stamp then Args_Sep & String (Time_Stamp) else "")); if F_Size /= 0 then Rewrite_Data.Rewrite (Rewriter, Input'Access, Output'Access); end if; Close (File); exception when others => if Is_Open (File) then Close (File); end if; end; else raise Constraint_Error with "File not found : " & Path_Name; end if; end Send_File_Internal; -------------------- -- Set_File_Stamp -- -------------------- procedure Set_File_Stamp (Path_Name : String; Time_Stamp : Time_Stamp_Type) is function TS (First, Last : Positive) return Integer is (Integer'Value (String (Time_Stamp (First .. Last)))); -- Converts substring from Time_Stamp to Integer begin Set_File_Last_Modify_Time_Stamp (Path_Name, To_Ada (time_t (Conversions.To_Unix_Time (Time_Of (TS (1, 4), TS (5, 6), TS (7, 8), TS (9, 10), TS (11, 12), TS (13, 14)))))); end Set_File_Stamp; ----------------------- -- Send_Info_Request -- ----------------------- procedure Send_Info_Request (Channel : Communication_Channel) is begin String'Output (Channel.Channel, Command_Kind'Image (IR)); end Send_Info_Request; ------------------------ -- Send_Info_Response -- ------------------------ procedure Send_Info_Response (Channel : Communication_Channel; Version_String : String; Current_UTC_Time : Stamps.Time_Stamp_Type; GPR_Hash : String) is begin String'Output (Channel.Channel, Command_Kind'Image (OK) & Version_String & Args_Sep & String (Current_UTC_Time) & Args_Sep & GPR_Hash); end Send_Info_Response; ------------- -- Send_Ko -- ------------- procedure Send_Ko (Channel : Communication_Channel; Pid : Compilation.Remote_Id) is begin String'Output (Channel.Channel, Command_Kind'Image (KO) & Image (Pid)); end Send_Ko; procedure Send_Ko (Channel : Communication_Channel; Message : String := "") is begin String'Output (Channel.Channel, Command_Kind'Image (KO) & Message); end Send_Ko; procedure Send_Ko (Channel : Communication_Channel; Files : File_Data_Set.Vector) is Args : Unbounded_String; First : Boolean := True; begin for F of Files loop if First then First := False; else Append (Args, Args_Sep); end if; Append (Args, To_String (F.Path_Name)); end loop; String'Output (Channel.Channel, Command_Kind'Image (KO) & To_String (Args)); end Send_Ko; ------------- -- Send_Ok -- ------------- procedure Send_Ok (Channel : Communication_Channel; Pid : Compilation.Remote_Id) is begin String'Output (Channel.Channel, Command_Kind'Image (OK) & Image (Pid)); end Send_Ok; procedure Send_Ok (Channel : Communication_Channel) is begin String'Output (Channel.Channel, Command_Kind'Image (OK)); end Send_Ok; ----------------- -- Send_Output -- ----------------- procedure Send_Output (Channel : Communication_Channel; File_Name : String) is begin Send_File_Internal (Channel, File_Name, DP, Empty_Time_Stamp); end Send_Output; ------------------------ -- Send_Ping_Response -- ------------------------ procedure Send_Ping_Response (Channel : Communication_Channel; Version_String : String; Current_UTC_Time : Stamps.Time_Stamp_Type; GPR_Hash : String) is begin String'Output (Channel.Channel, Command_Kind'Image (OK) & Version_String & ASCII.GS & String (Current_UTC_Time) & ASCII.GS & GPR_Hash); end Send_Ping_Response; --------------------------- -- Send_RAW_File_Content -- --------------------------- procedure Send_RAW_File_Content (Channel : Communication_Channel; Path_Name : String) is type Buffer_Access is access Stream_Element_Array; procedure Unchecked_Free is new Unchecked_Deallocation (Stream_Element_Array, Buffer_Access); Buffer : Buffer_Access; Last : Stream_Element_Offset; Sent : Stream_Element_Offset; File : Stream_IO.File_Type; begin Buffer := new Stream_Element_Array (1 .. Buffer_Size); -- A somewhat large buffer is needed to transfer big file efficiently. -- Here we use a buffer which should be large enough for read most file -- contents in one OS call. -- -- This is allocated on the heap to avoid too much pressure on the -- stack of the tasks. -- Open the file in shared mode as multiple tasks could have -- to send it. Stream_IO.Open (File, Stream_IO.In_File, Path_Name, Form => "shared=yes"); -- Always send an empty stream element array at the end. -- This is used as EOF tag. loop Stream_IO.Read (File, Buffer.all, Last); -- Send the chunk size Stream_Element_Offset'Write (Channel.Channel, Last); exit when Last = 0; -- Send the chunk data Sent := 1; loop Send_Socket (Channel.Sock, Buffer (Sent .. Last), Sent); exit when Sent = Last; Sent := Sent + 1; end loop; end loop; Stream_IO.Close (File); Unchecked_Free (Buffer); exception when others => if Stream_IO.Is_Open (File) then Stream_IO.Close (File); end if; Unchecked_Free (Buffer); raise; end Send_RAW_File_Content; ----------------------- -- Send_Slave_Config -- ----------------------- procedure Send_Slave_Config (Channel : Communication_Channel; Max_Process : Positive; Root_Directory : String; Clock_Status : Boolean) is begin String'Output (Channel.Channel, Command_Kind'Image (OK) & Image (Max_Process) & Args_Sep & Root_Directory & Args_Sep & Boolean'Image (Clock_Status)); end Send_Slave_Config; ----------------------- -- Send_Sync_Request -- ----------------------- procedure Send_Sync_Request (Channel : Communication_Channel) is begin String'Output (Channel.Channel, Command_Kind'Image (SY)); end Send_Sync_Request; -------------------- -- Set_Rewrite_CD -- -------------------- procedure Set_Rewrite_CD (Channel : in out Communication_Channel; Path : String) is P : String := Normalize_Pathname (Path, Case_Sensitive => not On_Windows); begin if On_Windows then -- On Windows the mapping file contains non normalized pathname. The -- format is an upper-case driver letter, all the remaining of the -- path is lower-case and the directory separator is a slash. We -- ensure that the compiler path registered follows this format -- to properly rewrite the runtime path in the mapping file. P (P'First) := Characters.Handling.To_Upper (P (P'First)); P := Strings.Fixed.Translate (P, Strings.Maps.To_Mapping ("\", "/")); end if; Channel.CD_From := To_Unbounded_String (P); Channel.CD_To := To_Unbounded_String (CD_Path_Tag); end Set_Rewrite_CD; -------------------- -- Set_Rewrite_WD -- -------------------- procedure Set_Rewrite_WD (Channel : in out Communication_Channel; Path : String) is begin Channel.WD_From := To_Unbounded_String (Path); Channel.WD_To := To_Unbounded_String (WD_Path_Tag); end Set_Rewrite_WD; ---------- -- Sock -- ---------- function Sock (Channel : Communication_Channel) return Socket_Type is begin return Channel.Sock; end Sock; ----------------------- -- Translate_Receive -- ----------------------- function Translate_Receive (Channel : Communication_Channel; Str : String) return String is P : constant Natural := Index (Str, To_String (Channel.WD_To)); begin if P = 0 then return Str; else -- Make sure we translate the filename to native directory seprator return To_Native_Directory_Separator (To_String (Channel.WD_From) & Str (P + Length (Channel.WD_To) .. Str'Last)); end if; end Translate_Receive; -------------------- -- Translate_Send -- -------------------- function Translate_Send (Channel : Communication_Channel; Str : String) return String is P : constant Natural := Index (Str, To_String (Channel.WD_From)); begin if P = 0 then return Str; else return To_String (Channel.WD_To) & Str (P + Length (Channel.WD_From) .. Str'Last); end if; end Translate_Send; end GPR.Compilation.Protocol; gprbuild-25.0.0/gpr/src/gpr-compilation-protocol.ads000066400000000000000000000316751470075373400224470ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2012-2020, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with GNAT.OS_Lib; use GNAT; with GNAT.Sockets; use GNAT.Sockets; with GPR.Util; use GPR.Util; private with Ada.Finalization; package GPR.Compilation.Protocol is Wrong_Command : exception; -- Raised when a command cannot be parsed WD_Path_Tag : constant String := "<1>"; -- The string replacing root working diretory of full path name, see -- Set_Rewrite below. CD_Path_Tag : constant String := "<2>"; -- The string replacing the compiler root directory, see Set_Rewrite below Any_OS : constant String := "any"; -- Used when OS check is not necessary, for example gprclean does not need -- this check. It is safe to clean-up a Solaris slave from a Windows -- master. -- -- Communication -- type Communication_Channel is tagged private; -- A communication channel, this channel is used for any communication -- between the build master and the slaves. No_Channel : constant Communication_Channel; function Create (Sock : Socket_Type; Virtual : Boolean := False) return Communication_Channel; -- Create a communication channel. If Virtual is True it only creates a -- virtual channel which cannot be used as a regular channel. This is -- meant to be used as a key for comparing against another channel. function Sock (Channel : Communication_Channel) return Socket_Type; pragma Inline (Sock); procedure Close (Channel : in out Communication_Channel); -- Close the channel procedure Set_Rewrite_WD (Channel : in out Communication_Channel; Path : String); -- Add rewrite information for the working directory. This is needed to -- translate paths to/from build master and slave working directories. procedure Set_Rewrite_CD (Channel : in out Communication_Channel; Path : String); -- Add rewrite information for the compiler directory. This is needed to -- translate paths to/from compilers path in build master and in slave. -- This is needed to be able to find the files from other projects -- installed with the compiler. The translated paths are in the -- gprbuild mapping file. procedure Clear_Rewrite (Channel : in out Communication_Channel); -- Remove any rewrite information from the channel function Translate_Receive (Channel : Communication_Channel; Str : String) return String; -- Translate Str using Channel rewrite function Translate_Send (Channel : Communication_Channel; Str : String) return String; -- Translate Str using Channel rewrite -- -- Command -- type Command is tagged private; type Command_Kind is (EX, -- execute a command AK, -- acknowledge received command (with pid) TS, -- a file timestamp ES, -- end of file timestamp FL, -- a file, content being rewritten from builder/slave PATH FR, -- a RAW file, no rewrite taking place OK, -- compilation ok (with optional pid) KO, -- compilation failed (with optional pid) CX, -- master context CU, -- clean-up request DP, -- display output EC, -- end of compilation SI, -- a signal as been detected (like EC but no ACK needed) SY, -- synchronization requested IR, -- information requested PG); -- PING just to know if the slave is listening function Kind (Cmd : Command) return Command_Kind; pragma Inline (Kind); function Args (Cmd : Command) return OS_Lib.Argument_List_Access; pragma Inline (Args); -- Returns all arguments for Cmd function Output (Cmd : Command) return Unbounded_String; pragma Inline (Output); -- Returns the output for a DP command function Get_Command (Channel : Communication_Channel'Class) return Command; -- Wait and return a command as parsed from the communication channel Invalid_Pid : constant := -1; -- -- From GPRbuild / GPRremote -- procedure Send_Context (Channel : Communication_Channel; Target : String; Project_Name : String; Build_Env : String; Sync : Boolean; Hash : String; Included_Artifact_Patterns : String); -- Send initial context to the slave procedure Send_Exec (Channel : Communication_Channel; Project : String; Dir : String; Language : String; Target : String; Runtime : String; Options : String_Vectors.Vector; Obj_Name : String; Dep_Name : String; Env : String; Filter : access function (Str, Sep : String) return String := null); -- Send a compilation job to a slave. The compilation must be done on -- Dir. This directory is specified relative to the root directory of -- the sources. Dep_Name is the dependency file that is generated by this -- compilation and which must be sent back to the build master after the -- compilation. Filter is a function used to make path on the command line -- all relatives to the root directory. The build master root in full path -- is replaced by Full_Path_Tag. The slaves will change back this tag to -- the actual full path on their working environment. The Env string is a -- set of environment variables (name=value[;name=value]) to set before -- spawning the process. -- If Language is empty, this is not a compilation based on a specific -- language. In this case the command in Options (Options'First) is to be -- executed as-is. procedure Send_File (Channel : Communication_Channel; Path_Name : String; Rewrite : Boolean; Keep_Time_Stamp : Boolean := False); -- Path_Name is the full path name to the local filename procedure Sync_Files (Channel : Communication_Channel; Root_Dir : String; Files : File_Data_Set.Vector); -- Send a set of filenames and associated timestamps. Will receive a OK or -- KO with the list of files to be transferred to the slave. procedure Send_End_Of_Compilation (Channel : Communication_Channel); -- Send an end of compilation signal, the slave will at this point be able -- to get jobs from another build master (Get_Context). procedure Send_End_Of_File_List (Channel : Communication_Channel); -- Send an end of file list signal, it means that all files timestamps have -- been checked. After this the compilation can be started. procedure Get_Pid (Channel : Communication_Channel; Pid : out Remote_Id; Success : out Boolean); -- Get a process id, Success is set to False in case of failure procedure Send_Clean_Up (Channel : Communication_Channel; Project_Name : String); -- Send a clean-up requets to the slave procedure Send_Sync_Request (Channel : Communication_Channel); -- Send a sync request to the slave procedure Send_Info_Request (Channel : Communication_Channel); -- Send a info request to the slave procedure Get_Info_Response (Channel : Communication_Channel; Version_String : out Unbounded_String; Current_UTC_Time : out Stamps.Time_Stamp_Type; GPR_Hash : out Unbounded_String; Success : out Boolean); -- Read and return the info sent from the slave -- -- From GPRslave -- procedure Get_Context (Channel : Communication_Channel; Target : out Unbounded_String; Project_Name : out Unbounded_String; Build_Env : out Unbounded_String; Sync : out Boolean; Timestamp : out Time_Stamp_Type; Version : out Unbounded_String; Hash : out Unbounded_String; Included_Artifact_Patterns : out Unbounded_String; Is_Ping : out Boolean); -- Wait for an initial context from a build master procedure Send_Slave_Config (Channel : Communication_Channel; Max_Process : Positive; Root_Directory : String; Clock_Status : Boolean); -- Send the slave configuration to the build master procedure Send_Ack (Channel : Communication_Channel; Pid : Remote_Id); -- Send Acknoledgement of a received compilation job procedure Send_Ok (Channel : Communication_Channel; Pid : Remote_Id); -- Send Pid of a successful command procedure Send_Ko (Channel : Communication_Channel; Pid : Remote_Id); -- Send Pid of an un-successful command procedure Send_Ok (Channel : Communication_Channel); -- Send Ok for a successful command (clean-up for example) procedure Send_Ko (Channel : Communication_Channel; Message : String := ""); -- Send Ko to initial handshake (slave not compatible with master for -- example). procedure Send_Ko (Channel : Communication_Channel; Files : File_Data_Set.Vector); -- Send a Ko message with a list of file names procedure Send_Ping_Response (Channel : Communication_Channel; Version_String : String; Current_UTC_Time : Stamps.Time_Stamp_Type; GPR_Hash : String); -- Send a ping response with some environment information procedure Send_Info_Response (Channel : Communication_Channel; Version_String : String; Current_UTC_Time : Stamps.Time_Stamp_Type; GPR_Hash : String); -- Send an information response procedure Send_Output (Channel : Communication_Channel; File_Name : String); -- Send an output of a command procedure Get_RAW_File_Content (Channel : Communication_Channel; Path_Name : String; Timestamp : Time_Stamp_Type := Empty_Time_Stamp); -- Create Path_Name from data received from the channel. The data must be -- sent by Send_RAW_File_Content to have the correct format. If specified -- the file's timestamp is set. private use Ada; type Communication_Channel is new Finalization.Controlled with record Sock : Socket_Type; Channel : Stream_Access; WD_From, WD_To : Unbounded_String; -- working directory CD_From, CD_To : Unbounded_String; -- compiler directory Refs : Shared_Counter_Access; end record; overriding procedure Initialize (Channel : in out Communication_Channel); overriding procedure Adjust (Channel : in out Communication_Channel); overriding procedure Finalize (Channel : in out Communication_Channel); No_Channel : constant Communication_Channel := (Finalization.Controlled with Sock => No_Socket, Channel => null, Refs => new Shared_Counter (1), others => Null_Unbounded_String); type Command is new Finalization.Controlled with record Cmd : Command_Kind; Args : Argument_List_Access; Output : Unbounded_String; Refs : Shared_Counter_Access; end record; overriding procedure Initialize (Cmd : in out Command); overriding procedure Adjust (Cmd : in out Command); overriding procedure Finalize (Cmd : in out Command); end GPR.Compilation.Protocol; gprbuild-25.0.0/gpr/src/gpr-compilation-slave.adb000066400000000000000000001033511470075373400216660ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2012-2021, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Calendar; use Ada.Calendar; with Ada.Directories; use Ada.Directories; with Ada.Exceptions; use Ada.Exceptions; with Ada.Numerics.Float_Random; use Ada.Numerics.Float_Random; with Ada.Strings.Fixed; use Ada.Strings.Fixed; with Ada.Strings.Maps.Constants; use Ada.Strings; with Ada.Text_IO; use Ada.Text_IO; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.Sockets; use GNAT; use GNAT.Sockets; with GNAT.String_Split; use GNAT.String_Split; with GPR.Compilation.Process; with GPR.Conf; with GPR.Names; use GPR.Names; with GPR.Opt; use GPR.Opt; with GPR.Snames; use GPR.Snames; package body GPR.Compilation.Slave is type Slave is record Sock : Integer; Data : Slave_Data; Channel : Communication_Channel; Current : Natural := 0; Max_Processes : Positive := 1; Root_Dir : Unbounded_String; Rsync_Pid : Process_Id; end record; function "<" (K1, K2 : Slave) return Boolean is (K1.Sock < K2.Sock); function "=" (K1, K2 : Slave) return Boolean is (K1.Sock = K2.Sock); No_Slave : constant Slave := (-1, No_Slave_Data, Current => Natural'Last, others => <>); package Slave_S is new Containers.Ordered_Sets (Slave); -- The key is the C socket number function Connect_Slave (S_Data : Slave_Data; Project_Name : String; Sync : Boolean; Included_Artifact_Patterns : String := "") return Slave; -- Connect to the slave and return the corresponding object function Parse (Host_Name : String) return Slave_Data; -- Parse a host[:port] string and returns corresponding Slave_Data record -- Ack transient signal stored into this variable protected Wait_Ack is procedure Set (Pid : Remote_Id); entry Get (Pid : out Remote_Id); private Is_Set : Boolean := False; Id : Remote_Id; end Wait_Ack; task type Wait_Remote; -- Wait for incoming data from all registered slaves type Wait_Remote_Ref is access Wait_Remote; WR : Wait_Remote_Ref; -- Will be initialized only if the distributed mode is activated Compiler_Path : constant OS_Lib.String_Access := Locate_Exec_On_Path ("gnatls"); Remote_Process : Shared_Counter; Slaves_Sockets : Socket_Set_Type; Max_Processes : Natural := 0; R_Gen : Generator; protected Slaves is procedure Insert (S : Slave); -- Add a slave into the pool function Find (Socket : Integer) return Slave; -- Find a slave given the socket number function Find (Host : String) return Slave; -- Find a slave give a host[:port] name function Get_Free return Slave; -- Returns a slave with free compilation slot function Count return Natural; -- Returns the number of registered slaves procedure Increment_Current (S : in out Slave); -- Increment the number of processes handled by slave procedure Decrement_Current (S : in out Slave); -- Decrement the number of processes handled by slave procedure Set_Rewrite_CD (S : in out Slave; Path : String); -- Record rewriting of the compiler directory procedure Set_Rewrite_WD (S : in out Slave; Path : String); -- Record rewriting of the wording directory procedure Iterate (Proc : access procedure (S : in out Slave)); -- Iterate over all slaves in the pool and call proc procedure Clear; -- Clear the pool private Pool : Slave_S.Set; end Slaves; ------------- -- Channel -- ------------- function Channel (Host : String) return Protocol.Communication_Channel is S : constant Slave := Slaves.Find (Host); begin if S = No_Slave then return No_Channel; else return S.Channel; end if; end Channel; ---------------------------- -- Clean_Up_Remote_Slaves -- ---------------------------- procedure Clean_Up_Remote_Slaves (Tree : Project_Tree_Ref; Project : Project_Id) is pragma Unreferenced (Tree); procedure Clean_Up_Remote_Slave (S_Data : Slave_Data; Project_Name : String); -- Clean-up slave --------------------------- -- Clean_Up_Remote_Slave -- --------------------------- procedure Clean_Up_Remote_Slave (S_Data : Slave_Data; Project_Name : String) is S : Slave; begin S := Connect_Slave (S_Data, Project_Name, Sync => False); -- Send the clean-up request Protocol.Send_Clean_Up (S.Channel, Project_Name); declare Cmd : constant Command := Get_Command (S.Channel); begin if Kind (Cmd) = OK then if Opt.Verbosity_Level > Opt.Low then Put_Line ("Clean-up done on " & To_String (S_Data.Host)); end if; elsif Kind (Cmd) = KO then Put_Line ("Slave cannot clean-up " & To_String (S_Data.Host)); OS_Exit (1); else Put_Line ("protocol error: " & Command_Kind'Image (Kind (Cmd))); OS_Exit (1); end if; end; Protocol.Send_End_Of_Compilation (S.Channel); -- Wait for acknowledge to ensure the clean-up is terminated on the -- slave. declare Cmd : constant Command := Get_Command (S.Channel) with Unreferenced; begin null; end; Close (S.Channel); exception when others => Close (S.Channel); end Clean_Up_Remote_Slave; begin for S of Slaves_Data loop Clean_Up_Remote_Slave (S, Get_Name_String (Project.Name)); end loop; end Clean_Up_Remote_Slaves; ------------------- -- Connect_Slave -- ------------------- function Connect_Slave (S_Data : Slave_Data; Project_Name : String; Sync : Boolean; Included_Artifact_Patterns : String := "") return Slave is Address : Sock_Addr_Type; Sock : Socket_Type; S : Slave; Status : Selector_Status; begin S.Data := S_Data; if S.Data.Host = Null_Unbounded_String then Put_Line ("A slave must have a name, aborting"); OS_Exit (1); end if; Address.Addr := Addresses (Get_Host_By_Name (To_String (S.Data.Host)), 1); Address.Port := S_Data.Port; Create_Socket (Sock); Set_Socket_Option (Sock, Socket_Level, (Reuse_Address, True)); begin Connect_Socket (Sock, Address, Timeout => 2.0, Status => Status); exception when Socket_Error => Put_Line ("Cannot connect to slave " & To_String (S.Data.Host) & ", aborting"); raise; end; if Status in Expired .. Aborted then Put_Line ("Cannot connect to slave " & To_String (S.Data.Host) & ", aborting"); OS_Exit (1); end if; S.Channel := Create (Sock); -- Do initial handshake Protocol.Send_Context (S.Channel, Get_Target, Project_Name, Slave_Env.all, Sync, (if Hash_Value = null then "" else Hash_Value.all), Included_Artifact_Patterns); declare Cmd : constant Command := Get_Command (S.Channel); Parameters : constant Argument_List_Access := Args (Cmd); begin if Kind (Cmd) = OK and then Parameters'Length = 3 then S.Max_Processes := Natural'Value (Parameters (1).all); S.Root_Dir := To_Unbounded_String (Parameters (2).all); if not Boolean'Value (Parameters (3).all) then Put_Line ("warning: non synchronized clock detected for " & To_String (S.Data.Host)); end if; elsif Kind (Cmd) = KO then Put_Line ((if Parameters'Length = 1 and then Parameters (1).all /= "" then Parameters (1).all else "build slave is not compatible") & " : " & To_String (S.Data.Host)); OS_Exit (1); else Put_Line ("protocol error: " & Command_Kind'Image (Kind (Cmd))); OS_Exit (1); end if; end; return S; end Connect_Slave; ----------------------- -- Get_Max_Processes -- ----------------------- function Get_Max_Processes return Natural is begin return Max_Processes; end Get_Max_Processes; ----------- -- Parse -- ----------- function Parse (Host_Name : String) return Slave_Data is V : String renames Host_Name; I : constant Natural := Index (V, ":"); Host : Unbounded_String; Port : Port_Type := Default_Port; begin -- Get for port if I = 0 then Host := To_Unbounded_String (V (V'First .. V'Last)); else Host := To_Unbounded_String (V (V'First .. I - 1)); declare Port_Str : constant String := V (I + 1 .. V'Last); begin if Strings.Maps.Is_Subset (Maps.To_Set (Port_Str), Maps.Constants.Decimal_Digit_Set) then Port := Port_Type'Value (V (I + 1 .. V'Last)); else return No_Slave_Data; end if; end; end if; return Slave_Data'(Host, Port); end Parse; ------------------- -- Record_Slaves -- ------------------- procedure Record_Slaves (Option : String) is S : Slice_Set; procedure Parse_Build_Slave (V : String); -- Parse the build slave V ----------------------- -- Parse_Build_Slave -- ----------------------- procedure Parse_Build_Slave (V : String) is S_Data : constant Slave_Data := Parse (V); begin if S_Data = No_Slave_Data then Put_Line ("error: invalid port value in " & V); OS_Exit (1); else Slaves_Data.Append (S_Data); end if; end Parse_Build_Slave; begin Create (S, Option, ","); for K in 1 .. Slice_Count (S) loop Parse_Build_Slave (Slice (S, K)); end loop; end Record_Slaves; --------------------------- -- Register_Remote_Slave -- --------------------------- procedure Register_Remote_Slave (S_Data : Slave_Data; Project_Name : String; Excluded_Patterns : Sync.Str_Vect.Vector; Included_Patterns : Sync.Str_Vect.Vector; Included_Artifact_Patterns : Sync.Str_Vect.Vector; Synchronize : Boolean) is S : Slave; IAP : Unbounded_String; begin for P of Included_Artifact_Patterns loop if IAP /= Null_Unbounded_String then Append (IAP, ";"); end if; Append (IAP, P); end loop; S := Connect_Slave (S_Data, Project_Name, Sync => Synchronize, Included_Artifact_Patterns => To_String (IAP)); Set (Slaves_Sockets, Sock (S.Channel)); -- Sum the Max_Process values Max_Processes := Max_Processes + S.Max_Processes; if Opt.Verbosity_Level > Opt.Low then Put ("Register slave " & To_String (S_Data.Host) & ","); Put (Integer'Image (S.Max_Processes)); Put_Line (" process(es)"); Put_Line (" location: " & To_String (S.Root_Dir)); end if; -- Let's double check that Root_Dir and Projet_Name are not empty, -- this is a safety check to avoid rsync destroying remote environment -- as rsync is using the --delete options. if Length (S.Root_Dir) = 0 then Put_Line ("error: Root_Dir cannot be empty"); OS_Exit (1); end if; if Project_Name = "" then Put_Line ("error: Project_Name cannot be empty"); OS_Exit (1); end if; if Synchronize then Compilation.Sync.Send_Files (Channel => S.Channel, Root_Dir => To_String (Root_Dir), Included_Patterns => Included_Patterns, Excluded_Patterns => Excluded_Patterns, Mode => Sync.To_Slave); end if; -- Now that all slave's data is known and set, record it S.Sock := To_C (Sock (S.Channel)); Slaves.Insert (S); exception when Host_Error => raise Constraint_Error with "cannot connect to " & To_String (S_Data.Host); end Register_Remote_Slave; ---------------------------- -- Register_Remote_Slaves -- ---------------------------- procedure Register_Remote_Slaves (Tree : Project_Tree_Ref; Project : Project_Id) is use type Containers.Count_Type; Start, Stop : Calendar.Time; procedure Insert (V : out Sync.Str_Vect.Vector; Values : String_List_Id); -- Inserts all values into the vector Excluded_Patterns : Sync.Str_Vect.Vector; Included_Patterns : Sync.Str_Vect.Vector; Included_Artifact_Patterns : Sync.Str_Vect.Vector; ------------ -- Insert -- ------------ procedure Insert (V : out Sync.Str_Vect.Vector; Values : String_List_Id) is Idx : String_List_Id := Values; begin while Idx /= Nil_String loop declare Item : constant String_Element := Tree.Shared.String_Elements.Table (Idx); begin V.Append (Get_Name_String (Item.Value)); Idx := Item.Next; end; end loop; end Insert; Pcks : Package_Table.Table_Ptr renames Tree.Shared.Packages.Table; Pck : Package_Id := Project.Decl.Packages; begin Root_Dir := To_Unbounded_String (Containing_Directory (Get_Name_String (Project.Path.Display_Name))); -- Check for Root_Dir attribute and Excluded_Patterns Look_Remote_Package : while Pck /= No_Package loop if Pcks (Pck).Decl /= No_Declarations and then Pcks (Pck).Name = Name_Remote then declare Id : Variable_Id := Pcks (Pck).Decl.Attributes; begin while Id /= No_Variable loop declare V : constant Variable := Tree.Shared.Variable_Elements.Table (Id); begin if not V.Value.Default then if V.Name = Name_Root_Dir then declare RD : constant String := Get_Name_String (V.Value.Value); begin if Is_Absolute_Path (RD) then Root_Dir := To_Unbounded_String (RD); else Root_Dir := To_Unbounded_String (Normalize_Pathname (To_String (Root_Dir) & Directory_Separator & RD)); end if; if not Exists (To_String (Root_Dir)) or else not Is_Directory (To_String (Root_Dir)) then Put_Line ("error: " & To_String (Root_Dir) & " is not a directory" & " or does not exist"); OS_Exit (1); else Put_Line ("root dir : " & To_String (Root_Dir)); end if; end; elsif V.Name = Name_Excluded_Patterns then Insert (Excluded_Patterns, V.Value.Values); elsif V.Name = Name_Included_Patterns then Insert (Included_Patterns, V.Value.Values); elsif V.Name = Name_Included_Artifact_Patterns then Insert (Included_Artifact_Patterns, V.Value.Values); end if; end if; end; Id := Tree.Shared.Variable_Elements.Table (Id).Next; end loop; end; end if; Pck := Pcks (Pck).Next; end loop Look_Remote_Package; -- Check if Excluded_Patterns and Included_Patterns are set if Included_Patterns.Length /= 0 and then Excluded_Patterns.Length /= 0 then Put_Line ("error: Excluded_Patterns and Included_Patterns are exclusive"); OS_Exit (1); end if; -- Then registers the build slaves Start := Calendar.Clock; for S of Slaves_Data loop Register_Remote_Slave (S, Get_Name_String (Project.Name), Excluded_Patterns, Included_Patterns, Included_Artifact_Patterns, True); end loop; Sync.Wait; Stop := Calendar.Clock; if Opt.Verbosity_Level > Opt.Low then Put (" All data synchronized in "); Put (Duration'Image (Stop - Start)); Put_Line (" seconds"); end if; -- We are in remote mode, the initialization was successful, start tasks -- now. Start_Waiting_Task; end Register_Remote_Slaves; --------- -- Run -- --------- function Run (Project : Project_Id; Language : String; Options : String_Vectors.Vector; Obj_Name : String; Dep_Name : String := ""; Env : String := "") return GPR.Compilation.Id is RD : constant String := To_String (Root_Dir); S : Slave := Slaves.Get_Free; -- Get a free slave for conducting the compilation function Filter_String (O : String; Sep : String := WD_Path_Tag) return String; -- Make O PATH relative to RD. For option -gnatec and -gnatem makes -- the specified filename absolute in the slave environment and send -- the file to the slave. ------------------- -- Filter_String -- ------------------- function Filter_String (O : String; Sep : String := WD_Path_Tag) return String is Pos : constant Natural := Index (O, RD); begin if Pos = 0 then return O; else -- Note that we transfer files only when they are under the -- project root. if O'Length > 8 and then O (O'First .. O'First + 7) in "-gnatem=" | "-gnatec=" then -- Send the corresponding file to the slave declare File_Name : constant String := O (O'First + 8 .. O'Last); begin if Exists (File_Name) then Send_File (S.Channel, File_Name, Rewrite => True, Keep_Time_Stamp => True); else Put_Line ("File not found " & File_Name); Put_Line ("Please check that Built_Root is properly set"); end if; return O (O'First .. O'First + 7) & Translate_Send (S.Channel, File_Name); end; elsif O'Length > 7 and then O (O'First .. O'First + 6) = "-specs=" then -- Send the corresponding file to the slave declare File_Name : constant String := O (O'First + 7 .. O'Last); File : Text_IO.File_Type; Line : String (1 .. 2_048); Last : Natural; begin if Exists (File_Name) then Send_File (S.Channel, File_Name, Rewrite => True, Keep_Time_Stamp => True); -- And now send the spec filename in the second line Text_IO.Open (File, Text_IO.In_File, File_Name); Text_IO.Skip_Line (File); Text_IO.Get_Line (File, Line, Last); Text_IO.Close (File); -- A spec filename starts with '+ @', so 3 characters declare Filename_Offset : constant := 3; Spec_Filename : constant String := Line (1 + Filename_Offset .. Last); begin if Exists (Spec_Filename) then Send_File (S.Channel, Spec_Filename, Rewrite => True, Keep_Time_Stamp => True); else Put_Line ("Spec file not found " & Spec_Filename); Put_Line ("Please check that Built_Root is properly set"); end if; end; else Put_Line ("File not found " & File_Name); Put_Line ("Please check that Built_Root is properly set"); end if; return O (O'First .. O'First + 6) & Translate_Send (S.Channel, File_Name); end; end if; return O (O'First .. Pos - 1) & Sep & Filter_String (O (Pos + RD'Length + 1 .. O'Last)); end if; end Filter_String; Lang_Id : constant Name_Id := Get_Name_Id (Language); Pid : Remote_Id; begin -- Record the rewrite information for this channel Slaves.Set_Rewrite_WD (S, Path => RD); if Compiler_Path /= null then Slaves.Set_Rewrite_CD (S, Path => Containing_Directory (Containing_Directory (Compiler_Path.all))); end if; Send_Exec (S.Channel, Get_Name_String (Project.Path.Display_Name), Filter_String (Get_Current_Dir, Sep => ""), Language, Opt.Target_Value.all, Conf.Runtime_Name_For (Lang_Id), Options, Obj_Name, Dep_Name, Env, Filter_String'Access); Remote_Process.Increment; -- Wait for the Ack from the remote host, this is set by the Wait_Remote -- task. Wait_Ack.Get (Pid); return Process.Create_Remote (Pid); exception when E : others => Put_Line ("Unexpected exception: " & Exception_Information (E)); OS_Exit (1); end Run; ------------ -- Slaves -- ------------ protected body Slaves is -------------------- -- Change_Current -- -------------------- procedure Change_Current (S : in out Slave; Value : Integer) is Position : constant Slave_S.Cursor := Pool.Find (S); begin Pool (Position).Current := Pool (Position).Current + Value; end Change_Current; ----------- -- Clear -- ----------- procedure Clear is begin Pool.Clear; end Clear; ----------- -- Count -- ----------- function Count return Natural is begin return Natural (Pool.Length); end Count; ----------------------- -- Decrement_Current -- ----------------------- procedure Decrement_Current (S : in out Slave) is begin Change_Current (S, -1); end Decrement_Current; ---------- -- Find -- ---------- function Find (Socket : Integer) return Slave is S : constant Slave := (Sock => Socket, others => <>); Position : constant Slave_S.Cursor := Pool.Find (S); begin if Slave_S.Has_Element (Position) then return Slave_S.Element (Position); else return No_Slave; end if; end Find; function Find (Host : String) return Slave is S_Data : constant Slave_Data := Parse (Host); begin for S of Pool loop if S.Data = S_Data then return S; end if; end loop; return No_Slave; end Find; -------------- -- Get_Free -- -------------- function Get_Free return Slave is use type Containers.Count_Type; S_Count : constant Containers.Count_Type := Pool.Length; Index : constant Positive := Natural (Float (S_Count - 1) * Random (R_Gen)) + 1; -- Index of the slave to return if available Result : Slave := No_Slave; K : Positive := 1; begin -- We want to have a random pick of one slave Search_Slaves : for S of Pool loop if S.Current < S.Max_Processes then Result := S; -- Slave is ready and this is the one picked-up randomly, stop -- searching now. exit Search_Slaves when K = Index; end if; K := K + 1; -- We are past the random slave and we have found one slave ready, -- stop search here. exit Search_Slaves when K > Index and Result /= No_Slave; end loop Search_Slaves; return Result; end Get_Free; ----------------------- -- Increment_Current -- ----------------------- procedure Increment_Current (S : in out Slave) is begin Change_Current (S, 1); end Increment_Current; ------------ -- Insert -- ------------ procedure Insert (S : Slave) is begin Pool.Insert (S); end Insert; ------------- -- Iterate -- ------------- procedure Iterate (Proc : access procedure (S : in out Slave)) is begin for C in Pool.Iterate loop declare S : Slave := Slave_S.Element (C); begin Proc (S); Pool.Replace_Element (C, S); end; end loop; end Iterate; -------------------- -- Set_Rewrite_CD -- -------------------- procedure Set_Rewrite_CD (S : in out Slave; Path : String) is Position : constant Slave_S.Cursor := Pool.Find (S); begin Set_Rewrite_CD (Pool (Position).Channel, Path => Path); S := Pool (Position); end Set_Rewrite_CD; -------------------- -- Set_Rewrite_WD -- -------------------- procedure Set_Rewrite_WD (S : in out Slave; Path : String) is Position : constant Slave_S.Cursor := Pool.Find (S); begin Set_Rewrite_WD (Pool (Position).Channel, Path => Path); S := Pool (Position); end Set_Rewrite_WD; end Slaves; ------------------------ -- Start_Waiting_Task -- ------------------------ procedure Start_Waiting_Task is begin if WR = null then WR := new Wait_Remote; end if; end Start_Waiting_Task; ------------------------------ -- Unregister_Remote_Slaves -- ------------------------------ procedure Unregister_Remote_Slaves (From_Signal : Boolean := False) is procedure Unregister (S : in out Slave); -- Unregister given slave Start, Stop : Time; ---------------- -- Unregister -- ---------------- procedure Unregister (S : in out Slave) is begin if not From_Signal then Send_End_Of_Compilation (S.Channel); -- Wait for acknowledge to ensure the clean-up is terminated on -- on the slave. declare Cmd : constant Command := Get_Command (S.Channel) with Unreferenced; begin null; end; end if; Close (S.Channel); exception when others => Close (S.Channel); end Unregister; begin Start := Clock; Slaves.Iterate (Unregister'Access); if not From_Signal then Sync.Wait; end if; Stop := Clock; if not From_Signal and then Opt.Verbosity_Level > Opt.Low and then Slaves.Count > 0 then Put (" All data synchronized in "); Put (Duration'Image (Stop - Start)); Put_Line (" seconds"); end if; Slaves.Clear; end Unregister_Remote_Slaves; -------------- -- Wait_Ack -- -------------- protected body Wait_Ack is --------- -- Set -- --------- procedure Set (Pid : Remote_Id) is begin Id := Pid; Is_Set := True; end Set; --------- -- Get -- --------- entry Get (Pid : out Remote_Id) when Is_Set is begin Pid := Id; Is_Set := False; end Get; end Wait_Ack; ----------------- -- Wait_Remote -- ----------------- task body Wait_Remote is Proc : Id; Pid : Remote_Id; Selector : Selector_Type; Status : Selector_Status; R_Set, W_Set : Socket_Set_Type; Sock : Socket_Type; S : Slave; begin -- In this task we are only interested by the incoming data, so we do -- not wait on socket ready for writing. Sockets.Empty (W_Set); Create_Selector (Selector); loop -- Let's wait for at least some process to monitor Remote_Process.Wait_Non_Zero; -- Wait for response from all registered slaves Copy (Slaves_Sockets, R_Set); Check_Selector (Selector, R_Set, W_Set, Status); if Status = Completed then Get (R_Set, Sock); pragma Assert (Sock /= No_Socket, "no socket returned by selector"); S := Slaves.Find (To_C (Sock)); if S /= No_Slave then declare Cmd : constant Command := Get_Command (S.Channel); Success : Boolean; begin -- A display output if Kind (Cmd) = DP then -- Write output to the console Put (To_String (Protocol.Output (Cmd))); Get_Pid (S.Channel, Pid, Success); Proc := Process.Create_Remote (Pid); Remote_Process.Decrement; Slaves.Decrement_Current (S); Process.Add_Result (Proc, Success, To_String (S.Data.Host)); -- An acknowledgment of an compilation job elsif Kind (Cmd) = AK then declare Pid : constant Remote_Id := Remote_Id'Value (Args (Cmd)(1).all); begin Slaves.Increment_Current (S); Wait_Ack.Set (Pid); end; elsif Kind (Cmd) in EC | SI then null; else raise Constraint_Error with "Unexpected command: " & Command_Kind'Image (Kind (Cmd)); end if; end; end if; else if Opt.Verbosity_Level = Opt.High then Put_Line ("warning: selector in " & Selector_Status'Image (Status) & " state"); end if; end if; Sockets.Empty (R_Set); end loop; exception when E : others => Put_Line (Exception_Information (E)); OS_Exit (1); end Wait_Remote; end GPR.Compilation.Slave; gprbuild-25.0.0/gpr/src/gpr-compilation-slave.ads000066400000000000000000000132171470075373400217100ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2012-2018, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Containers.Vectors; with Ada.Strings.Unbounded; with GNAT.Sockets; with GPR.Compilation.Protocol; with GPR.Compilation.Sync; with GPR.Util; use GPR.Util; package GPR.Compilation.Slave is use Ada; use Ada.Strings.Unbounded; use GPR.Compilation; use GPR.Compilation.Protocol; procedure Record_Slaves (Option : String); -- Record the slaves as passed on the command line procedure Register_Remote_Slaves (Tree : Project_Tree_Ref; Project : Project_Id); -- Register the slaves describes in Build_Slaves attribute of project's -- Remote package. This routine also initialize the slaves sources. This -- routine must be called before any other in this unit. function Channel (Host : String) return Protocol.Communication_Channel; -- Returns the communication channel for the given host. Returns No_Channel -- if host has not been registered. procedure Clean_Up_Remote_Slaves (Tree : Project_Tree_Ref; Project : Project_Id); -- Send a clean-up request to all remote slaves. The slaves are then asked -- to remove all the sources and build artifacts for the given project. function Run (Project : Project_Id; Language : String; Options : String_Vectors.Vector; Obj_Name : String; Dep_Name : String := ""; Env : String := "") return GPR.Compilation.Id; -- Send a compilation job to one slave that has still some free slot. There -- is also free slot when this routine is called (gprbuild ensure this). procedure Unregister_Remote_Slaves (From_Signal : Boolean := False); -- Unregister all slaves, send them notification about the end of the -- current build. This routine must be called after the compilation phase -- and before the bind and link ones. It is safe to call this routine -- multiple times, the first call will do the clean-up, next calls are -- just no-op. From_Signal must be set when called from a signal, for -- example when calling this routine from the ctrl-c handler. function Get_Max_Processes return Natural; -- Returns the maximum number of processes supported by the compilation -- engine. This is the sum of the parallel local builds as specified by -- the -j option and all the sum of the processes supported by each slaves. -- ??????????????????????????????????????????????????????????????????? -- ??? following routines/types are exposed here to be shared with -- ??? LibGPR2. Should be moved into LibGPR2 body when LibGPR will -- ??? be discontinued. -- ??????????????????????????????????????????????????????????????????? Root_Dir : Unbounded_String; -- Root directory from where the sources are to be synchronized with the -- slaves. This is by default the directory containing the main project -- file. The value is changed with the Root_Dir attribute value of the -- project file's Remote package. type Slave_Data is record Host : Unbounded_String; Port : GNAT.Sockets.Port_Type; end record; No_Slave_Data : constant Slave_Data := (Port => GNAT.Sockets.Port_Type'Last, others => <>); package Slaves_N is new Containers.Vectors (Positive, Slave_Data); Slaves_Data : Slaves_N.Vector; procedure Register_Remote_Slave (S_Data : Slave_Data; Project_Name : String; Excluded_Patterns : Sync.Str_Vect.Vector; Included_Patterns : Sync.Str_Vect.Vector; Included_Artifact_Patterns : Sync.Str_Vect.Vector; Synchronize : Boolean); -- Register a slave living on Host for the given project name. User is -- used when calling rsync, it is the remote machine user name, if empty -- the local user name is used. procedure Start_Waiting_Task; -- Start the remote waiting task if needed end GPR.Compilation.Slave; gprbuild-25.0.0/gpr/src/gpr-compilation-sync.adb000066400000000000000000000437531470075373400215410ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2014-2020, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Containers.Vectors; with Ada.Directories; use Ada.Directories; with Ada.Exceptions; use Ada.Exceptions; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with Ada.Text_IO; use Ada.Text_IO; with GNAT.Regexp; use GNAT.Regexp; with GNAT.Sockets; use GNAT.Sockets; with GPR.Util; use GPR.Util; package body GPR.Compilation.Sync is use Ada; use type Containers.Count_Type; Common_Excluded_Patterns : Str_Vect.Vector; -- Default excluded patterns to use when in excluded mode as opposed to -- include mode where we describe the patterns to include specifically. Artifact_Excluded_Patterns : Str_Vect.Vector; -- Artifacts patterns to exclude Max_Gpr_Sync : constant := 10; -- The number of parallele synchronization done for the gpr protocol. This -- is currenlty fixed to 6 but could probable be a parameter. The number is -- high, as these tasks are mostly doing IO and so are not CPU demanding, -- the goal is to saturate the network bandwidth. -- Data for each synchronization job for the Gpr protocol type Gpr_Data is record Channel : Protocol.Communication_Channel; Root_Dir : Unbounded_String; Excluded_Patterns : Str_Vect.Vector; Included_Patterns : Str_Vect.Vector; end record; package Gpr_Data_Set is new Containers.Vectors (Positive, Gpr_Data); -- Queue of job to be done for the gpr protocol protected Gpr_Queue is procedure Add (Job : Gpr_Data); -- Add a new synchronization job entry Get (Job : out Gpr_Data; Files : out File_Data_Set.Vector; Stop : out Boolean); -- Get a synchronization job with the corresponding files, Stop is set -- to True if there is no more job to handle and False otherwise. procedure No_More_Job; private procedure Set_Project_Files (Job : Gpr_Data); -- Set the project files to be synchronized Jobs : Gpr_Data_Set.Vector; Project_Files : File_Data_Set.Vector; PF_Initialized : Boolean := False; No_More : Boolean := False; end Gpr_Queue; -- Synchronization job are handled by the Gpr_Sync tasks task type Gpr_Sync is entry Stop; end Gpr_Sync; type Gpr_Sync_Tasks is array (1 .. Max_Gpr_Sync) of Gpr_Sync; type Sync_Tasks_Ref is access all Gpr_Sync_Tasks; Sync_Tasks : Sync_Tasks_Ref; -- Only allocated (and so started) if a some slaves are using the gpr -- protocol. Otherwise this variable will stay null. --------------- -- Gpr_Queue -- --------------- protected body Gpr_Queue is --------- -- Add -- --------- procedure Add (Job : Gpr_Data) is begin Jobs.Append (Job); end Add; --------- -- Get -- --------- entry Get (Job : out Gpr_Data; Files : out File_Data_Set.Vector; Stop : out Boolean) when Jobs.Length > 0 or No_More is begin if Jobs.Length = 0 and then No_More then Stop := True; else Stop := False; Job := Jobs.First_Element; Jobs.Delete_First; if not PF_Initialized then Set_Project_Files (Job); end if; Files := Project_Files; end if; end Get; ----------------- -- No_More_Job -- ----------------- procedure No_More_Job is begin No_More := True; end No_More_Job; ----------------------- -- Set_Project_Files -- ----------------------- procedure Set_Project_Files (Job : Gpr_Data) is Root_Dir : constant String := (if Job.Root_Dir = Null_Unbounded_String then "." else To_String (Job.Root_Dir)); type Regexp_Set is array (Containers.Count_Type range <>) of Regexp; I_Regexp : Regexp_Set (1 .. Job.Included_Patterns.Length); E_Regexp : Regexp_Set (1 .. Job.Excluded_Patterns.Length); procedure Process (Prefix : String); ------------- -- Process -- ------------- procedure Process (Prefix : String) is procedure Check (File : Directory_Entry_Type); -- Check and add this file if it passes the filters ----------- -- Check -- ----------- procedure Check (File : Directory_Entry_Type) is use GNAT; function Match (Name : String; R_Set : Regexp_Set) return Boolean with Inline; -- Returns true if Name is matched by one of the regexp in -- R_Set. ----------- -- Match -- ----------- function Match (Name : String; R_Set : Regexp_Set) return Boolean is begin for Regexp of R_Set loop if Match (Name, Regexp) then return True; end if; end loop; return False; end Match; S_Name : constant String := Simple_Name (File); Entry_Name : constant String := Prefix & S_Name; Is_File : Boolean; begin if Kind (File) = Directory then if S_Name not in "." | ".." and then (I_Regexp'Length /= 0 or else not Match (S_Name, E_Regexp)) and then not Is_Symbolic_Link (Root_Dir & Directory_Separator & Entry_Name) then Process (Entry_Name & Directory_Separator); end if; else if I_Regexp'Length = 0 then if Match (S_Name, E_Regexp) then Is_File := False; else Is_File := True; end if; else if Match (S_Name, I_Regexp) then Is_File := True; else Is_File := False; end if; end if; if Is_File then Project_Files.Append (File_Data' (To_Unbounded_String (Entry_Name), To_UTC_Time_Stamp (Modification_Time (File)), OS_Lib.Is_Executable_File (Root_Dir & Directory_Separator & Entry_Name))); end if; end if; end Check; begin Search (Directory => Root_Dir & (if Prefix = "" then "" else Directory_Separator & Prefix), Pattern => "*", Filter => (Special_File => False, others => True), Process => Check'Access); end Process; begin -- Compile the patterns declare K : Containers.Count_Type := 1; begin for P of Job.Included_Patterns loop I_Regexp (K) := Compile (P, Glob => True); K := K + 1; end loop; K := 1; for P of Job.Excluded_Patterns loop E_Regexp (K) := Compile (P, Glob => True); K := K + 1; end loop; end; -- Check the files under the project root Process (Prefix => ""); PF_Initialized := True; end Set_Project_Files; end Gpr_Queue; -------------- -- Gpr_Sync -- -------------- task body Gpr_Sync is Job : Gpr_Data; Files : File_Data_Set.Vector; No_More_Job : Boolean; begin For_Slave : loop -- Get a new job and the associated files if any Gpr_Queue.Get (Job, Files, No_More_Job); exit For_Slave when No_More_Job; declare Chunk_Size : constant := 250; -- This constant controls the number of files sent with the sync -- command. Doing one at a time is really time consumming as -- we have for every file and send and a receive command on -- the socket. F_List : File_Data_Set.Vector; Count : Natural := 0; begin -- Synchronize each file in the list we got for F of Files loop if Count = Chunk_Size then Protocol.Sync_Files (Job.Channel, To_String (Job.Root_Dir), F_List); F_List.Clear; Count := 0; end if; F_List.Append (F); Count := Count + 1; end loop; -- Then send the last chunk if any if Count /= 0 then Protocol.Sync_Files (Job.Channel, To_String (Job.Root_Dir), F_List); end if; Protocol.Send_End_Of_File_List (Job.Channel); end; end loop For_Slave; accept Stop; exception when Socket_Error => accept Stop; when E : others => Put_Line (Exception_Information (E)); OS_Exit (1); end Gpr_Sync; ------------------- -- Receive_Files -- ------------------- function Receive_Files (Channel : Protocol.Communication_Channel; Root_Dir : String; Total_File : out Natural; Total_Transferred : out Natural; Remote_Files : out Files.Set; Is_Debug : Boolean; Display : access procedure (Message : String)) return Protocol.Command_Kind is use GPR.Compilation.Protocol; begin Total_File := 0; Total_Transferred := 0; loop declare Cmd : constant Command := Get_Command (Channel); To_Sync : File_Data_Set.Vector; K : Positive := 1; Message : Unbounded_String; begin if Is_Debug then Message := To_Unbounded_String ("command: " & Command_Kind'Image (Kind (Cmd))); if Args (Cmd) /= null then for K in Args (Cmd)'Range loop Append (Message, ", " & Args (Cmd) (K).all); end loop; end if; Display (To_String (Message)); end if; if Kind (Cmd) = TS then -- Check all files in the argument of the command. This is a -- list of couple (filename and time stamp). Check_All_Files : loop Total_File := Total_File + 1; declare Path_Name : constant String := To_Native_Directory_Separator (Args (Cmd) (K).all); Full_Path : constant String := Root_Dir & Directory_Separator & Path_Name; TS : constant Time_Stamp_Type := Time_Stamp_Type (Args (Cmd) (K + 1).all); Is_Executable : constant Boolean := Boolean'Value (Args (Cmd) (K + 2).all); File_Stamp : Time_Stamp_Type; Exists : Boolean; begin if Ada.Directories.Exists (Full_Path) then File_Stamp := To_UTC_Time_Stamp (Modification_Time (Full_Path)); Exists := True; else Exists := False; end if; Remote_Files.Insert (Full_Path); if not Exists or else File_Stamp /= TS then To_Sync.Append (File_Data' (To_Unbounded_String (Path_Name), TS, Is_Executable)); end if; end; K := K + 3; exit Check_All_Files when K > Args (Cmd)'Length; end loop Check_All_Files; -- If all files are up-to-data if To_Sync.Length = 0 then Send_Ok (Channel); else -- Some files are to be synchronized, send the list of -- names back to the master. Send_Ko (Channel, To_Sync); -- We then receive the files contents in the same order Get_RAW_Data : declare Max : constant String := Containers.Count_Type'Image (To_Sync.Length); N : Natural := 0; begin for W of To_Sync loop declare Full_Path : constant String := Root_Dir & Directory_Separator & To_String (W.Path_Name); begin Create_Path (Containing_Directory (Full_Path)); Get_RAW_File_Content (Channel, Full_Path, W.Timestamp); -- And mark file executable if needed if W.Is_Executable then GNAT.OS_Lib.Set_Executable (Full_Path); end if; exception when others => Display ("failed to create file: " & Full_Path); return Protocol.SI; end; N := N + 1; if N mod 100 = 0 then Display ("File transfered" & Natural'Image (N) & "/" & Max); end if; end loop; end Get_RAW_Data; Total_Transferred := Total_Transferred + Natural (To_Sync.Length); end if; else return Kind (Cmd); end if; end; end loop; end Receive_Files; ---------------- -- Send_Files -- ---------------- procedure Send_Files (Channel : Protocol.Communication_Channel; Root_Dir : String; Excluded_Patterns : Str_Vect.Vector; Included_Patterns : Str_Vect.Vector; Mode : Direction) is use type Str_Vect.Vector; begin -- Starts the tasks if not already done if Sync_Tasks = null then Sync_Tasks := new Gpr_Sync_Tasks; end if; Gpr_Queue.Add (Gpr_Data' (Channel, To_Unbounded_String (Root_Dir), Excluded_Patterns & Common_Excluded_Patterns & (if Mode = To_Slave then Artifact_Excluded_Patterns else Str_Vect.Empty_Vector), Included_Patterns)); end Send_Files; ---------- -- Wait -- ---------- procedure Wait is begin Gpr_Queue.No_More_Job; if Sync_Tasks /= null then for T of Sync_Tasks.all loop if not T'Terminated then T.Stop; end if; end loop; end if; end Wait; begin Common_Excluded_Patterns.Append (".git"); Common_Excluded_Patterns.Append (".svn"); Common_Excluded_Patterns.Append (".hg"); Common_Excluded_Patterns.Append ("CVS"); Common_Excluded_Patterns.Append ("gnatinspect.db*"); Common_Excluded_Patterns.Append ("GNAT-TEMP*.TMP"); Common_Excluded_Patterns.Append ("*.lexch"); Artifact_Excluded_Patterns.Append ("*.o"); Artifact_Excluded_Patterns.Append ("*.obj"); Artifact_Excluded_Patterns.Append ("*.ali"); Artifact_Excluded_Patterns.Append ("*.dll"); Artifact_Excluded_Patterns.Append ("*.so"); Artifact_Excluded_Patterns.Append ("*.so.*"); Artifact_Excluded_Patterns.Append ("*.exe"); end GPR.Compilation.Sync; gprbuild-25.0.0/gpr/src/gpr-compilation-sync.ads000066400000000000000000000071211470075373400215470ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2014-2021, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- Synchronize data to/from the slave. The usage is: -- -- On one side: -- 1. call Send_Files for every slave to be synchronized -- 2. call Wait to wait for the synchronization to be terminated -- -- On the other side: -- 1. call Receive_Files with Ada.Containers.Indefinite_Vectors; with GPR.Compilation.Protocol; use GPR.Compilation; package GPR.Compilation.Sync is package Str_Vect is new Ada.Containers.Indefinite_Vectors (Positive, String); type Direction is (To_Slave, To_Master); procedure Send_Files (Channel : Protocol.Communication_Channel; Root_Dir : String; Excluded_Patterns : Str_Vect.Vector; Included_Patterns : Str_Vect.Vector; Mode : Direction); -- Synchronize from the build master to the slave procedure Wait; -- Wait for all synchronization to be terminated package Files renames String_Sets; function Receive_Files (Channel : Protocol.Communication_Channel; Root_Dir : String; Total_File : out Natural; Total_Transferred : out Natural; Remote_Files : out Files.Set; Is_Debug : Boolean; Display : access procedure (Message : String)) return Protocol.Command_Kind; -- This routine must be used to receive the files that will be sent over -- by To_Slave. Total_File will be set with the total number of files -- checked and Total_Transferred the total number of files actually -- transferred (because of a time-stamp mismatch). The Root_Dir is the -- directory from where the files are to be written. Finally a Display -- routine can be passed to display messages during the transfer. Some -- messages are only displayed depending on Is_Debug status. end GPR.Compilation.Sync; gprbuild-25.0.0/gpr/src/gpr-compilation.adb000066400000000000000000000140311470075373400205520ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2012-2023, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Environment_Variables; use Ada; with Ada.Strings.Fixed; with Ada.Strings.Maps; with Ada.Text_IO; with GNAT.MD5; use GNAT; with GNAT.String_Split; use GNAT.String_Split; with GPR.Names; use GPR.Names; package body GPR.Compilation is Last_Env_MD5 : MD5.Message_Digest := (others => ASCII.NUL); -- Keep last environment variable set to avoid too many system calls. -- ??? Ideally, we should set them when spawning the process, in -- which case it would be less expensive to set and could be set -- every time. ------------------------- -- Check_Local_Process -- ------------------------- procedure Check_Local_Process (Process : Id; Executable : String; Options : GPR.Util.String_Vectors.Vector) is begin if Process = Invalid_Process then declare Err : constant String := "spawn failed with ERRNO =" & Errno'Img & " (" & Errno_Message & ")"; begin Name_Len := 0; for S of Options loop Add_Str_To_Name_Buffer (S & " "); end loop; GPR.Util.Fail_Program (null, Err, Command => "failed command was: " & Executable & " " & Name_Buffer (1 .. Name_Len)); end; end if; end Check_Local_Process; ----------- -- Image -- ----------- function Image (Pid : Remote_Id) return String is N_Img : constant String := Remote_Id'Image (Pid); begin return N_Img (N_Img'First + 1 .. N_Img'Last); end Image; ------------- -- Set_Env -- ------------- procedure Set_Env (Env : String; Fail : Boolean; Force : Boolean := False) is Env_List : Slice_Set; begin Create (Env_List, Env, String'(1 => Opts_Sep)); for K in 1 .. Slice_Count (Env_List) loop declare Var : constant String := Slice (Env_List, K); I : constant Natural := Strings.Fixed.Index (Var, "="); Sum : constant MD5.Message_Digest := MD5.Digest (Var); begin if I /= 0 then if Force or else Last_Env_MD5 /= Sum then Environment_Variables.Set (Name => Var (Var'First .. I - 1), Value => Var (I + 1 .. Var'Last)); Last_Env_MD5 := Sum; end if; elsif Var'Length > 0 then -- This is a protocol error, we do not want to fail here as -- this routine is used by gprslave. This error message should -- never been displayed anyway. Text_IO.Put_Line ("wrong environment variable, missing '=' : " & Var); if Fail then OS_Exit (1); end if; end if; end; end loop; end Set_Env; -------------------- -- Shared_Counter -- -------------------- protected body Shared_Counter is ----------- -- Count -- ----------- function Count return Natural is begin return Counter; end Count; --------------- -- Decrement -- --------------- procedure Decrement is begin Counter := Counter - 1; end Decrement; --------------- -- Increment -- --------------- procedure Increment is begin Counter := Counter + 1; end Increment; ----------- -- Reset -- ----------- procedure Reset is begin Counter := 0; end Reset; ------------------- -- Wait_Non_Zero -- ------------------- entry Wait_Non_Zero when Counter /= 0 is begin null; end Wait_Non_Zero; end Shared_Counter; ----------------------------------- -- To_Native_Directory_Separator -- ----------------------------------- function To_Native_Directory_Separator (Pathname : String) return String is DS : Character renames Directory_Separator; begin return Strings.Fixed.Translate (Pathname, Strings.Maps.To_Mapping (String'(1 => (if DS = '/' then '\' else '/')), String'(1 => DS))); end To_Native_Directory_Separator; end GPR.Compilation; gprbuild-25.0.0/gpr/src/gpr-compilation.ads000066400000000000000000000116561470075373400206050ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2012-2023, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- This is the root package for the compilation support. It handles the local -- and distributed compilation modes. with Ada.Characters.Latin_1; with Ada.Containers.Vectors; with Ada.Strings.Unbounded; with GNAT.OS_Lib; with GPR.Util; package GPR.Compilation is Default_Port : constant := 8484; Opts_Sep : constant Character := Ada.Characters.Latin_1.HT; -- Command options separator, that is the separator used for options to be -- passed to the executed command. -- A simple concurrent counter type protected type Shared_Counter (Default : Natural := 0) is function Count return Natural; -- Returns the current counter value procedure Increment; -- Increment by one procedure Decrement; -- Decrement by one procedure Reset; -- Reset counter to 0 entry Wait_Non_Zero; -- Returns when the counter is above zero private Counter : Natural := Default; end Shared_Counter; type Shared_Counter_Access is access Shared_Counter; procedure Set_Env (Env : String; Fail : Boolean; Force : Boolean := False); -- Set environment given an Env variable containing a set of name=value -- separated with Opts_Sep. -- -- name=value[name=value] -- -- If Fail is true the program will exit if the a format error is detected. -- If Force is set to True the environment will always be set otherwise it -- will be set only if not already set. -- The set of files for a given project (associated with a synchronization -- job). type File_Data is record Path_Name : Ada.Strings.Unbounded.Unbounded_String; Timestamp : Time_Stamp_Type; -- YYYYMMDDhhmmss Is_Executable : Boolean; end record; package File_Data_Set is new Ada.Containers.Vectors (Positive, File_Data); -- Process's Id, shared between Slave and Process children type Remote_Id is mod 2 ** 64; -- Represent a remote process id, this number is unique across all slaves. -- Such number if created by the slaves using a slave id (unique number) -- and a compilation number. Bother numbers are 32bits value: -- -- 63 32 31 0 -- | [slave id] | [compilation number] | type Process_Kind is (Local, Remote); type Id (Kind : Process_Kind := Local) is record case Kind is when Local => Pid : GNAT.OS_Lib.Process_Id; when Remote => R_Pid : Remote_Id; end case; end record; Invalid_Process : constant Id := (Local, Pid => GNAT.OS_Lib.Invalid_Pid); function Image (Pid : Remote_Id) return String; -- Returns the string representation of Pid procedure Check_Local_Process (Process : Id; Executable : String; Options : GPR.Util.String_Vectors.Vector); -- Check that a local process is valid. If not, fail with the errno and -- associated message and failed command composed from Executable and -- Options. private function To_Native_Directory_Separator (Pathname : String) return String with Inline; -- Returns Pathname with native directory separator end GPR.Compilation; gprbuild-25.0.0/gpr/src/gpr-conf.adb000066400000000000000000002771151470075373400171770ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2006-2023, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Directories; use Ada.Directories; with Ada.Environment_Variables; with Ada.Unchecked_Deallocation; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.Case_Util; use GNAT.Case_Util; with GNAT.Table; with GPR.Env; with GPR.Names; use GPR.Names; with GPR.Nmsc; use GPR.Nmsc; with GPR.Opt; use GPR.Opt; with GPR.Output; use GPR.Output; with GPR.Part; with GPR.Proc; use GPR.Proc; with GPR.Tree; use GPR.Tree; with GPR.Util; use GPR.Util; with GPR.Snames; use GPR.Snames; with GPR.Tempdir; package body GPR.Conf is Auto_Cgpr : constant String := "auto.cgpr"; Gprconfig_Name : constant String := "gprconfig"; Auto_Configuration_Success : Boolean := True; -- False when invocation of gprconfig for auto-configuration returned a -- failure status. Warn_For_RTS : Boolean := True; -- Set to False when gprbuild parse again the project files, to avoid -- an incorrect warning. Warn_For_Config_In_Builder_Switches : Boolean := True; -- Set to False when gprbuild parse again the project files, to avoid -- an incorrect warning. type Runtime_Root_Data; type Runtime_Root_Ptr is access Runtime_Root_Data; type Runtime_Root_Data is record Root : String_Access; Next : Runtime_Root_Ptr; end record; -- Data for a runtime root to be used when adding directories to the -- project path. type Compiler_Root_Data; type Compiler_Root_Ptr is access Compiler_Root_Data; type Compiler_Root_Data is record Root : String_Access; Runtimes : Runtime_Root_Ptr; Next : Compiler_Root_Ptr; end record; -- Data for a compiler root to be used when adding directories to the -- project path. First_Compiler_Root : Compiler_Root_Ptr := null; -- Head of the list of compiler roots function Get_Element_Or_Empty (Self : Language_Maps.Map; Lang : Name_Id) return String; -- Returns String from element or empty string if does not exists RTS_Languages : Language_Maps.Map; -- Stores the runtime names for the various languages. This is in general -- set from a --RTS command line option. Toolchain_Languages : Language_Maps.Map; -- Stores the toolchain names for the various languages Toolchain_Paths : Language_Maps.Map; -- Stores the toolchain paths for the various languages package Db_Switch_Args is new GNAT.Table (Table_Component_Type => Name_Id, Table_Index_Type => Integer, Table_Low_Bound => 1, Table_Initial => 200, Table_Increment => 100); -- Table of all the arguments of --db switches of gprbuild ----------------------- -- Local_Subprograms -- ----------------------- function Check_Target (Config_File : Project_Id; Autoconf_Specified : Boolean; Project_Tree : Project_Tree_Ref; Target : String := "") return Boolean; -- Check that the config file's target matches Target. -- Target should be set to the empty string when the user did not specify -- a target. If the target in the configuration file is invalid, this -- function will raise Invalid_Config with an appropriate message. -- Autoconf_Specified should be set to True if the user has used -- autoconf. function Locate_Config_File (Name : String) return String_Access; -- Search for Name in the config files directory. Return full path if -- found, or null otherwise. procedure Apply_Config_File (Config_File : Project_Id; Project_Tree : Project_Tree_Ref); -- Apply the configuration file settings to all the projects in the -- project tree. The Project_Tree must have been parsed first, and -- processed through the first phase so that all its projects are known. -- -- Currently, this will add new attributes and packages in the various -- projects, so that when the second phase of the processing is performed -- these attributes are automatically taken into account. type State is (No_State); procedure Look_For_Project_Paths (Project : Project_Id; Tree : Project_Tree_Ref; With_State : in out State); -- Check the compilers in the Project and add record them in the list -- rooted at First_Compiler_Root, with their runtimes, if they are not -- already in the list. procedure Update_Project_Path is new For_Every_Project_Imported (State => State, Action => Look_For_Project_Paths); ----------------------- -- Add_Db_Switch_Arg -- ----------------------- procedure Add_Db_Switch_Arg (N : Name_Id) is begin Db_Switch_Args.Append (N); end Add_Db_Switch_Arg; ----------------------- -- Apply_Config_File -- ----------------------- procedure Apply_Config_File (Config_File : Project_Id; Project_Tree : Project_Tree_Ref) is procedure Add_Attributes (Project_Tree : Project_Tree_Ref; Conf_Decl : Declarations; User_Decl : in out Declarations); -- Process the attributes in the config declarations. For -- single string values, if the attribute is not declared in -- the user declarations, declare it with the value in the -- config declarations. For string list values, prepend the -- value in the user declarations with the value in the config -- declarations. -------------------- -- Add_Attributes -- -------------------- procedure Add_Attributes (Project_Tree : Project_Tree_Ref; Conf_Decl : Declarations; User_Decl : in out Declarations) is Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared; Conf_Attr_Id : Variable_Id; Conf_Attr : Variable; Conf_Array_Id : Array_Id; Conf_Array : Array_Data; Conf_Array_Elem_Id : Array_Element_Id; Conf_Array_Elem : Array_Element; Conf_List : String_List_Id; Conf_List_Elem : String_Element; User_Attr_Id : Variable_Id; User_Attr : Variable; User_Array_Id : Array_Id; User_Array : Array_Data; User_Array_Elem_Id : Array_Element_Id; User_Array_Elem : Array_Element; begin Conf_Attr_Id := Conf_Decl.Attributes; User_Attr_Id := User_Decl.Attributes; while Conf_Attr_Id /= No_Variable loop Conf_Attr := Shared.Variable_Elements.Table (Conf_Attr_Id); User_Attr := Shared.Variable_Elements.Table (User_Attr_Id); if not Conf_Attr.Value.Default then if User_Attr.Value.Default then -- No attribute declared in user project file: just copy -- the value of the configuration attribute. User_Attr.Value := Conf_Attr.Value; Shared.Variable_Elements.Table (User_Attr_Id) := User_Attr; elsif User_Attr.Value.Kind = Single and then User_Attr.Name = Name_Target and then User_Attr.Value.From_Implicit_Target then -- The Target attribute is declared in user project but -- its value derives from implicit evaluation of 'Target -- attribute, e.g.: -- -- abstract project Config is -- end Config; -- -- with "config.gpr"; -- project P is -- for Target use Config'Target; -- end P; -- -- In such case the effective target might change due to -- target fallback, so it needs to be overwritten by the -- value from configuration project. User_Attr.Value.Value := Conf_Attr.Value.Value; Shared.Variable_Elements.Table (User_Attr_Id) := User_Attr; elsif User_Attr.Value.Kind = List and then Conf_Attr.Value.Values /= Nil_String and then Conf_Attr.Value.Concat then -- List attribute declared in both the user project and the -- configuration project: prepend the user list with the -- configuration list. declare User_List : constant String_List_Id := User_Attr.Value.Values; Conf_List : String_List_Id := Conf_Attr.Value.Values; Conf_Elem : String_Element; New_List : String_List_Id; New_Elem : String_Element; begin -- Create new list String_Element_Table.Increment_Last (Shared.String_Elements); New_List := String_Element_Table.Last (Shared.String_Elements); -- Value of attribute is new list User_Attr.Value.Values := New_List; Shared.Variable_Elements.Table (User_Attr_Id) := User_Attr; loop -- Get each element of configuration list Conf_Elem := Shared.String_Elements.Table (Conf_List); New_Elem := Conf_Elem; Conf_List := Conf_Elem.Next; if Conf_List = Nil_String then -- If it is the last element in the list, connect -- to first element of user list, and we are done. New_Elem.Next := User_List; Shared.String_Elements.Table (New_List) := New_Elem; exit; else -- If it is not the last element in the list, add -- to new list. String_Element_Table.Increment_Last (Shared.String_Elements); New_Elem.Next := String_Element_Table.Last (Shared.String_Elements); Shared.String_Elements.Table (New_List) := New_Elem; New_List := New_Elem.Next; end if; end loop; end; end if; end if; Conf_Attr_Id := Conf_Attr.Next; User_Attr_Id := User_Attr.Next; end loop; Conf_Array_Id := Conf_Decl.Arrays; while Conf_Array_Id /= No_Array loop Conf_Array := Shared.Arrays.Table (Conf_Array_Id); User_Array_Id := User_Decl.Arrays; while User_Array_Id /= No_Array loop User_Array := Shared.Arrays.Table (User_Array_Id); exit when User_Array.Name = Conf_Array.Name; User_Array_Id := User_Array.Next; end loop; -- If this associative array does not exist in the user project -- file, do a shallow copy of the full associative array. if User_Array_Id = No_Array then Array_Table.Increment_Last (Shared.Arrays); User_Array := Conf_Array; User_Array.Next := User_Decl.Arrays; User_Decl.Arrays := Array_Table.Last (Shared.Arrays); Shared.Arrays.Table (User_Decl.Arrays) := User_Array; -- Otherwise, check each array element else Conf_Array_Elem_Id := Conf_Array.Value; while Conf_Array_Elem_Id /= No_Array_Element loop Conf_Array_Elem := Shared.Array_Elements.Table (Conf_Array_Elem_Id); User_Array_Elem_Id := User_Array.Value; while User_Array_Elem_Id /= No_Array_Element loop User_Array_Elem := Shared.Array_Elements.Table (User_Array_Elem_Id); exit when User_Array_Elem.Index = Conf_Array_Elem.Index; User_Array_Elem_Id := User_Array_Elem.Next; end loop; -- If the array element doesn't exist in the user array, -- insert a shallow copy of the conf array element in the -- user array. if User_Array_Elem_Id = No_Array_Element then Array_Element_Table.Increment_Last (Shared.Array_Elements); User_Array_Elem := Conf_Array_Elem; User_Array_Elem.Next := User_Array.Value; User_Array.Value := Array_Element_Table.Last (Shared.Array_Elements); Shared.Array_Elements.Table (User_Array.Value) := User_Array_Elem; Shared.Arrays.Table (User_Array_Id) := User_Array; -- Otherwise, if the value is a string list, prepend the -- conf array element value to the array element. elsif Conf_Array_Elem.Value.Kind = List and then Conf_Array_Elem.Value.Concat then Conf_List := Conf_Array_Elem.Value.Values; if Conf_List /= Nil_String then declare Link : constant String_List_Id := User_Array_Elem.Value.Values; Previous : String_List_Id := Nil_String; Next : String_List_Id; begin loop Conf_List_Elem := Shared.String_Elements.Table (Conf_List); String_Element_Table.Increment_Last (Shared.String_Elements); Next := String_Element_Table.Last (Shared.String_Elements); Shared.String_Elements.Table (Next) := Conf_List_Elem; if Previous = Nil_String then User_Array_Elem.Value.Values := Next; Shared.Array_Elements.Table (User_Array_Elem_Id) := User_Array_Elem; else Shared.String_Elements.Table (Previous).Next := Next; end if; Previous := Next; Conf_List := Conf_List_Elem.Next; if Conf_List = Nil_String then Shared.String_Elements.Table (Previous).Next := Link; exit; end if; end loop; end; end if; end if; Conf_Array_Elem_Id := Conf_Array_Elem.Next; end loop; end if; Conf_Array_Id := Conf_Array.Next; end loop; end Add_Attributes; Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared; Conf_Decl : constant Declarations := Config_File.Decl; Conf_Pack_Id : Package_Id; Conf_Pack : Package_Element; User_Decl : Declarations; User_Pack_Id : Package_Id; User_Pack : Package_Element; Proj : Project_List; begin Debug_Output ("Applying config file to a project tree"); Proj := Project_Tree.Projects; while Proj /= null loop if Proj.Project /= Config_File then User_Decl := Proj.Project.Decl; Add_Attributes (Project_Tree => Project_Tree, Conf_Decl => Conf_Decl, User_Decl => User_Decl); Conf_Pack_Id := Conf_Decl.Packages; while Conf_Pack_Id /= No_Package loop Conf_Pack := Shared.Packages.Table (Conf_Pack_Id); User_Pack_Id := User_Decl.Packages; while User_Pack_Id /= No_Package loop User_Pack := Shared.Packages.Table (User_Pack_Id); exit when User_Pack.Name = Conf_Pack.Name; User_Pack_Id := User_Pack.Next; end loop; if User_Pack_Id = No_Package then Package_Table.Increment_Last (Shared.Packages); User_Pack := Conf_Pack; User_Pack.Next := User_Decl.Packages; User_Decl.Packages := Package_Table.Last (Shared.Packages); Shared.Packages.Table (User_Decl.Packages) := User_Pack; else Add_Attributes (Project_Tree => Project_Tree, Conf_Decl => Conf_Pack.Decl, User_Decl => Shared.Packages.Table (User_Pack_Id).Decl); end if; Conf_Pack_Id := Conf_Pack.Next; end loop; Proj.Project.Decl := User_Decl; -- For aggregate projects, we need to apply the config to all -- their aggregated trees as well. if Proj.Project.Qualifier in Aggregate_Project then declare List : Aggregated_Project_List; begin List := Proj.Project.Aggregated_Projects; while List /= null loop Debug_Output ("Recursively apply config to aggregated tree", List.Project.Name); Apply_Config_File (Config_File, Project_Tree => List.Tree); List := List.Next; end loop; end; end if; end if; Proj := Proj.Next; end loop; end Apply_Config_File; --------------------------------------- -- Problem_During_Auto_Configuration -- --------------------------------------- function Problem_During_Auto_Configuration return Boolean is begin return not Auto_Configuration_Success; end Problem_During_Auto_Configuration; ------------------ -- Check_Target -- ------------------ function Check_Target (Config_File : Project_Id; Autoconf_Specified : Boolean; Project_Tree : Project_Tree_Ref; Target : String := "") return Boolean is Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared; Variable : constant Variable_Value := Value_Of (Name_Target, Config_File.Decl.Attributes, Shared); Tgt_Name : Name_Id := No_Name; OK : Boolean; begin if Variable /= Nil_Variable_Value and then not Variable.Default then Tgt_Name := Variable.Value; end if; OK := Target = "" or else Target = "native" or else (Tgt_Name /= No_Name and then (Tgt_Name = Empty_String or else Target = Get_Name_String (Tgt_Name))); if not OK then if Autoconf_Specified then if Opt.Verbosity_Level > Opt.Low then Write_Line ("inconsistent targets, performing autoconf"); end if; return False; else raise Invalid_Config with (if Tgt_Name = No_Name then "no target specified in configuration file" else "mismatched targets: """ & Get_Name_String_Safe (Tgt_Name) & """ in configuration, """ & Target & """ specified"); end if; end if; return True; end Check_Target; -------------------------- -- Get_Element_Or_Empty -- -------------------------- function Get_Element_Or_Empty (Self : Language_Maps.Map; Lang : Name_Id) return String is C : constant Language_Maps.Cursor := Self.Find (Lang); begin if Language_Maps.Has_Element (C) then return Get_Name_String (Language_Maps.Element (C)); else return ""; end if; end Get_Element_Or_Empty; -------------------------------------- -- Get_Or_Create_Configuration_File -- -------------------------------------- procedure Get_Or_Create_Configuration_File (Project : Project_Id; Conf_Project : Project_Id; Project_Tree : Project_Tree_Ref; Project_Node_Tree : Tree.Project_Node_Tree_Ref; Env : in out Tree.Environment; Allow_Automatic_Generation : Boolean; Config_File_Name : String := ""; Autoconf_Specified : Boolean; Target_Name : String := ""; Normalized_Hostname : String; Packages_To_Check : String_List_Access := null; Config : out Project_Id; Config_File_Path : out String_Access; Automatically_Generated : out Boolean; On_Load_Config : Config_File_Hook := null; Gprconfig_Options : String_Vectors.Vector := String_Vectors.Empty_Vector) is Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared; At_Least_One_Compiler_Command : Boolean := False; -- Set to True if at least one attribute Ide'Compiler_Command is -- specified for one language of the system. Conf_File_Name : String_Access := new String'(Config_File_Name); -- The configuration project file name. May be modified if there are -- switches --config= in the Builder package of the main project. Selected_Target : String_Access := new String'(Target_Name); function Default_CGPR_Name return String; -- Return the name of the default config file that should be looked up procedure Do_Autoconf; -- Generate a new config file through gprconfig. In case of error, this -- raises the Invalid_Config exception with an appropriate message procedure Check_Builder_Switches; -- Check for switches --config and --RTS in package Builder procedure Get_Project_Target; -- If Target_Name is empty, get the specified target in the project -- file, if any. procedure Get_Config_File; -- If configuration project is not yet specified, checks for value -- of Config_File attribute. procedure Get_Project_Attribute (Lang_Map : in out Language_Maps.Map; Attr_Name : Name_Id); -- Put the various Attr_Name () into then Lang_Map from the -- project file or any project it extends, if any are specified. function Get_Config_Switches return Argument_List_Access; -- Return the --config switches to use for gprconfig function Get_Db_Switches return Argument_List_Access; -- Return the --db switches to use for gprconfig function Is_Base_Name (Path : String) return Boolean; -- Returns True if Path has no directory separator ---------------------------- -- Check_Builder_Switches -- ---------------------------- procedure Check_Builder_Switches is Get_RTS_Switches : constant Boolean := RTS_Languages.Is_Empty; -- If no switch --RTS have been specified on the command line, look -- for --RTS switches in the Builder switches. Builder : constant Package_Id := Value_Of (Name_Builder, Project.Decl.Packages, Shared); Switch_Array_Id : Array_Element_Id; -- The Switches to be checked Report_Legacy_Config_Prj_Usage : Boolean := False; procedure Check_Switches; -- Check the switches in Switch_Array_Id -------------------- -- Check_Switches -- -------------------- procedure Check_Switches is Switch_Array : Array_Element; Switch_List : String_List_Id := Nil_String; Switch : String_Element; Lang : Name_Id; Lang_Last : Positive; begin while Switch_Array_Id /= No_Array_Element loop Switch_Array := Shared.Array_Elements.Table (Switch_Array_Id); Switch_List := Switch_Array.Value.Values; List_Loop : while Switch_List /= Nil_String loop Switch := Shared.String_Elements.Table (Switch_List); if Switch.Value /= No_Name then Get_Name_String (Switch.Value); if Conf_File_Name'Length = 0 and then Name_Len > 9 and then Name_Buffer (1 .. 9) = "--config=" then Conf_File_Name := new String'(Name_Buffer (10 .. Name_Len)); Report_Legacy_Config_Prj_Usage := True; elsif Get_RTS_Switches and then Name_Len >= 7 and then Name_Buffer (1 .. 5) = "--RTS" then if Name_Buffer (6) = '=' then if not Runtime_Name_Set_For (Name_Ada) then Set_Runtime_For (Name_Ada, Name_Buffer (7 .. Name_Len)); end if; elsif Name_Len > 7 and then Name_Buffer (6) = ':' and then Name_Buffer (7) /= '=' then Lang_Last := 7; while Lang_Last < Name_Len and then Name_Buffer (Lang_Last + 1) /= '=' loop Lang_Last := Lang_Last + 1; end loop; if Name_Buffer (Lang_Last + 1) = '=' then declare RTS : constant String := Name_Buffer (Lang_Last + 2 .. Name_Len); begin Name_Buffer (1 .. Lang_Last - 6) := Name_Buffer (7 .. Lang_Last); Name_Len := Lang_Last - 6; To_Lower (Name_Buffer (1 .. Name_Len)); Lang := Name_Find; if not Runtime_Name_Set_For (Lang) then Set_Runtime_For (Lang, RTS); end if; end; end if; end if; end if; end if; Switch_List := Switch.Next; end loop List_Loop; Switch_Array_Id := Switch_Array.Next; end loop; end Check_Switches; -- Start of processing for Check_Builder_Switches begin if Builder /= No_Package then Switch_Array_Id := Value_Of (Name => Name_Switches, In_Arrays => Shared.Packages.Table (Builder).Decl.Arrays, Shared => Shared); Check_Switches; Switch_Array_Id := Value_Of (Name => Name_Default_Switches, In_Arrays => Shared.Packages.Table (Builder).Decl.Arrays, Shared => Shared); Check_Switches; end if; if Report_Legacy_Config_Prj_Usage and then not Quiet_Output and then Warn_For_Config_In_Builder_Switches then Write_Line ("warning: --config in Builder switches is obsolescent, " & "use Config_Prj_File instead"); Warn_For_Config_In_Builder_Switches := False; end if; end Check_Builder_Switches; ------------------------ -- Get_Project_Target -- ------------------------ procedure Get_Project_Target is begin if Selected_Target'Length = 0 then -- Check if attribute Target is specified in the main -- project, or in a project it extends. If it is, use this -- target to invoke gprconfig. declare Variable : Variable_Value; Proj : Project_Id; Tgt_Name : Name_Id := No_Name; begin Proj := Project; Project_Loop : while Proj /= No_Project loop Variable := Value_Of (Name_Target, Proj.Decl.Attributes, Shared); if Variable /= Nil_Variable_Value and then not Variable.Default and then Variable.Value /= No_Name then Tgt_Name := Variable.Value; exit Project_Loop; end if; Proj := Proj.Extends; end loop Project_Loop; if Tgt_Name /= No_Name then Free (Selected_Target); Selected_Target := new String'(Get_Name_String (Tgt_Name)); end if; end; end if; end Get_Project_Target; --------------------------- -- Get_Project_Attribute -- --------------------------- procedure Get_Project_Attribute (Lang_Map : in out Language_Maps.Map; Attr_Name : Name_Id) is Element : Array_Element; Id : Array_Element_Id; Lang : Name_Id; Proj : Project_Id; CL : Language_Maps.Cursor; OK : Boolean; begin Proj := Project; while Proj /= No_Project loop Id := Value_Of (Attr_Name, Proj.Decl.Arrays, Shared); while Id /= No_Array_Element loop Element := Shared.Array_Elements.Table (Id); Lang := Element.Index; Lang_Map.Insert (Lang, Element.Value.Value, CL, OK); Id := Element.Next; end loop; Proj := Proj.Extends; end loop; end Get_Project_Attribute; ----------------------- -- Default_CGPR_Name -- ----------------------- function Default_CGPR_Name return String is Ada_RTS : constant String := Runtime_Name_For (Name_Ada); GPR_CONFIG_Var : constant String := "GPR_CONFIG"; -- Name of the environment variable that provides the name of the -- configuration file to use or dir in which to look it up. CGPR_From_Platform : constant String := (if Selected_Target'Length > 0 then (if Ada_RTS /= "" then Selected_Target.all & '-' & Ada_RTS else Selected_Target.all ) elsif Ada_RTS /= "" then Ada_RTS else "default" ) & Config_Project_File_Extension; -- Name of default configuration file for the platform - depending -- on what if anything is explicitly defined this is either -- -.cgpr, .gpr, .gpr, or default.cgpr. begin -- Check if GPR_CONFIG is defined; if defined then provided it's a -- dir look for platform cgpr in it, otherwise use it directly; if -- not defined look for platform cgpr in the current dir. if Ada.Environment_Variables.Exists (GPR_CONFIG_Var) then declare GPR_CONFIG : constant String := Ada.Environment_Variables.Value (GPR_CONFIG_Var); begin if Is_Directory (GPR_CONFIG) then return GPR_CONFIG & Directory_Separator & CGPR_From_Platform; else return GPR_CONFIG; end if; end; else return CGPR_From_Platform; end if; end Default_CGPR_Name; ----------------- -- Do_Autoconf -- ----------------- procedure Do_Autoconf is Obj_Dir : constant Variable_Value := Value_Of (Name_Object_Dir, Conf_Project.Decl.Attributes, Shared); Gprconfig_Path : String_Access; begin -- First look for gprconfig at current exec prefix declare Prefix : constant String := Executable_Prefix_Path; begin if Prefix /= "" then Gprconfig_Path := Locate_Exec_On_Path (Prefix & "bin" & Directory_Separator & Gprconfig_Name); end if; end; -- If not found, search on PATH if Gprconfig_Path = null then Gprconfig_Path := Locate_Exec_On_Path (Gprconfig_Name); end if; -- If still not found, abort if Gprconfig_Path = null then raise Invalid_Config with "could not locate gprconfig for auto-configuration"; end if; -- First, find the object directory of the Conf_Project -- If the object directory is a relative one and Build_Tree_Dir is -- set, first add it. Name_Len := 0; if Obj_Dir.Value = No_Name or else Obj_Dir.Default then if Build_Tree_Dir /= null then Add_Str_To_Name_Buffer (Build_Tree_Dir.all); if Get_Name_String (Conf_Project.Directory.Display_Name)'Length < Root_Dir'Length then raise Invalid_Config with "cannot relocate deeper than object directory"; end if; Add_Str_To_Name_Buffer (Relative_Path (Get_Name_String (Conf_Project.Directory.Display_Name), Root_Dir.all)); else Get_Name_String (Conf_Project.Directory.Display_Name); end if; else if Is_Absolute_Path (Get_Name_String (Obj_Dir.Value)) then Get_Name_String (Obj_Dir.Value); else if Build_Tree_Dir /= null then if Get_Name_String (Conf_Project.Directory.Display_Name)'Length < Root_Dir'Length then raise Invalid_Config with "cannot relocate deeper than object directory"; end if; Add_Str_To_Name_Buffer (Build_Tree_Dir.all); Add_Str_To_Name_Buffer (Relative_Path (Get_Name_String (Conf_Project.Directory.Display_Name), Root_Dir.all)); else Get_Name_String_And_Append (Conf_Project.Directory.Display_Name); end if; Get_Name_String_And_Append (Obj_Dir.Value); end if; end if; if Subdirs /= null then Add_Char_To_Name_Buffer (Directory_Separator); Add_Str_To_Name_Buffer (Subdirs.all); end if; for J in 1 .. Name_Len loop if Name_Buffer (J) = '/' then Name_Buffer (J) := Directory_Separator; end if; end loop; -- Make sure that Obj_Dir ends with a directory separator if Name_Buffer (Name_Len) /= Directory_Separator then Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Directory_Separator; end if; declare Obj_Dir : constant String := Normalize_Pathname (Name_Buffer (1 .. Name_Len), Resolve_Links => False); Config_Switches : Argument_List_Access; Db_Switches : Argument_List_Access; Args : Argument_List (1 .. 7); Comm_Line_Opt : Argument_List_Access; Arg_Last : Positive; begin -- Get the config switches. This should be done only now, as some -- runtimes may have been found in the Builder switches. Config_Switches := Get_Config_Switches; -- Get eventual --db switches Db_Switches := Get_Db_Switches; -- Invoke gprconfig Args (1) := new String'("--batch"); Args (2) := new String'("-o"); -- If no config file was specified, create a temporary one if Conf_File_Name'Length = 0 then declare Current_Dir : constant String := Get_Current_Dir; Path_FD : File_Descriptor; Path_Name : Path_Name_Type; begin if Is_Directory (GPR.Tempdir.Temporary_Directory_Path) then Set_Directory (GPR.Tempdir.Temporary_Directory_Path); else raise Invalid_Config with "No temp dir specified"; end if; GPR.Env.Create_Temp_File (Shared => Project_Tree.Shared, Path_FD => Path_FD, Path_Name => Path_Name, File_Use => "configuration project"); if Path_FD /= Invalid_FD then Close (Path_FD); Args (3) := new String'(Get_Name_String (Path_Name)); else -- We'll have an error message later on Args (3) := new String'(Obj_Dir & Auto_Cgpr); end if; Set_Directory (Current_Dir); end; else Args (3) := new String'(Conf_File_Name.all); end if; Arg_Last := 3; if Selected_Target /= null and then Selected_Target.all /= "" then Args (4) := new String'("--target=" & Selected_Target.all); Arg_Last := 4; elsif Normalized_Hostname /= "" then if At_Least_One_Compiler_Command then Args (4) := new String'("--target=all"); else Args (4) := new String'("--target=" & Normalized_Hostname); end if; Arg_Last := 4; end if; if Native_Target then Arg_Last := Arg_Last + 1; Args (Arg_Last) := new String'("--fallback-targets"); end if; if Verbosity_Level <= Low then Arg_Last := Arg_Last + 1; Args (Arg_Last) := new String'("-q"); end if; if Opt.Verbose_Mode and then Opt.Verbosity_Level > Opt.Low then if Opt.Verbosity_Level = Opt.High then Write_Str (Gprconfig_Path.all); else Write_Str (Gprconfig_Name); end if; for J in 1 .. Arg_Last loop Write_Char (' '); Write_Str (Args (J).all); end loop; for J in Config_Switches'Range loop Write_Char (' '); Write_Str (Config_Switches (J).all); end loop; for J in Db_Switches'Range loop Write_Char (' '); Write_Str (Db_Switches (J).all); end loop; Write_Eol; elsif not Quiet_Output then -- Display no message if we are creating auto.cgpr, unless in -- verbose mode. if Config_File_Name'Length > 0 or else Opt.Verbosity_Level > Opt.Low then Write_Str ("creating "); Write_Str (Simple_Name (Args (3).all)); Write_Eol; end if; end if; Comm_Line_Opt := new Argument_List (1 .. Integer (Gprconfig_Options.Length)); declare CL_Index : Integer := 1; begin for Opt of Gprconfig_Options loop Comm_Line_Opt (CL_Index) := new String'(Opt); CL_Index := CL_Index + 1; end loop; end; Spawn (Gprconfig_Path.all, Args (1 .. Arg_Last) & Config_Switches.all & Db_Switches.all & Comm_Line_Opt.all, Auto_Configuration_Success); Free (Config_Switches); Free (Comm_Line_Opt); Free (Gprconfig_Path); Config_File_Path := Locate_Config_File (Args (3).all); if Config_File_Path = null then raise Invalid_Config with "could not create " & Args (3).all; end if; for F in Args'Range loop Free (Args (F)); end loop; end; end Do_Autoconf; --------------------- -- Get_Db_Switches -- --------------------- function Get_Db_Switches return Argument_List_Access is Result : Argument_List_Access; Nmb_Arg : Natural; begin Nmb_Arg := (2 * Db_Switch_Args.Last) + Boolean'Pos (not Load_Standard_Base); Result := new Argument_List (1 .. Nmb_Arg); if Nmb_Arg /= 0 then for J in 1 .. Db_Switch_Args.Last loop Result (2 * J - 1) := new String'("--db"); Result (2 * J) := new String'(Get_Name_String (Db_Switch_Args.Table (J))); end loop; if not Load_Standard_Base then Result (Result'Last) := new String'("--db-"); end if; end if; return Result; end Get_Db_Switches; --------------------- -- Get_Config_File -- --------------------- procedure Get_Config_File is Variable : Variable_Value; begin if Conf_File_Name'Length /= 0 then return; end if; Variable := Value_Of (Name_Config_Prj_File, Project.Decl.Attributes, Shared); if Variable /= Nil_Variable_Value then Free (Conf_File_Name); Conf_File_Name := new String'(Get_Name_String (Variable.Value)); end if; end Get_Config_File; ------------------------- -- Get_Config_Switches -- ------------------------- function Get_Config_Switches return Argument_List_Access is Language_Htable : Language_Maps.Map; IDE : constant Package_Id := Value_Of (Name_Ide, Project.Decl.Packages, Shared); procedure Add_Config_Switches_For_Project (Project : Project_Id; Tree : Project_Tree_Ref; With_State : in out Integer); -- Add all --config switches for this project. This is also called -- for aggregate projects. ------------------------------------- -- Add_Config_Switches_For_Project -- ------------------------------------- procedure Add_Config_Switches_For_Project (Project : Project_Id; Tree : Project_Tree_Ref; With_State : in out Integer) is pragma Unreferenced (With_State); Shared : constant Shared_Project_Tree_Data_Access := Tree.Shared; Variable : Variable_Value; Check_Default : Boolean; Lang : Name_Id; List : String_List_Id; Elem : String_Element; Current_Array_Id : Array_Id; Current_Array : Array_Data; Element_Id : Array_Element_Id; Element : Array_Element; CL : Language_Maps.Cursor; OK : Boolean; begin -- Required_Toolchain_Version processing Current_Array_Id := Project.Decl.Arrays; while Current_Array_Id /= No_Array loop Current_Array := Shared.Arrays.Table (Current_Array_Id); Element_Id := Current_Array.Value; while Element_Id /= No_Array_Element loop Element := Shared.Array_Elements.Table (Element_Id); if Current_Array.Name = Name_Required_Toolchain_Version then -- Attribute Required_Toolchain_Version () Language_Htable.Insert (Element.Index, Element.Value.Value, CL, OK); if not OK and then Language_Htable (CL) /= Element.Value.Value then if Language_Htable (CL) /= No_Name then raise Invalid_Config with "Attributes Required_Toolchain_Version differ in" & " projects tree"; end if; Language_Htable (CL) := Element.Value.Value; end if; end if; Element_Id := Element.Next; end loop; Current_Array_Id := Current_Array.Next; end loop; Variable := Value_Of (Name_Languages, Project.Decl.Attributes, Shared); if Variable = Nil_Variable_Value or else Variable.Default then -- Languages is not declared. If it is not an extending -- project, or if it extends a project with no Languages, -- check for Default_Language. Check_Default := Project.Extends = No_Project; if not Check_Default then Variable := Value_Of (Name_Languages, Project.Extends.Decl.Attributes, Shared); Check_Default := Variable /= Nil_Variable_Value and then Variable.Values = Nil_String; end if; if Check_Default then Variable := Value_Of (Name_Default_Language, Project.Decl.Attributes, Shared); if Variable /= Nil_Variable_Value and then not Variable.Default then Get_Name_String (Variable.Value); To_Lower (Name_Buffer (1 .. Name_Len)); Lang := Name_Find; Language_Htable.Insert (Lang, No_Name, CL, OK); -- If no default language is declared, default to Ada else Language_Htable.Insert (Name_Ada, No_Name, CL, OK); end if; end if; elsif Variable.Values /= Nil_String then -- Attribute Languages is declared with a non empty list: -- put all the languages in Language_HTable. List := Variable.Values; while List /= Nil_String loop Elem := Shared.String_Elements.Table (List); Get_Name_String (Elem.Value); To_Lower (Name_Buffer (1 .. Name_Len)); Lang := Name_Find; Language_Htable.Insert (Lang, No_Name, CL, OK); List := Elem.Next; end loop; end if; end Add_Config_Switches_For_Project; procedure For_Every_Imported_Project is new For_Every_Project_Imported (State => Integer, Action => Add_Config_Switches_For_Project); -- Document this procedure ??? -- Local variables Name : Name_Id; Count : Natural; Result : Argument_List_Access; Variable : Variable_Value; Dummy : Integer := 0; -- Start of processing for Get_Config_Switches begin For_Every_Imported_Project (By => Project, Tree => Project_Tree, With_State => Dummy, Include_Aggregated => True); Result := new String_List (1 .. Natural (Language_Htable.Length)); Count := 0; for CL in Language_Htable.Iterate loop Name := Language_Maps.Key (CL); if (not CodePeer_Mode or else Name = Name_Ada) and then Is_Allowed_Language (Name) then Count := Count + 1; -- Check if IDE'Compiler_Command is declared for the language. -- If it is, use its value to invoke gprconfig. Variable := Value_Of (Name, Attribute_Or_Array_Name => Name_Compiler_Command, In_Package => IDE, Shared => Shared, Force_Lower_Case_Index => True); declare Version : constant String := Get_Name_String_Or_Null (Language_Maps.Element (CL)); Ver_First : constant Positive := Version'First + (if Name = Name_Ada and then Starts_With (Version, GNAT_And_Space) then GNAT_And_Space'Length else 0); Config_Common : constant String := "--config=" & Get_Name_String (Name) & ',' & Version (Ver_First .. Version'Last) & ',' & Runtime_Name_For (Name) & ','; begin -- In CodePeer mode, we do not take into account any -- compiler command from the package IDE. if CodePeer_Mode or else Variable = Nil_Variable_Value or else Variable.Value = Empty_String then Result (Count) := new String' (Config_Common & Get_Element_Or_Empty (Toolchain_Paths, Name) & ',' & Toolchain_Name_For (Name)); else At_Least_One_Compiler_Command := True; declare Compiler_Command : constant String := Get_Name_String (Variable.Value); begin if Is_Absolute_Path (Compiler_Command) then Result (Count) := new String' (Config_Common & Containing_Directory (Compiler_Command) & "," & Simple_Name (Compiler_Command)); else Result (Count) := new String' (Config_Common & ',' & Compiler_Command); end if; end; end if; end; end if; end loop; if Count = 0 then Free (Result); raise Invalid_Config with "project has no languages"; elsif Count /= Result'Last then Result := new String_List'(Result (1 .. Count)); end if; return Result; end Get_Config_Switches; ------------------ -- Is_Base_Name -- ------------------ function Is_Base_Name (Path : String) return Boolean is begin for I in Path'Range loop if Path (I) = Directory_Separator or else Path (I) = '/' then return False; end if; end loop; return True; end Is_Base_Name; -- Local Variables Success : Boolean; Config_Project_Node : Project_Node_Id := Empty_Project_Node; -- Start of processing for Get_Or_Create_Configuration_File begin pragma Assert (GPR.Env.Is_Initialized (Env.Project_Path)); Free (Config_File_Path); Config := No_Project; Get_Project_Target; -- Get the various Toolchain_Name () in the project file or any -- project it extends, if any are specified. Get_Project_Attribute (Toolchain_Languages, Name_Toolchain_Name); -- Get the various Toolchain_Path () in the project file or any -- project it extends, if any are specified. Get_Project_Attribute (Toolchain_Paths, Name_Toolchain_Path); -- Get the various Runtime () in the project file or any project -- it extends, if any are specified. Get_Project_Attribute (RTS_Languages, Name_Runtime); -- Get the config file specified by corresponding attribute before -- checking for legacy way of specifying it in Builder switches. Get_Config_File; Check_Builder_Switches; -- Makes the Ada RTS absolute if it is not a base name and check if the -- runtime directory is a valid one. if Runtime_Name_Set_For (Name_Ada) then declare Runtime_Dir : constant String := Runtime_Name_For (Name_Ada); RTS_Dir : String_Access := null; OK : Boolean := True; begin if Is_Absolute_Path (Runtime_Dir) then RTS_Dir := new String'(Normalize_Pathname (Runtime_Dir)); elsif Runtime_Dir'Length /= 0 then declare Dir : constant String := Normalize_Pathname (Get_Name_String (Project.Directory.Display_Name) & Directory_Separator & Runtime_Dir); Runtime_Path : constant String := Ada.Environment_Variables.Value ("GPR_RUNTIME_PATH", ""); begin if Dir'Length > 0 and then Is_Directory (Dir) then RTS_Dir := new String'(Dir); else -- If Environment variable GPR_RUNTIME_PATH is defined, -- look for the runtime directory in this path. if Runtime_Path'Length > 0 then RTS_Dir := Locate_Directory (Dir_Name => Runtime_Dir, Path => Runtime_Path); end if; if RTS_Dir = null then if not Is_Base_Name (Runtime_Dir) then OK := False; RTS_Dir := new String'(Runtime_Dir); end if; end if; end if; end; end if; -- If RTS_Dir is null, it means that the runtime dir is -- specified as an empty string, or as a base name that is not a -- subdirectory of the project directory. In this case, gprconfig -- is invoked with the simple name. if RTS_Dir /= null then if OK then OK := (Is_Directory (RTS_Dir.all & Directory_Separator & "adalib") or else Is_Regular_File (RTS_Dir.all & Directory_Separator & "ada_object_path")) and then (Is_Directory (RTS_Dir.all & Directory_Separator & "adainclude") or else Is_Regular_File (RTS_Dir.all & Directory_Separator & "ada_source_path")); end if; if OK then Set_Runtime_For (Name_Ada, RTS_Dir.all); -- Do not fail if the runtime directory is a base name, as -- there may be a subdirectory of the project directory with -- this name, but it is really a runtime that need to be found -- by gprconfig. elsif not Is_Base_Name (Runtime_Dir) then raise Invalid_Config with "invalid runtime directory " & RTS_Dir.all; end if; Free (RTS_Dir); end if; end; end if; -- Do not attempt to find a configuration project file when -- Config_File_Name is No_Configuration_File. if Config_File_Name = No_Configuration_File then Config_File_Path := null; elsif Conf_File_Name'Length > 0 then declare CFN : constant String := Ensure_Extension (Conf_File_Name.all, Config_Project_File_Extension); begin Config_File_Path := Locate_Config_File (CFN); if Config_File_Path = null and then not Allow_Automatic_Generation then raise Invalid_Config with "could not locate main configuration project " & CFN; end if; end; else Config_File_Path := Locate_Config_File (Default_CGPR_Name); end if; Automatically_Generated := Allow_Automatic_Generation and then Config_File_Path = null; <> if Automatically_Generated then -- This might raise an Invalid_Config exception Do_Autoconf; -- If the config file is not auto-generated, warn if there is any --RTS -- switch, but not when the config file is generated in memory. elsif Warn_For_RTS and then not RTS_Languages.Is_Empty and then Opt.Warning_Mode /= Opt.Suppress and then On_Load_Config = null then Write_Line ("warning: " & "runtimes are taken into account only in auto-configuration"); end if; -- Parse the configuration file if Opt.Verbosity_Level > Opt.Low and then Config_File_Path /= null then Write_Str ("Checking configuration "); Write_Line (Config_File_Path.all); end if; if Config_File_Path /= null then Part.Parse (In_Tree => Project_Node_Tree, Project => Config_Project_Node, Project_File_Name => Config_File_Path.all, Errout_Handling => Part.Finalize_If_Error, Packages_To_Check => Packages_To_Check, Current_Directory => Get_Current_Dir, Is_Config_File => True, Env => Env); else Config_Project_Node := Empty_Project_Node; end if; if On_Load_Config /= null then On_Load_Config (Config_File => Config_Project_Node, Project_Node_Tree => Project_Node_Tree); end if; if Present (Config_Project_Node) then Proc.Process_Project_Tree_Phase_1 (In_Tree => Project_Tree, Project => Config, Packages_To_Check => Packages_To_Check, Success => Success, From_Project_Node => Config_Project_Node, From_Project_Node_Tree => Project_Node_Tree, Env => Env, Reset_Tree => False, On_New_Tree_Loaded => null); end if; if No (Config_Project_Node) or else Config = No_Project then raise Invalid_Config with "processing of configuration project """ & Config_File_Path.all & """ failed"; end if; -- Check that the target of the configuration file is the one the user -- specified on the command line. We do not need to check that when in -- auto-conf mode, since the appropriate target was passed to gprconfig. if not Automatically_Generated and then not Check_Target (Config, Autoconf_Specified, Project_Tree, Selected_Target.all) then Automatically_Generated := True; goto Process_Config_File; end if; Free (Conf_File_Name); Free (Selected_Target); end Get_Or_Create_Configuration_File; ------------------------ -- Locate_Config_File -- ------------------------ function Locate_Config_File (Name : String) return String_Access is Prefix_Path : constant String := Executable_Prefix_Path; begin if Prefix_Path'Length /= 0 then return Locate_Regular_File (Name, "." & Path_Separator & Prefix_Path & "share" & Directory_Separator & "gpr"); else return Locate_Regular_File (Name, "."); end if; end Locate_Config_File; ------------------------------------ -- Parse_Project_And_Apply_Config -- ------------------------------------ procedure Parse_Project_And_Apply_Config (Main_Project : out Project_Id; User_Project_Node : out Project_Node_Id; Config_File_Name : String := ""; Autoconf_Specified : Boolean; Project_File_Name : String; Project_Tree : Project_Tree_Ref; Project_Node_Tree : Tree.Project_Node_Tree_Ref; Env : in out Tree.Environment; Packages_To_Check : String_List_Access; Allow_Automatic_Generation : Boolean := True; Automatically_Generated : out Boolean; Config_File_Path : out String_Access; Target_Name : String := ""; Normalized_Hostname : String; On_Load_Config : Config_File_Hook := null; Implicit_Project : Boolean := False; On_New_Tree_Loaded : Proc.Tree_Loaded_Callback := null; Gprconfig_Options : String_Vectors.Vector := String_Vectors.Empty_Vector) is Success : Boolean := False; Target_Try_Again : Boolean := True; Config_Try_Again : Boolean; Fallback_Try_Again : Boolean := True; Store_Flags : Processing_Flags; Store_Create_Dirs : Dir_Creation_Mode; N_Hostname : String_Access := new String'(Normalized_Hostname); Finalization : Part.Errout_Mode := Part.Always_Finalize; Conf_File_Name : String_Access; Auto_Generated : Boolean; type Path_Names_Arr is array (Positive range <>) of Path_Name_Type; type Path_Names_Ref is access Path_Names_Arr; Path_Names : Path_Names_Ref := null; begin pragma Assert (GPR.Env.Is_Initialized (Env.Project_Path)); -- Start with ignoring missing withed projects Set_Ignore_Missing_With (Env.Flags, True); -- Note: If in fact the config file is automatically generated, then -- Automatically_Generated will be set to True after invocation of -- Process_Project_And_Apply_Config. Automatically_Generated := False; -- Record Target_Value and Target_Origin if Target_Name = "" then Opt.Target_Value := new String'(N_Hostname.all); Opt.Target_Value_Canonical := new String'(N_Hostname.all); Opt.Target_Origin := Default; Native_Target := True; Store_Flags := Env.Flags; Set_Require_Obj_Dirs (Env.Flags, Silent); Set_Check_Configuration_Only (Env.Flags, True); Set_Missing_Source_Files (Env.Flags, Silent); Env.Flags.Missing_Project_Files := Decide_Later; Store_Create_Dirs := Create_Dirs; Create_Dirs := Never_Create_Dirs; else Opt.Target_Value := new String'(Target_Name); Opt.Target_Origin := Specified; declare Tgt : constant String := Target_Name; begin Opt.Target_Value_Canonical := new String'(Knowledge.Normalized_Target (Tgt)); end; -- Target specified explicitly, no point for fallback check Fallback_Try_Again := False; end if; <> Conf_File_Name := new String'(Config_File_Name); -- Parse the user project tree Project_Node_Tree.Incomplete_With := False; Env.Flags.Incomplete_Withs := False; -- Save the temporary files, if any, and initialize the project tree declare use GPR.Temp_Files_Table; begin if not Opt.Keep_Temporary_Files and then Project_Tree.Shared /= null and then Project_Tree.Shared.Private_Part.Temp_Files.Table /= null and then Temp_Files_Table.Last (Project_Tree.Shared.Private_Part.Temp_Files) > 0 then Path_Names := new Path_Names_Arr (1 .. Temp_Files_Table.Last (Project_Tree.Shared.Private_Part.Temp_Files)); for J in Path_Names'Range loop Path_Names (J) := Project_Tree.Shared.Private_Part.Temp_Files.Table (J); end loop; end if; end; GPR.Initialize (Project_Tree); -- Put back the temporary files if Path_Names /= null then for J in Path_Names'Range loop Record_Temp_File (Project_Tree.Shared, Path_Names (J)); end loop; Path_Names := null; end if; Main_Project := No_Project; GPR.Env.Reset_Cache (Env.Project_Path); GPR.Part.Parse (In_Tree => Project_Node_Tree, Project => User_Project_Node, Project_File_Name => Project_File_Name, Errout_Handling => Finalization, Packages_To_Check => Packages_To_Check, Current_Directory => Get_Current_Dir, Is_Config_File => False, Env => Env, Implicit_Project => Implicit_Project); Finalization := GPR.Part.Finalize_If_Error; if No (User_Project_Node) then return; end if; Main_Project := No_Project; Process_Project_Tree_Phase_1 (In_Tree => Project_Tree, Project => Main_Project, Packages_To_Check => Packages_To_Check, Success => Success, From_Project_Node => User_Project_Node, From_Project_Node_Tree => Project_Node_Tree, Env => Env, Reset_Tree => True, On_New_Tree_Loaded => On_New_Tree_Loaded); if not Success then Main_Project := No_Project; return; end if; if not Fallback_Try_Again and then Create_Dirs /= Create_All_Dirs then -- Check if attribute Create_Missing_Dirs is specified with value -- "true". declare Variable : constant Variable_Value := Value_Of (Name_Create_Missing_Dirs, Main_Project.Decl.Attributes, Project_Tree.Shared); begin if Variable /= Nil_Variable_Value and then not Variable.Default then Get_Name_String (Variable.Value); declare Do_Create : Boolean; begin Do_Create := Boolean'Value (Name_Buffer (1 .. Name_Len)); if Do_Create then Create_Dirs := Create_All_Dirs; end if; exception when Constraint_Error => raise Invalid_Config with "inconsistent value of attribute Create_Missing_Dirs"; end; end if; end; end if; -- If --target was not specified on the command line, then check if -- attribute Target is declared in the main project. if not Env.Flags.Incomplete_Withs and then Opt.Target_Origin /= Specified then declare Variable : constant Variable_Value := Value_Of (Name_Target, Main_Project.Decl.Attributes, Project_Tree.Shared); begin if Variable /= Nil_Variable_Value and then not Variable.Default then if Get_Name_String (Variable.Value) = Opt.Target_Value.all then if not Variable.From_Implicit_Target then Native_Target := False; end if; elsif Target_Try_Again then Opt.Target_Value := new String'(Get_Name_String (Variable.Value)); Opt.Target_Value_Canonical := new String'(Knowledge.Normalized_Target (Opt.Target_Value.all)); Target_Try_Again := False; -- Target explicitly specified in the project file, -- undo fallback preparations. Fallback_Try_Again := False; Env.Flags := Store_Flags; Create_Dirs := Store_Create_Dirs; goto Parse_Again; else raise Invalid_Config with "inconsistent value of attribute Target"; end if; end if; end; end if; -- If there are missing withed projects, the projects will be parsed -- again after the project path is extended with directories rooted -- at the compiler roots. Config_Try_Again := Fallback_Try_Again or Project_Node_Tree.Incomplete_With; Process_Project_And_Apply_Config (Main_Project => Main_Project, User_Project_Node => User_Project_Node, Config_File_Name => Conf_File_Name.all, Autoconf_Specified => Autoconf_Specified, Project_Tree => Project_Tree, Project_Node_Tree => Project_Node_Tree, Env => Env, Packages_To_Check => Packages_To_Check, Allow_Automatic_Generation => Allow_Automatic_Generation, Automatically_Generated => Auto_Generated, Config_File_Path => Config_File_Path, Target_Name => Target_Name, Normalized_Hostname => N_Hostname.all, On_Load_Config => On_Load_Config, On_New_Tree_Loaded => On_New_Tree_Loaded, Do_Phase_1 => False, Gprconfig_Options => Gprconfig_Options); if Auto_Generated then Automatically_Generated := True; end if; if Main_Project /= No_Project then if Fallback_Try_Again then if not Env.Flags.Incomplete_Withs and then Auto_Generated then declare Variable : constant Variable_Value := Value_Of (Name_Target, Main_Project.Decl.Attributes, Project_Tree.Shared); begin if Native_Target and then Opt.Target_Value.all /= Get_Name_String (Variable.Value) then -- The target is not the default one. Try again with -- the new one. Free (N_Hostname); N_Hostname := new String'(Get_Name_String (Variable.Value)); Free (Opt.Target_Value); Free (Opt.Target_Value_Canonical); Opt.Target_Value := new String'(N_Hostname.all); Opt.Target_Value_Canonical := new String'(N_Hostname.all); Success := False; Target_Try_Again := True; Fallback_Try_Again := False; Env.Flags := Store_Flags; Create_Dirs := Store_Create_Dirs; Warn_For_RTS := False; goto Parse_Again; end if; end; end if; -- Restore the flags and cancel Fallback_Try_Again Env.Flags := Store_Flags; Create_Dirs := Store_Create_Dirs; Fallback_Try_Again := False; end if; end if; -- Add the default directories corresponding to the compilers Update_Project_Search_Path (Main_Project, Project_Tree, Env); -- If there was no error and Config_Try_Again is True, update the -- project path and try again. if Main_Project /= No_Project and then Config_Try_Again then Config_Try_Again := False; Set_Ignore_Missing_With (Env.Flags, False); if Config_File_Path /= null then Conf_File_Name := new String'(Config_File_Path.all); end if; -- For the second time the project files are parsed, the warning for -- --RTS= being only taken into account in auto-configuration are -- suppressed, as we are no longer in auto-configuration. Warn_For_RTS := False; -- And parse again the project files. There will be no missing -- withed projects, as Ignore_Missing_With is set to False in -- the environment flags, so there is no risk of endless loop here. goto Parse_Again; end if; end Parse_Project_And_Apply_Config; -------------------------------- -- Update_Project_Search_Path -- -------------------------------- procedure Update_Project_Search_Path (Project : Project_Id; Project_Tree : Project_Tree_Ref; Env : in out Tree.Environment) is S : State := No_State; procedure Add_Directory (Dir : String); -- Add a directory at the end of the Project Path procedure Free_Pointers (Ptr : in out Compiler_Root_Ptr); -- Clean up temporary compiler data gathered during path search Compiler_Root : Compiler_Root_Ptr; Prefix : String_Access; Runtime_Root : Runtime_Root_Ptr; Path_Value : constant String_Access := Getenv ("PATH"); ------------------- -- Add_Directory -- ------------------- procedure Add_Directory (Dir : String) is begin if Opt.Verbosity_Level > Opt.Low then Write_Line (" Adding directory """ & Dir & """"); end if; GPR.Env.Add_Directories (Env.Project_Path, Dir); end Add_Directory; ------------------- -- Free_Pointers -- ------------------- procedure Free_Pointers (Ptr : in out Compiler_Root_Ptr) is procedure Free is new Ada.Unchecked_Deallocation (Compiler_Root_Data, Compiler_Root_Ptr); procedure Free is new Ada.Unchecked_Deallocation (Runtime_Root_Data, Runtime_Root_Ptr); procedure Free_Runtimes (Ptr : in out Runtime_Root_Ptr); ------------------- -- Free_Runtimes -- ------------------- procedure Free_Runtimes (Ptr : in out Runtime_Root_Ptr) is begin if Ptr = null then return; end if; Free_Runtimes (Ptr.Next); Free (Ptr.Root); Free (Ptr); end Free_Runtimes; begin if Ptr = null then return; end if; Free_Pointers (Ptr.Next); Free (Ptr.Root); Free_Runtimes (Ptr.Runtimes); Free (Ptr); end Free_Pointers; begin if Project = No_Project or else Project_Tree = No_Project_Tree then return; end if; Update_Project_Path (By => Project, Tree => Project_Tree, With_State => S, Include_Aggregated => True, Imported_First => False); if Opt.Verbosity_Level > Opt.Low then Write_Line ("Setting the default project search directories"); if GPR.Current_Verbosity = High then if Path_Value = null or else Path_Value'Length = 0 then Write_Line ("No environment variable PATH"); else Write_Line ("PATH ="); Write_Line (" " & Path_Value.all); end if; end if; end if; -- Reorder the compiler roots in the PATH order if First_Compiler_Root /= null and then First_Compiler_Root.Next /= null then declare Pred : Compiler_Root_Ptr; First_New_Comp : Compiler_Root_Ptr := null; New_Comp : Compiler_Root_Ptr := null; First : Positive := Path_Value'First; Last : Positive; Path_Last : Positive; begin while First <= Path_Value'Last loop Last := First; if Path_Value (First) /= Path_Separator then while Last < Path_Value'Last and then Path_Value (Last + 1) /= Path_Separator loop Last := Last + 1; end loop; Path_Last := Last; while Path_Last > First and then Path_Value (Path_Last) = Directory_Separator loop Path_Last := Path_Last - 1; end loop; if Path_Last > First + 4 and then Path_Value (Path_Last - 2 .. Path_Last) = "bin" and then Path_Value (Path_Last - 3) = Directory_Separator then Path_Last := Path_Last - 4; Pred := null; Compiler_Root := First_Compiler_Root; while Compiler_Root /= null and then Compiler_Root.Root.all /= Path_Value (First .. Path_Last) loop Pred := Compiler_Root; Compiler_Root := Compiler_Root.Next; end loop; if Compiler_Root /= null then if Pred = null then First_Compiler_Root := First_Compiler_Root.Next; else Pred.Next := Compiler_Root.Next; end if; if First_New_Comp = null then First_New_Comp := Compiler_Root; else New_Comp.Next := Compiler_Root; end if; New_Comp := Compiler_Root; New_Comp.Next := null; end if; end if; end if; First := Last + 1; end loop; if First_New_Comp /= null then New_Comp.Next := First_Compiler_Root; First_Compiler_Root := First_New_Comp; end if; end; end if; -- Now that the compiler roots are in a correct order, add the -- directories corresponding to these compiler roots in the -- project path. Compiler_Root := First_Compiler_Root; while Compiler_Root /= null loop Prefix := Compiler_Root.Root; Runtime_Root := Compiler_Root.Runtimes; while Runtime_Root /= null loop Add_Directory (Runtime_Root.Root.all & Directory_Separator & "share" & Directory_Separator & "gpr"); Add_Directory (Runtime_Root.Root.all & Directory_Separator & "lib" & Directory_Separator & "gnat"); Runtime_Root := Runtime_Root.Next; end loop; Add_Directory (Prefix.all & Directory_Separator & Opt.Target_Value.all & Directory_Separator & "share" & Directory_Separator & "gpr"); Add_Directory (Prefix.all & Directory_Separator & Opt.Target_Value.all & Directory_Separator & "lib" & Directory_Separator & "gnat"); declare CT_Variable : constant Variable_Value := Value_Of (Name_Canonical_Target, Project.Decl.Attributes, Project_Tree.Shared); Canonical_Target : constant String := Get_Name_String (CT_Variable.Value); begin if Canonical_Target not in Opt.Target_Value.all | "" then Add_Directory (Prefix.all & Directory_Separator & Canonical_Target & Directory_Separator & "share" & Directory_Separator & "gpr"); Add_Directory (Prefix.all & Directory_Separator & Canonical_Target & Directory_Separator & "lib" & Directory_Separator & "gnat"); end if; end; Add_Directory (Prefix.all & Directory_Separator & "share" & Directory_Separator & "gpr"); Add_Directory (Prefix.all & Directory_Separator & "lib" & Directory_Separator & "gnat"); Compiler_Root := Compiler_Root.Next; end loop; -- Need to reset compilers for possible future reloads. Free_Pointers (First_Compiler_Root); end Update_Project_Search_Path; -------------------------------------- -- Process_Project_And_Apply_Config -- -------------------------------------- procedure Process_Project_And_Apply_Config (Main_Project : out Project_Id; User_Project_Node : Project_Node_Id; Config_File_Name : String := ""; Autoconf_Specified : Boolean; Project_Tree : Project_Tree_Ref; Project_Node_Tree : Tree.Project_Node_Tree_Ref; Env : in out Tree.Environment; Packages_To_Check : String_List_Access; Allow_Automatic_Generation : Boolean := True; Automatically_Generated : out Boolean; Config_File_Path : out String_Access; Target_Name : String := ""; Normalized_Hostname : String; On_Load_Config : Config_File_Hook := null; Reset_Tree : Boolean := True; On_New_Tree_Loaded : Proc.Tree_Loaded_Callback := null; Do_Phase_1 : Boolean := True; Gprconfig_Options : String_Vectors.Vector := String_Vectors.Empty_Vector) is Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared; Main_Config_Project : Project_Id; Success : Boolean; Conf_Project : Project_Id := No_Project; -- The object directory of this project is used to store the config -- project file in auto-configuration. Set by Check_Project below. procedure Check_Project (Project : Project_Id); -- Look for a non aggregate project. If one is found, put its project Id -- in Conf_Project. ------------------- -- Check_Project -- ------------------- procedure Check_Project (Project : Project_Id) is begin if Project.Qualifier in Aggregate_Project then declare List : Aggregated_Project_List := Project.Aggregated_Projects; begin -- Look for a non aggregate project until one is found while Conf_Project = No_Project and then List /= null loop Check_Project (List.Project); List := List.Next; end loop; end; else Conf_Project := Project; end if; end Check_Project; -- Start of processing for Process_Project_And_Apply_Config begin Automatically_Generated := False; if Do_Phase_1 then Main_Project := No_Project; Process_Project_Tree_Phase_1 (In_Tree => Project_Tree, Project => Main_Project, Packages_To_Check => Packages_To_Check, Success => Success, From_Project_Node => User_Project_Node, From_Project_Node_Tree => Project_Node_Tree, Env => Env, Reset_Tree => Reset_Tree, On_New_Tree_Loaded => On_New_Tree_Loaded); if not Success then Main_Project := No_Project; return; end if; end if; if Project_Tree.Source_Info_File_Name /= null then if not Is_Absolute_Path (Project_Tree.Source_Info_File_Name.all) then declare Obj_Dir : constant Variable_Value := Value_Of (Name_Object_Dir, Main_Project.Decl.Attributes, Shared); begin if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then Get_Name_String (Main_Project.Directory.Display_Name); else if Is_Absolute_Path (Get_Name_String (Obj_Dir.Value)) then Get_Name_String (Obj_Dir.Value); else Set_Name_Buffer (Get_Name_String (Main_Project.Directory.Display_Name)); Get_Name_String_And_Append (Obj_Dir.Value); end if; end if; Add_Char_To_Name_Buffer (Directory_Separator); Add_Str_To_Name_Buffer (Project_Tree.Source_Info_File_Name.all); Free (Project_Tree.Source_Info_File_Name); Project_Tree.Source_Info_File_Name := new String'(Name_Buffer (1 .. Name_Len)); end; end if; Read_Source_Info_File (Project_Tree); end if; -- Get the first project that is not an aggregate project or an -- aggregate library project. The object directory of this project will -- be used to store the config project file in auto-configuration. Check_Project (Main_Project); -- Fail if there is only aggregate projects and aggregate library -- projects in the project tree. if Conf_Project = No_Project then Messages_Decision (Error); raise Invalid_Config with "there are no non-aggregate projects for" & " project " & Get_Name_String_Safe (Main_Project.Name); else Messages_Decision (Silent); end if; -- Find configuration file Get_Or_Create_Configuration_File (Config => Main_Config_Project, Project => Main_Project, Conf_Project => Conf_Project, Project_Tree => Project_Tree, Project_Node_Tree => Project_Node_Tree, Env => Env, Allow_Automatic_Generation => Allow_Automatic_Generation, Config_File_Name => Config_File_Name, Autoconf_Specified => Autoconf_Specified, Target_Name => Target_Name, Normalized_Hostname => Normalized_Hostname, Packages_To_Check => Packages_To_Check, Config_File_Path => Config_File_Path, Automatically_Generated => Automatically_Generated, On_Load_Config => On_Load_Config, Gprconfig_Options => Gprconfig_Options); Apply_Config_File (Main_Config_Project, Project_Tree); GPR.Proc.Process_Project_Tree_Phase_2 (In_Tree => Project_Tree, Project => Main_Project, Success => Success, From_Project_Node => User_Project_Node, From_Project_Node_Tree => Project_Node_Tree, Env => Env); if Success then if not Env.Flags.Check_Configuration_Only then if Project_Tree.Source_Info_File_Name /= null and then not Project_Tree.Source_Info_File_Exists then Write_Source_Info_File (Project_Tree); end if; end if; else Main_Project := No_Project; end if; end Process_Project_And_Apply_Config; ---------------------- -- Runtime_Name_For -- ---------------------- function Runtime_Name_For (Language : Name_Id) return String is begin return Get_Element_Or_Empty (RTS_Languages, Language); end Runtime_Name_For; -------------------------- -- Runtime_Name_Set_For -- -------------------------- function Runtime_Name_Set_For (Language : Name_Id) return Boolean is begin return RTS_Languages.Contains (Language); end Runtime_Name_Set_For; --------------------- -- Set_Runtime_For -- --------------------- procedure Set_Runtime_For (Language : Name_Id; RTS_Name : String) is begin Name_Len := RTS_Name'Length; Name_Buffer (1 .. Name_Len) := RTS_Name; RTS_Languages.Include (Language, Name_Find); end Set_Runtime_For; ------------------------ -- Toolchain_Name_For -- ------------------------ function Toolchain_Name_For (Language : Name_Id) return String is begin return Get_Element_Or_Empty (Toolchain_Languages, Language); end Toolchain_Name_For; ---------------------------- -- Toolchain_Name_Set_For -- ---------------------------- function Toolchain_Name_Set_For (Language : Name_Id) return Boolean is begin return Toolchain_Languages.Contains (Language); end Toolchain_Name_Set_For; ----------------------- -- Set_Toolchain_For -- ----------------------- procedure Set_Toolchain_For (Language : Name_Id; Toolchain_Name : String) is begin Name_Len := Toolchain_Name'Length; Name_Buffer (1 .. Name_Len) := Toolchain_Name; Toolchain_Languages.Include (Language, Name_Find); end Set_Toolchain_For; ---------------------------- -- Look_For_Project_Paths -- ---------------------------- procedure Look_For_Project_Paths (Project : Project_Id; Tree : Project_Tree_Ref; With_State : in out State) is Lang_Id : Language_Ptr; Compiler_Root : Compiler_Root_Ptr; Runtime_Root : Runtime_Root_Ptr; Comp_Driver : String_Access; Comp_Dir : String_Access; Prefix : String_Access; pragma Unreferenced (Tree); begin With_State := No_State; Lang_Id := Project.Languages; while Lang_Id /= No_Language_Index loop if Lang_Id.Config.Compiler_Driver /= No_File then Comp_Driver := new String' (Get_Name_String (Lang_Id.Config.Compiler_Driver)); -- Get the absolute path of the compiler driver if not Is_Absolute_Path (Comp_Driver.all) then Comp_Driver := Locate_Exec_On_Path (Comp_Driver.all); end if; if Comp_Driver /= null and then Comp_Driver'Length > 0 then Comp_Dir := new String' (Containing_Directory (Comp_Driver.all)); -- Consider only the compiler drivers that are in "bin" -- subdirectories. if Simple_Name (Comp_Dir.all) = "bin" then Prefix := new String'(Containing_Directory (Comp_Dir.all)); -- Check if the compiler root is already in the list. If it -- is not, add it to the list. Compiler_Root := First_Compiler_Root; while Compiler_Root /= null loop exit when Prefix.all = Compiler_Root.Root.all; Compiler_Root := Compiler_Root.Next; end loop; if Compiler_Root = null then First_Compiler_Root := new Compiler_Root_Data' (Root => Prefix, Runtimes => null, Next => First_Compiler_Root); Compiler_Root := First_Compiler_Root; end if; -- If there is a runtime for this compiler, check if it is -- recorded with the compiler root. If it is not, record -- the runtime. declare Runtime : constant String := Runtime_Name_For (Lang_Id.Name); Root : String_Access; begin if Runtime'Length > 0 then if Is_Absolute_Path (Runtime) then Root := new String'(Runtime); else Root := new String' (Prefix.all & Directory_Separator & Opt.Target_Value.all & Directory_Separator & Runtime); end if; Runtime_Root := Compiler_Root.Runtimes; while Runtime_Root /= null loop exit when Root.all = Runtime_Root.Root.all; Runtime_Root := Runtime_Root.Next; end loop; if Runtime_Root = null then Compiler_Root.Runtimes := new Runtime_Root_Data' (Root => Root, Next => Compiler_Root.Runtimes); end if; end if; end; end if; end if; end if; Lang_Id := Lang_Id.Next; end loop; end Look_For_Project_Paths; end GPR.Conf; gprbuild-25.0.0/gpr/src/gpr-conf.ads000066400000000000000000000331251470075373400172070ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2006-2021, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- The following package manipulates the configuration files with GPR.Tree; with GPR.Proc; with GPR.Util; package GPR.Conf is use GPR.Util; type Config_File_Hook is access procedure (Config_File : in out GPR.Project_Node_Id; Project_Node_Tree : GPR.Tree.Project_Node_Tree_Ref); -- Hook called after the config file has been parsed. This lets the -- application do last minute changes to it (GPS uses this to add the -- default naming schemes for instance). At that point, the config file -- has not been applied to the project yet. When no config file was found, -- and automatic generation is disabled, it is possible that Config_File -- is set to Empty_Node when this procedure is called. You can then decide -- to create a new config file if you need. No_Configuration_File : constant String := "/"; -- When specified as a parameter Config_File_Name in the procedures below, -- no existing configuration project file is parsed. This is used by -- gnatmake, gnatclean and the GNAT driver to avoid parsing an existing -- default configuration project file. procedure Add_Db_Switch_Arg (N : Name_Id); -- Add one argument to the --db switch procedure Parse_Project_And_Apply_Config (Main_Project : out Project_Id; User_Project_Node : out Project_Node_Id; Config_File_Name : String := ""; Autoconf_Specified : Boolean; Project_File_Name : String; Project_Tree : Project_Tree_Ref; Project_Node_Tree : Tree.Project_Node_Tree_Ref; Env : in out Tree.Environment; Packages_To_Check : String_List_Access; Allow_Automatic_Generation : Boolean := True; Automatically_Generated : out Boolean; Config_File_Path : out String_Access; Target_Name : String := ""; Normalized_Hostname : String; On_Load_Config : Config_File_Hook := null; Implicit_Project : Boolean := False; On_New_Tree_Loaded : Proc.Tree_Loaded_Callback := null; Gprconfig_Options : String_Vectors.Vector := String_Vectors.Empty_Vector); -- Find the main configuration project and parse the project tree rooted at -- this configuration project. -- -- Project_Node_Tree must have been initialized first (and possibly the -- value for external references and project path should also have been -- set). -- -- If the processing fails, Main_Project is set to No_Project. If the error -- happened while parsing the project itself (i.e. creating the tree), -- User_Project_Node is also set to Empty_Node. -- -- If Config_File_Name is No_Configuration_File, then no configuration -- project file is parsed. Normally, in this case On_Load_Config is not -- null, and it is used to create a configuration project file in memory. -- -- Autoconf_Specified indicates whether the user has specified --autoconf. -- If this is the case, the config file might be (re)generated, as -- appropriate, to match languages and target if the one specified doesn't -- already match. -- -- Normalized_Hostname is the host on which gprbuild is returned, -- normalized so that we can more easily compare it with what is stored in -- configuration files. It is used when the target is unspecified, although -- we need to know the target specified by the user (Target_Name) when -- computing the name of the default config file that should be used. -- -- If specified, On_Load_Config is called just after the config file has -- been created/loaded. You can then modify it before it is later applied -- to the project itself. -- -- Any error in generating or parsing the config file is reported via the -- Invalid_Config exception, with an appropriate message. Any error while -- parsing the project file results in No_Project. -- -- If Implicit_Project is True, the main project file being parsed is -- deemed to be in the current working directory, even if it is not the -- case. Implicit_Project is set to True when a tool such as gprbuild is -- invoked without a project file and is using an implicit project file -- that is virtually in the current working directory, but is physically -- in another directory. -- -- If specified, On_New_Tree_Loaded is called after each aggregated project -- has been processed successfully. procedure Process_Project_And_Apply_Config (Main_Project : out Project_Id; User_Project_Node : Project_Node_Id; Config_File_Name : String := ""; Autoconf_Specified : Boolean; Project_Tree : Project_Tree_Ref; Project_Node_Tree : Tree.Project_Node_Tree_Ref; Env : in out Tree.Environment; Packages_To_Check : String_List_Access; Allow_Automatic_Generation : Boolean := True; Automatically_Generated : out Boolean; Config_File_Path : out String_Access; Target_Name : String := ""; Normalized_Hostname : String; On_Load_Config : Config_File_Hook := null; Reset_Tree : Boolean := True; On_New_Tree_Loaded : Proc.Tree_Loaded_Callback := null; Do_Phase_1 : Boolean := True; Gprconfig_Options : String_Vectors.Vector := String_Vectors.Empty_Vector); -- Same as above, except the project must already have been parsed through -- GPR.Part.Parse, and only the processing of the project and the -- configuration is done at this level. -- -- If Reset_Tree is true, all projects are first removed from the tree. -- When_No_Sources indicates what should be done when no sources are found -- for one of the languages of the project. -- -- If Require_Sources_Other_Lang is true, then all languages must have at -- least one source file, or an error is reported via When_No_Sources. If -- it is false, this is only required for Ada (and only if it is a language -- of the project). -- -- If Do_Phase_1 is False, then GPR.Proc.Process_Project_Tree_Phase_1 -- should not be called, as it has already been invoked successfully. Invalid_Config : exception; procedure Get_Or_Create_Configuration_File (Project : Project_Id; Conf_Project : Project_Id; Project_Tree : Project_Tree_Ref; Project_Node_Tree : Tree.Project_Node_Tree_Ref; Env : in out Tree.Environment; Allow_Automatic_Generation : Boolean; Config_File_Name : String := ""; Autoconf_Specified : Boolean; Target_Name : String := ""; Normalized_Hostname : String; Packages_To_Check : String_List_Access := null; Config : out Project_Id; Config_File_Path : out String_Access; Automatically_Generated : out Boolean; On_Load_Config : Config_File_Hook := null; Gprconfig_Options : String_Vectors.Vector := String_Vectors.Empty_Vector); -- Compute the name of the configuration file that should be used. If no -- default configuration file is found, a new one will be automatically -- generated if Allow_Automatic_Generation is true. This configuration -- project file will be generated in the object directory of project -- Conf_Project. -- -- Any error in generating or parsing the config file is reported via the -- Invalid_Config exception, with an appropriate message. -- -- On exit, Config_File_Path is never null (if none could be found, Os.Fail -- was called and the program exited anyway). -- -- The choice and generation of a configuration file depends on several -- attributes of the user's project file (given by the Project argument), -- e.g. list of languages that must be supported. Project must therefore -- have been partially processed (phase one of the processing only). -- -- Config_File_Name should be set to the name of the config file specified -- by the user (either through gprbuild's --config or --autoconf switches). -- In the latter case, Autoconf_Specified should be set to true to indicate -- that the configuration file can be regenerated to match target and -- languages. This name can either be an absolute path, or the base name -- that will be searched in the default config file directories (which -- depends on the installation path for the tools). -- -- Target_Name is used to chose the configuration file that will be used -- from among several possibilities. -- -- If a project file could be found, it is automatically parsed and -- processed (and Packages_To_Check is used to indicate which packages -- should be processed). procedure Update_Project_Search_Path (Project : Project_Id; Project_Tree : Project_Tree_Ref; Env : in out Tree.Environment); -- Add compiler-specific predefined directories to the project search path. -- procedure Add_Default_GNAT_Naming_Scheme -- (Config_File : in out GPR.Tree.Project_Node_Id; -- Project_Tree : GPR.Tree.Project_Node_Tree_Ref); -- A hook that will create a new config file (in memory), used for -- Get_Or_Create_Configuration_File and Process_Project_And_Apply_Config -- and add the default GNAT naming scheme to it. Nothing is done if the -- config_file already exists, to avoid overriding what the user might -- have put in there. -------------- -- Runtimes -- -------------- procedure Set_Runtime_For (Language : Name_Id; RTS_Name : String); -- Specifies the runtime to use for a specific language. Most of the time -- this should be used for Ada, but other languages can also specify their -- own runtime. This is in general specified via the --RTS command line -- switch, and results in a specific component passed to gprconfig's -- --config switch then automatically generating a configuration file. function Runtime_Name_For (Language : Name_Id) return String; -- Returns the runtime name for a language. Returns the value set by the -- last call to Set_Runtime_For, if any, otherwise returns an empty string. function Runtime_Name_Set_For (Language : Name_Id) return Boolean; -- Returns True only if Set_Runtime_For has been called for the Language ---------------- -- Toolchains -- ---------------- procedure Set_Toolchain_For (Language : Name_Id; Toolchain_Name : String); -- Specifies the toolchain to use for a specific language. This results in -- a specific component passed to gprconfig's --config switch when -- automatically generating a configuration file. function Toolchain_Name_For (Language : Name_Id) return String; -- Returns the toolchain name for a language. Returns the value set by the -- last call to Set_Toolchain_For, if any, otherwise returns an empty -- string. function Toolchain_Name_Set_For (Language : Name_Id) return Boolean; -- Returns True only if Set_Toolchain_For has been called for the Language ------------------------ -- Auto-configuration -- ------------------------ function Problem_During_Auto_Configuration return Boolean; -- Return True if the last invocation of gprconfig for auto-configuration -- returns a failure status. Returns False otherwise, including if there is -- no auto-configuration. end GPR.Conf; gprbuild-25.0.0/gpr/src/gpr-cset.adb000066400000000000000000000234641470075373400172040ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2015, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ package body GPR.Cset is X_C0 : constant Character := Character'Val (16#C0#); X_C1 : constant Character := Character'Val (16#C1#); X_C2 : constant Character := Character'Val (16#C2#); X_C3 : constant Character := Character'Val (16#C3#); X_C4 : constant Character := Character'Val (16#C4#); X_C5 : constant Character := Character'Val (16#C5#); X_C6 : constant Character := Character'Val (16#C6#); X_C7 : constant Character := Character'Val (16#C7#); X_C8 : constant Character := Character'Val (16#C8#); X_C9 : constant Character := Character'Val (16#C9#); X_CA : constant Character := Character'Val (16#CA#); X_CB : constant Character := Character'Val (16#CB#); X_CC : constant Character := Character'Val (16#CC#); X_CD : constant Character := Character'Val (16#CD#); X_CE : constant Character := Character'Val (16#CE#); X_CF : constant Character := Character'Val (16#CF#); X_D0 : constant Character := Character'Val (16#D0#); X_D1 : constant Character := Character'Val (16#D1#); X_D2 : constant Character := Character'Val (16#D2#); X_D3 : constant Character := Character'Val (16#D3#); X_D4 : constant Character := Character'Val (16#D4#); X_D5 : constant Character := Character'Val (16#D5#); X_D6 : constant Character := Character'Val (16#D6#); -- X_D7 : constant Character := Character'Val (16#D7#); X_D8 : constant Character := Character'Val (16#D8#); X_D9 : constant Character := Character'Val (16#D9#); X_DA : constant Character := Character'Val (16#DA#); X_DB : constant Character := Character'Val (16#DB#); X_DC : constant Character := Character'Val (16#DC#); X_DD : constant Character := Character'Val (16#DD#); X_DE : constant Character := Character'Val (16#DE#); X_DF : constant Character := Character'Val (16#DF#); X_E0 : constant Character := Character'Val (16#E0#); X_E1 : constant Character := Character'Val (16#E1#); X_E2 : constant Character := Character'Val (16#E2#); X_E3 : constant Character := Character'Val (16#E3#); X_E4 : constant Character := Character'Val (16#E4#); X_E5 : constant Character := Character'Val (16#E5#); X_E6 : constant Character := Character'Val (16#E6#); X_E7 : constant Character := Character'Val (16#E7#); X_E8 : constant Character := Character'Val (16#E8#); X_E9 : constant Character := Character'Val (16#E9#); X_EA : constant Character := Character'Val (16#EA#); X_EB : constant Character := Character'Val (16#EB#); X_EC : constant Character := Character'Val (16#EC#); X_ED : constant Character := Character'Val (16#ED#); X_EE : constant Character := Character'Val (16#EE#); X_EF : constant Character := Character'Val (16#EF#); X_F0 : constant Character := Character'Val (16#F0#); X_F1 : constant Character := Character'Val (16#F1#); X_F2 : constant Character := Character'Val (16#F2#); X_F3 : constant Character := Character'Val (16#F3#); X_F4 : constant Character := Character'Val (16#F4#); X_F5 : constant Character := Character'Val (16#F5#); X_F6 : constant Character := Character'Val (16#F6#); -- X_F7 : constant Character := Character'Val (16#F7#); X_F8 : constant Character := Character'Val (16#F8#); X_F9 : constant Character := Character'Val (16#F9#); X_FA : constant Character := Character'Val (16#FA#); X_FB : constant Character := Character'Val (16#FB#); X_FC : constant Character := Character'Val (16#FC#); X_FD : constant Character := Character'Val (16#FD#); X_FE : constant Character := Character'Val (16#FE#); X_FF : constant Character := Character'Val (16#FF#); ------------------------------------------ -- Definitions for Latin-1 (ISO 8859-1) -- ------------------------------------------ type Translate_Table is array (Character) of Character; Fold_Upper_Table : constant Translate_Table := Translate_Table'( 'a' => 'A', X_E0 => X_C0, X_F0 => X_D0, 'b' => 'B', X_E1 => X_C1, X_F1 => X_D1, 'c' => 'C', X_E2 => X_C2, X_F2 => X_D2, 'd' => 'D', X_E3 => X_C3, X_F3 => X_D3, 'e' => 'E', X_E4 => X_C4, X_F4 => X_D4, 'f' => 'F', X_E5 => X_C5, X_F5 => X_D5, 'g' => 'G', X_E6 => X_C6, X_F6 => X_D6, 'h' => 'H', X_E7 => X_C7, 'i' => 'I', X_E8 => X_C8, X_F8 => X_D8, 'j' => 'J', X_E9 => X_C9, X_F9 => X_D9, 'k' => 'K', X_EA => X_CA, X_FA => X_DA, 'l' => 'L', X_EB => X_CB, X_FB => X_DB, 'm' => 'M', X_EC => X_CC, X_FC => X_DC, 'n' => 'N', X_ED => X_CD, X_FD => X_DD, 'o' => 'O', X_EE => X_CE, X_FE => X_DE, 'p' => 'P', X_EF => X_CF, 'q' => 'Q', 'r' => 'R', 's' => 'S', 't' => 'T', 'u' => 'U', 'v' => 'V', 'w' => 'W', 'x' => 'X', 'y' => 'Y', 'z' => 'Z', 'A' => 'A', X_C0 => X_C0, X_D0 => X_D0, 'B' => 'B', X_C1 => X_C1, X_D1 => X_D1, 'C' => 'C', X_C2 => X_C2, X_D2 => X_D2, 'D' => 'D', X_C3 => X_C3, X_D3 => X_D3, 'E' => 'E', X_C4 => X_C4, X_D4 => X_D4, 'F' => 'F', X_C5 => X_C5, X_D5 => X_D5, 'G' => 'G', X_C6 => X_C6, X_D6 => X_D6, 'H' => 'H', X_C7 => X_C7, 'I' => 'I', X_C8 => X_C8, X_D8 => X_D8, 'J' => 'J', X_C9 => X_C9, X_D9 => X_D9, 'K' => 'K', X_CA => X_CA, X_DA => X_DA, 'L' => 'L', X_CB => X_CB, X_DB => X_DB, 'M' => 'M', X_CC => X_CC, X_DC => X_DC, 'N' => 'N', X_CD => X_CD, X_DD => X_DD, 'O' => 'O', X_CE => X_CE, X_DE => X_DE, 'P' => 'P', X_CF => X_CF, X_DF => X_DF, X_FF => X_FF, 'Q' => 'Q', 'R' => 'R', 'S' => 'S', 'T' => 'T', 'U' => 'U', 'V' => 'V', 'W' => 'W', 'X' => 'X', 'Y' => 'Y', 'Z' => 'Z', '0' => '0', '1' => '1', '2' => '2', '3' => '3', '4' => '4', '5' => '5', '6' => '6', '7' => '7', '8' => '8', '9' => '9', '_' => '_', others => ' '); Fold_Lower_Table : Translate_Table; Identifier_Char_Table : array (Character) of Boolean; procedure Initialize_Tables; -------------------------- -- Is_Lower_Case_Letter -- -------------------------- function Is_Lower_Case_Letter (C : Character) return Boolean is begin return C /= Fold_Upper (C); end Is_Lower_Case_Letter; -------------------------- -- Is_Upper_Case_Letter -- -------------------------- function Is_Upper_Case_Letter (C : Character) return Boolean is begin return C /= Fold_Lower (C); end Is_Upper_Case_Letter; ---------------- -- Fold_Lower -- ---------------- function Fold_Lower (C : Character) return Character is begin return Fold_Lower_Table (C); end Fold_Lower; ---------------- -- Fold_Upper -- ---------------- function Fold_Upper (C : Character) return Character is begin return Fold_Upper_Table (C); end Fold_Upper; ----------------------- -- Initialize_Tables -- ----------------------- procedure Initialize_Tables is begin -- Use Fold_Upper table to compute Fold_Lower table Fold_Lower_Table := Fold_Upper_Table; for J in Character loop if J /= Fold_Upper_Table (J) then Fold_Lower_Table (Fold_Upper_Table (J)) := J; Fold_Lower_Table (J) := J; end if; end loop; Fold_Lower_Table (' ') := ' '; -- Build Identifier_Char table from used entries of Fold_Upper for J in Character loop Identifier_Char_Table (J) := (Fold_Upper_Table (J) /= ' '); end loop; -- Always add [ as an identifier character to deal with the brackets -- notation for wide characters used in identifiers. Note that if -- we are not allowing wide characters in identifiers, then any use -- of this notation will be flagged as an error in Scan_Identifier. Identifier_Char_Table ('[') := True; end Initialize_Tables; --------------------- -- Identifier_Char -- --------------------- function Identifier_Char (C : Character) return Boolean is begin return Identifier_Char_Table (C); end Identifier_Char; begin Initialize_Tables; end GPR.Cset; gprbuild-25.0.0/gpr/src/gpr-cset.ads000066400000000000000000000046141470075373400172210ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2015, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ package GPR.Cset is function Is_Upper_Case_Letter (C : Character) return Boolean; pragma Inline (Is_Upper_Case_Letter); -- Determine if character is upper case letter function Is_Lower_Case_Letter (C : Character) return Boolean; pragma Inline (Is_Lower_Case_Letter); -- Determine if character is lower case letter function Identifier_Char (C : Character) return Boolean; pragma Inline (Identifier_Char); function Fold_Lower (C : Character) return Character; pragma Inline (Fold_Lower); function Fold_Upper (C : Character) return Character; pragma Inline (Fold_Upper); end GPR.Cset; gprbuild-25.0.0/gpr/src/gpr-debug.adb000066400000000000000000000062231470075373400173260ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; package body GPR.Debug is --------------------------------------------- -- Documentation for gprbuild Debug Flags -- --------------------------------------------- -- dm Display the maximum number of simultaneous compilations. -- dn Do not delete temporary files created by gprbuild at the end -- of execution, such as temporary config pragma files, mapping -- files or project path files. This debug switch is equivalent to -- the standard switch --keep-temp-files. We retain the debug switch -- for back compatibility with past usage. -- dt When a time stamp mismatch has been found for an ALI file, -- display the source file name, the time stamp expected and -- the time stamp found. -- da Print information about names being registered and accessed in -- the package GPR.Names. -- ds In verbose mode, print details about the checks on .cswi files. -- du Disable checks on unit names, thus allowing non-ascii characters. -------------------- -- Set_Debug_Flag -- -------------------- procedure Set_Debug_Flag (C : Character; Val : Boolean := True) is begin if C in Debug_Flags'Range then Debug_Flags (C) := Val; else Ada.Text_IO.Put_Line ("illegal debug switch '" & C & '''); end if; end Set_Debug_Flag; end GPR.Debug; gprbuild-25.0.0/gpr/src/gpr-debug.ads000066400000000000000000000103251470075373400173450ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2015-2020, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package contains global flags used to control the inclusion -- of debugging code in various phases of the compiler. Some of these -- flags are also used by the binder and gnatmake. package GPR.Debug is ------------------------- -- Dynamic Debug Flags -- ------------------------- -- 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_Flags : array (Character range 'a' .. 'z') of Boolean := (others => False); Debug_Flag_A : Boolean renames Debug_Flags ('a'); Debug_Flag_B : Boolean renames Debug_Flags ('b'); Debug_Flag_C : Boolean renames Debug_Flags ('c'); Debug_Flag_D : Boolean renames Debug_Flags ('d'); Debug_Flag_E : Boolean renames Debug_Flags ('e'); Debug_Flag_F : Boolean renames Debug_Flags ('f'); Debug_Flag_G : Boolean renames Debug_Flags ('g'); Debug_Flag_H : Boolean renames Debug_Flags ('h'); Debug_Flag_I : Boolean renames Debug_Flags ('i'); Debug_Flag_J : Boolean renames Debug_Flags ('j'); Debug_Flag_K : Boolean renames Debug_Flags ('k'); Debug_Flag_L : Boolean renames Debug_Flags ('l'); Debug_Flag_M : Boolean renames Debug_Flags ('m'); Debug_Flag_N : Boolean renames Debug_Flags ('n'); Debug_Flag_O : Boolean renames Debug_Flags ('o'); Debug_Flag_P : Boolean renames Debug_Flags ('p'); Debug_Flag_Q : Boolean renames Debug_Flags ('q'); Debug_Flag_R : Boolean renames Debug_Flags ('r'); Debug_Flag_S : Boolean renames Debug_Flags ('s'); Debug_Flag_T : Boolean renames Debug_Flags ('t'); Debug_Flag_U : Boolean renames Debug_Flags ('u'); Debug_Flag_V : Boolean renames Debug_Flags ('v'); Debug_Flag_W : Boolean renames Debug_Flags ('w'); Debug_Flag_X : Boolean renames Debug_Flags ('x'); Debug_Flag_Y : Boolean renames Debug_Flags ('y'); Debug_Flag_Z : Boolean renames Debug_Flags ('z'); procedure Set_Debug_Flag (C : Character; Val : Boolean := True); -- Where C is a-z, sets the corresponding debug flag to -- the given value. end GPR.Debug; gprbuild-25.0.0/gpr/src/gpr-dect.adb000066400000000000000000002127531470075373400171660ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2022, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with GNAT; use GNAT; with GNAT.Case_Util; use GNAT.Case_Util; with GNAT.Strings; with GPR.Opt; use GPR.Opt; with GPR.Attr; use GPR.Attr; with GPR.Attr.PM; use GPR.Attr.PM; with GPR.Err; use GPR.Err; with GPR.Erroutc; use GPR.Erroutc; with GPR.Names; use GPR.Names; with GPR.Output; use GPR.Output; with GPR.Osint; use GPR.Osint; with GPR.Sinput; use GPR.Sinput; with GPR.Strt; use GPR.Strt; with GPR.Tree; use GPR.Tree; with GPR.Scans; use GPR.Scans; with GPR.Snames; with GPR.Util; use GPR.Util; package body GPR.Dect is type Zone is (In_Project, In_Package, In_Case_Construction); -- Used to indicate if we are parsing a package (In_Package), a case -- construction (In_Case_Construction) or none of those two (In_Project). procedure Rename_Obsolescent_Attributes (In_Tree : Project_Node_Tree_Ref; Attribute : Project_Node_Id; Current_Package : Project_Node_Id); -- Rename obsolescent attributes in the tree. When the attribute has been -- renamed since its initial introduction in the design of projects, we -- replace the old name in the tree with the new name, so that the code -- does not have to check both names forever. procedure Check_Attribute_Allowed (In_Tree : Project_Node_Tree_Ref; Project : Project_Node_Id; Attribute : Project_Node_Id; Flags : Processing_Flags); -- Check whether the attribute is valid in this project. In particular, -- depending on the type of project (qualifier), some attributes might -- be disabled. procedure Check_Package_Allowed (In_Tree : Project_Node_Tree_Ref; Project : Project_Node_Id; Current_Package : Project_Node_Id; Flags : Processing_Flags); -- Check whether the package is valid in this project procedure Find_Variable (Variable : in out Project_Node_Id; Name : Name_Id; In_Tree : Project_Node_Tree_Ref); -- Look for a Variable with the Name. If not found, Variable is -- Project_Node_Tree_Ref. procedure Parse_Attribute_Declaration (In_Tree : Project_Node_Tree_Ref; Attribute : out Project_Node_Id; First_Attribute : Attribute_Node_Id; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; Packages_To_Check : String_List_Access; Flags : Processing_Flags); -- Parse an attribute declaration procedure Parse_Case_Construction (In_Tree : Project_Node_Tree_Ref; Case_Construction : out Project_Node_Id; First_Attribute : Attribute_Node_Id; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; Packages_To_Check : String_List_Access; Is_Config_File : Boolean; Flags : Processing_Flags); -- Parse a case construction procedure Parse_Declarative_Items (In_Tree : Project_Node_Tree_Ref; Declarations : out Project_Node_Id; In_Zone : Zone; First_Attribute : Attribute_Node_Id; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; Packages_To_Check : String_List_Access; Is_Config_File : Boolean; Flags : Processing_Flags); -- Parse declarative items. Depending on In_Zone, some declarative items -- may be forbidden. Is_Config_File should be set to True if the project -- represents a config file (.cgpr) since some specific checks apply. procedure Parse_Package_Declaration (In_Tree : Project_Node_Tree_Ref; Package_Declaration : out Project_Node_Id; Current_Project : Project_Node_Id; Packages_To_Check : String_List_Access; Is_Config_File : Boolean; Flags : Processing_Flags); -- Parse a package declaration. -- Is_Config_File should be set to True if the project represents a config -- file (.cgpr) since some specific checks apply. procedure Parse_String_Type_Declaration (In_Tree : Project_Node_Tree_Ref; String_Type : out Project_Node_Id; Current_Project : Project_Node_Id; Flags : Processing_Flags); -- type is ( { , } ) ; procedure Parse_Variable_Declaration (In_Tree : Project_Node_Tree_Ref; Variable : out Project_Node_Id; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; Flags : Processing_Flags); -- Parse a variable assignment -- := ; OR -- : := ; ----------- -- Parse -- ----------- procedure Parse (In_Tree : Project_Node_Tree_Ref; Declarations : out Project_Node_Id; Current_Project : Project_Node_Id; Extends : Project_Node_Id; Packages_To_Check : String_List_Access; Is_Config_File : Boolean; Flags : Processing_Flags) is First_Declarative_Item : Project_Node_Id := Empty_Project_Node; begin Declarations := Default_Project_Node (Of_Kind => N_Project_Declaration, In_Tree => In_Tree); Set_Location_Of (Declarations, In_Tree, To => Token_Ptr); Set_Extended_Project_Of (Declarations, In_Tree, To => Extends); Set_Project_Declaration_Of (Current_Project, In_Tree, Declarations); Parse_Declarative_Items (Declarations => First_Declarative_Item, In_Tree => In_Tree, In_Zone => In_Project, First_Attribute => GPR.Attr.Attribute_First, Current_Project => Current_Project, Current_Package => Empty_Project_Node, Packages_To_Check => Packages_To_Check, Is_Config_File => Is_Config_File, Flags => Flags); Set_First_Declarative_Item_Of (Declarations, In_Tree, To => First_Declarative_Item); end Parse; ----------------------------------- -- Rename_Obsolescent_Attributes -- ----------------------------------- procedure Rename_Obsolescent_Attributes (In_Tree : Project_Node_Tree_Ref; Attribute : Project_Node_Id; Current_Package : Project_Node_Id) is Attr_Name : Name_Id; begin if Present (Current_Package) and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored then Attr_Name := Name_Of (Attribute, In_Tree); if Attr_Name = Snames.Name_Specification then Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec); elsif Attr_Name = Snames.Name_Specification_Suffix then Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec_Suffix); elsif Attr_Name = Snames.Name_Implementation then Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body); elsif Attr_Name = Snames.Name_Implementation_Suffix then Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body_Suffix); end if; end if; end Rename_Obsolescent_Attributes; --------------------------- -- Check_Package_Allowed -- --------------------------- procedure Check_Package_Allowed (In_Tree : Project_Node_Tree_Ref; Project : Project_Node_Id; Current_Package : Project_Node_Id; Flags : Processing_Flags) is Qualif : constant Project_Qualifier := Project_Qualifier_Of (Project, In_Tree); Name : constant Name_Id := Name_Of (Current_Package, In_Tree); use GPR.Snames; begin -- Packages Naming, Compiler and Linker are not allowed in aggregate -- projects and aggregate library projects. Packages Binder and Install -- is not allowed in aggregate projects, but is allowed in aggregate -- library projects. if ((Qualif = Aggregate or else Qualif = Aggregate_Library) and then (Name = Name_Naming or else Name = Name_Compiler or else Name = Name_Linker)) or else (Qualif = Aggregate and then (Name = Name_Install or else Name = Name_Binder)) then Error_Msg_Name_1 := Name; Error_Msg (Flags, "package %% cannot be used in aggregate" & (if Qualif = Aggregate then "" else " library") & " projects", Location_Of (Current_Package, In_Tree)); end if; end Check_Package_Allowed; ----------------------------- -- Check_Attribute_Allowed -- ----------------------------- procedure Check_Attribute_Allowed (In_Tree : Project_Node_Tree_Ref; Project : Project_Node_Id; Attribute : Project_Node_Id; Flags : Processing_Flags) is Qualif : constant Project_Qualifier := Project_Qualifier_Of (Project, In_Tree); Name : constant Name_Id := Name_Of (Attribute, In_Tree); begin case Qualif is when Aggregate | Aggregate_Library => if Name = Snames.Name_Languages or else Name = Snames.Name_Source_Files or else Name = Snames.Name_Source_List_File or else Name = Snames.Name_Locally_Removed_Files or else Name = Snames.Name_Excluded_Source_Files or else Name = Snames.Name_Excluded_Source_List_File or else Name = Snames.Name_Exec_Dir or else Name = Snames.Name_Source_Dirs or else Name = Snames.Name_Inherit_Source_Path or else (Qualif = Aggregate and then Name = Snames.Name_Interfaces) or else (Qualif = Aggregate and then Name = Snames.Name_Library_Dir) or else (Qualif = Aggregate and then Name = Snames.Name_Library_Name) or else Name = Snames.Name_Main or else Name = Snames.Name_Roots or else Name = Snames.Name_Externally_Built or else Name = Snames.Name_Executable or else Name = Snames.Name_Executable_Suffix or else (Qualif = Aggregate and then Name = Snames.Name_Default_Switches) then Error_Msg_Name_1 := Name; Error_Msg (Flags, "%% is not valid in aggregate projects", Location_Of (Attribute, In_Tree), Always => True); end if; when others => if Name = Snames.Name_Project_Files or else Name = Snames.Name_Project_Path or else Name = Snames.Name_External then Error_Msg_Name_1 := Name; Error_Msg (Flags, "%% is only valid in aggregate projects", Location_Of (Attribute, In_Tree), Always => True); end if; end case; end Check_Attribute_Allowed; ------------------- -- Find_Variable -- ------------------- procedure Find_Variable (Variable : in out Project_Node_Id; Name : Name_Id; In_Tree : Project_Node_Tree_Ref) is begin while Present (Variable) and then Name_Of (Variable, In_Tree) /= Name loop Variable := Next_Variable (Variable, In_Tree); end loop; end Find_Variable; --------------------------------- -- Parse_Attribute_Declaration -- --------------------------------- procedure Parse_Attribute_Declaration (In_Tree : Project_Node_Tree_Ref; Attribute : out Project_Node_Id; First_Attribute : Attribute_Node_Id; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; Packages_To_Check : String_List_Access; Flags : Processing_Flags) is Current_Attribute : Attribute_Node_Id := First_Attribute; Full_Associative_Array : Boolean := False; Attribute_Name : Name_Id := No_Name; Optional_Index : Boolean := False; Pkg_Id : Package_Node_Id := Empty_Package; procedure Process_Attribute_Name; -- Read the name of the attribute, and check its type procedure Process_Associative_Array_Index; -- Read the index of the associative array and check its validity ---------------------------- -- Process_Attribute_Name -- ---------------------------- procedure Process_Attribute_Name is Ignore : Boolean; begin Attribute_Name := Token_Name; Set_Name_Of (Attribute, In_Tree, To => Attribute_Name); Set_Location_Of (Attribute, In_Tree, To => Token_Ptr); -- Find the attribute Current_Attribute := Attribute_Node_Id_Of (Attribute_Name, First_Attribute); -- If the attribute cannot be found, create the attribute if inside -- an unknown package. if Current_Attribute = Empty_Attribute then if Present (Current_Package) and then Expression_Kind_Of (Current_Package, In_Tree) = Ignored then Pkg_Id := Package_Id_Of (Current_Package, In_Tree); Add_Attribute (Pkg_Id, Token_Name, Current_Attribute); else -- If not a valid attribute name, issue an error if inside -- a package that need to be checked. Ignore := Present (Current_Package) and then Packages_To_Check /= All_Packages; if Ignore then -- Check that we are not in a package to check Get_Name_String (Name_Of (Current_Package, In_Tree)); for Index in Packages_To_Check'Range loop if Name_Buffer (1 .. Name_Len) = Packages_To_Check (Index).all then Ignore := False; exit; end if; end loop; end if; if not Ignore then Error_Msg_Name_1 := Token_Name; Error_Msg (Flags, "undefined attribute %%", Token_Ptr); end if; end if; -- Set, if appropriate the index case insensitivity flag else if Is_Read_Only (Current_Attribute) then Error_Msg_Name_1 := Token_Name; Error_Msg (Flags, "read-only attribute %% cannot be given a value", Token_Ptr); end if; if Attribute_Kind_Of (Current_Attribute) in All_Case_Insensitive_Associative_Array then Set_Case_Insensitive (Attribute, In_Tree, To => True); end if; end if; Scan (In_Tree); -- past the attribute name -- Set the expression kind of the attribute if Current_Attribute /= Empty_Attribute then Set_Expression_Kind_Of (Attribute, In_Tree, To => Variable_Kind_Of (Current_Attribute)); Set_Is_Config_Concatenable (Attribute, In_Tree, To => Is_Config_Concatenable (Current_Attribute)); Optional_Index := Optional_Index_Of (Current_Attribute); end if; end Process_Attribute_Name; ------------------------------------- -- Process_Associative_Array_Index -- ------------------------------------- procedure Process_Associative_Array_Index is begin -- If the attribute is not an associative array attribute, report -- an error. If this information is still unknown, set the kind -- to Associative_Array. if Current_Attribute /= Empty_Attribute and then Attribute_Kind_Of (Current_Attribute) = Single then Error_Msg (Flags, "the attribute """ & Get_Name_String_Safe (Attribute_Name_Of (Current_Attribute)) & """ cannot be an associative array", Location_Of (Attribute, In_Tree)); elsif Attribute_Kind_Of (Current_Attribute) = Unknown then Set_Attribute_Kind_Of (Current_Attribute, To => Associative_Array); end if; Scan (In_Tree); -- past the left parenthesis if Others_Allowed_For (Current_Attribute) and then Token = Tok_Others then Set_Associative_Array_Index_Of (Attribute, In_Tree, All_Other_Names); Scan (In_Tree); -- past others else Expect (Tok_String_Literal, "literal string" & (if Others_Allowed_For (Current_Attribute) then " or others" else "")); if Token = Tok_String_Literal then Get_Name_String (Token_Name); if Case_Insensitive (Attribute, In_Tree) then To_Lower (Name_Buffer (1 .. Name_Len)); end if; Set_Associative_Array_Index_Of (Attribute, In_Tree, Name_Find); Scan (In_Tree); -- past the literal string index if Token = Tok_At then case Attribute_Kind_Of (Current_Attribute) is when Optional_Index_Associative_Array | Optional_Index_Case_Insensitive_Associative_Array => Scan (In_Tree); Expect (Tok_Integer_Literal, "integer literal"); if Token = Tok_Integer_Literal then -- Set the source index value from given literal declare Index : constant Int := Int_Literal_Value; begin if Index = 0 then Error_Msg (Flags, "index cannot be zero", Token_Ptr); else Set_Source_Index_Of (Attribute, In_Tree, To => Index); end if; end; Scan (In_Tree); end if; when others => Error_Msg (Flags, "index not allowed here", Token_Ptr); Scan (In_Tree); if Token = Tok_Integer_Literal then Scan (In_Tree); end if; end case; end if; end if; end if; Expect (Tok_Right_Paren, "`)`"); if Token = Tok_Right_Paren then Scan (In_Tree); -- past the right parenthesis end if; end Process_Associative_Array_Index; begin Attribute := Default_Project_Node (Of_Kind => N_Attribute_Declaration, In_Tree => In_Tree); Set_Location_Of (Attribute, In_Tree, To => Token_Ptr); Set_Previous_Line_Node (Attribute); -- Scan past "for" Scan (In_Tree); -- Body or External may be an attribute name if Token = Tok_Body then Token := Tok_Identifier; Token_Name := Snames.Name_Body; end if; if Token = Tok_External then Token := Tok_Identifier; Token_Name := Snames.Name_External; end if; Expect (Tok_Identifier, "identifier"); Process_Attribute_Name; Rename_Obsolescent_Attributes (In_Tree, Attribute, Current_Package); Check_Attribute_Allowed (In_Tree, Current_Project, Attribute, Flags); -- Associative array attributes if Token = Tok_Left_Paren then Process_Associative_Array_Index; else -- If it is an associative array attribute and there are no left -- parenthesis, then this is a full associative array declaration. -- Flag it as such for later processing of its value. if Current_Attribute /= Empty_Attribute and then Attribute_Kind_Of (Current_Attribute) /= Single then if Attribute_Kind_Of (Current_Attribute) = Unknown then Set_Attribute_Kind_Of (Current_Attribute, To => Single); else Full_Associative_Array := True; end if; end if; end if; Expect (Tok_Use, "USE"); if Token = Tok_Use then Scan (In_Tree); if Full_Associative_Array then -- Expect ', or -- .' declare The_Project : Project_Node_Id := Empty_Project_Node; -- The node of the project where the associative array is -- declared. The_Package : Project_Node_Id := Empty_Project_Node; -- The node of the package where the associative array is -- declared, if any. Project_Name : Name_Id := No_Name; -- The name of the project where the associative array is -- declared. Location : Source_Ptr := No_Location; -- The location of the project name begin Expect (Tok_Identifier, "identifier in full associative array expression"); if Token = Tok_Identifier then Location := Token_Ptr; -- Find the project node in the imported project or -- in the project being extended. The_Project := Imported_Or_Extended_Project_Of (Current_Project, In_Tree, Token_Name); if No (The_Project) and then not In_Tree.Incomplete_With then declare Var : Project_Node_Id; begin if Present (Current_Package) then Var := First_Variable_Of (Current_Package, In_Tree); elsif Present (Current_Project) then Var := First_Variable_Of (Current_Project, In_Tree); end if; Find_Variable (Var, Token_Name, In_Tree); Error_Msg (Flags, (if Present (Var) then "found variable name, expected project name" else "unknown project") & " in full associative array expression", Location); end; Scan (In_Tree); -- past the project name else Project_Name := Token_Name; Scan (In_Tree); -- past the project name -- If this is inside a package, a dot followed by the -- name of the package must followed the project name. if Present (Current_Package) then Expect (Tok_Dot, "`.`"); if Token /= Tok_Dot then The_Project := Empty_Project_Node; else Scan (In_Tree); -- past the dot Expect (Tok_Identifier, "identifier in full associative array" & " expression"); if Token /= Tok_Identifier then The_Project := Empty_Project_Node; -- If it is not the same package name, issue error elsif Token_Name /= Name_Of (Current_Package, In_Tree) then The_Project := Empty_Project_Node; Error_Msg (Flags, "not the same package as " & Get_Name_String_Safe (Name_Of (Current_Package, In_Tree)), Token_Ptr); Scan (In_Tree); -- past the package name else if Present (The_Project) then The_Package := First_Package_Of (The_Project, In_Tree); -- Look for the package node while Present (The_Package) and then Name_Of (The_Package, In_Tree) /= Token_Name loop The_Package := Next_Package_In_Project (The_Package, In_Tree); end loop; -- If the package cannot be found in the -- project, issue an error. if No (The_Package) then The_Project := Empty_Project_Node; Error_Msg_Name_2 := Project_Name; Error_Msg_Name_1 := Token_Name; Error_Msg (Flags, "package % not declared in project %", Token_Ptr); end if; end if; Scan (In_Tree); -- past the package name end if; end if; end if; end if; end if; if Present (The_Project) or else In_Tree.Incomplete_With then -- Looking for ' Expect (Tok_Apostrophe, "`''`"); if Token /= Tok_Apostrophe then The_Project := Empty_Project_Node; else Scan (In_Tree); -- past the apostrophe Expect (Tok_Identifier, "identifier"); if Token /= Tok_Identifier then The_Project := Empty_Project_Node; else -- If it is not the same attribute name, issue error if Token_Name /= Attribute_Name then The_Project := Empty_Project_Node; Error_Msg_Name_1 := Attribute_Name; Error_Msg (Flags, "invalid name, should be %", Token_Ptr); end if; Scan (In_Tree); -- past the attribute name end if; end if; end if; if No (The_Project) then -- If there were any problem, set the attribute id to null, -- so that the node will not be recorded. Current_Attribute := Empty_Attribute; else -- Set the appropriate field in the node. -- Note that the index and the expression are nil. This -- characterizes full associative array attribute -- declarations. Set_Associative_Project_Of (Attribute, In_Tree, The_Project); Set_Associative_Package_Of (Attribute, In_Tree, The_Package); end if; end; -- Other attribute declarations (not full associative array) else declare Expression_Location : constant Source_Ptr := Token_Ptr; -- The location of the first token of the expression Expression : Project_Node_Id := Empty_Project_Node; -- The expression, value for the attribute declaration begin -- Get the expression value and set it in the attribute node Parse_Expression (In_Tree => In_Tree, Expression => Expression, Flags => Flags, Current_Project => Current_Project, Current_Package => Current_Package, Optional_Index => Optional_Index); Set_Expression_Of (Attribute, In_Tree, To => Expression); -- If the expression is legal, but not of the right kind -- for the attribute, issue an error. if Current_Attribute /= Empty_Attribute and then Present (Expression) and then Variable_Kind_Of (Current_Attribute) /= Expression_Kind_Of (Expression, In_Tree) then if Variable_Kind_Of (Current_Attribute) = Undefined then Set_Variable_Kind_Of (Current_Attribute, To => Expression_Kind_Of (Expression, In_Tree)); else Error_Msg (Flags, "wrong expression kind for attribute """ & Get_Name_String_Safe (Attribute_Name_Of (Current_Attribute)) & '"', Expression_Location); end if; end if; end; end if; end if; -- If the attribute was not recognized, return an empty node. -- It may be that it is not in a package to check, and the node will -- not be added to the tree. if Current_Attribute = Empty_Attribute then Attribute := Empty_Project_Node; end if; Set_End_Of_Line (Attribute); Set_Previous_Line_Node (Attribute); end Parse_Attribute_Declaration; ----------------------------- -- Parse_Case_Construction -- ----------------------------- procedure Parse_Case_Construction (In_Tree : Project_Node_Tree_Ref; Case_Construction : out Project_Node_Id; First_Attribute : Attribute_Node_Id; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; Packages_To_Check : String_List_Access; Is_Config_File : Boolean; Flags : Processing_Flags) is Current_Item : Project_Node_Id := Empty_Project_Node; Next_Item : Project_Node_Id := Empty_Project_Node; First_Case_Item : Boolean := True; Variable_Location : Source_Ptr := No_Location; String_Type : Project_Node_Id := Empty_Project_Node; Case_Variable : Project_Node_Id := Empty_Project_Node; First_Declarative_Item : Project_Node_Id := Empty_Project_Node; First_Choice : Project_Node_Id := Empty_Project_Node; When_Others : Boolean := False; -- Set to True when there is a "when others =>" clause begin Case_Construction := Default_Project_Node (Of_Kind => N_Case_Construction, In_Tree => In_Tree); Set_Location_Of (Case_Construction, In_Tree, To => Token_Ptr); -- Scan past "case" Scan (In_Tree); -- Get the switch variable Expect (Tok_Identifier, "identifier"); if Token = Tok_Identifier then Variable_Location := Token_Ptr; Parse_Variable_Reference (In_Tree => In_Tree, Variable => Case_Variable, Flags => Flags, Current_Project => Current_Project, Current_Package => Current_Package, Allow_Attribute => False); if Kind_Of (Case_Variable, In_Tree) = N_Attribute_Reference then Case_Variable := Empty_Project_Node; end if; Set_Case_Variable_Reference_Of (Case_Construction, In_Tree, To => Case_Variable); else return; end if; if Present (Case_Variable) then String_Type := String_Type_Of (Case_Variable, In_Tree); if Expression_Kind_Of (Case_Variable, In_Tree) /= Single then Error_Msg (Flags, "variable """ & Get_Name_String_Safe (Name_Of (Case_Variable, In_Tree)) & """ is not a single string", Variable_Location); end if; end if; Expect (Tok_Is, "IS"); if Token = Tok_Is then Set_End_Of_Line (Case_Construction); Set_Previous_Line_Node (Case_Construction); Set_Next_End_Node (Case_Construction); -- Scan past "is" Scan (In_Tree); else return; end if; Start_New_Case_Construction (In_Tree, String_Type); When_Loop : while Token = Tok_When loop if First_Case_Item then Current_Item := Default_Project_Node (Of_Kind => N_Case_Item, In_Tree => In_Tree); Set_First_Case_Item_Of (Case_Construction, In_Tree, To => Current_Item); First_Case_Item := False; else Next_Item := Default_Project_Node (Of_Kind => N_Case_Item, In_Tree => In_Tree); Set_Next_Case_Item (Current_Item, In_Tree, To => Next_Item); Current_Item := Next_Item; end if; Set_Location_Of (Current_Item, In_Tree, To => Token_Ptr); -- Scan past "when" Scan (In_Tree); if Token = Tok_Others then When_Others := True; -- Scan past "others" Scan (In_Tree); Expect (Tok_Arrow, "`=>`"); Set_End_Of_Line (Current_Item); Set_Previous_Line_Node (Current_Item); -- Empty_Project_Node in Field1 of a Case_Item indicates -- the "when others =>" branch. Set_First_Choice_Of (Current_Item, In_Tree, To => Empty_Project_Node); Parse_Declarative_Items (In_Tree => In_Tree, Declarations => First_Declarative_Item, In_Zone => In_Case_Construction, First_Attribute => First_Attribute, Current_Project => Current_Project, Current_Package => Current_Package, Packages_To_Check => Packages_To_Check, Is_Config_File => Is_Config_File, Flags => Flags); -- "when others =>" must be the last branch, so save the -- Case_Item and exit Set_First_Declarative_Item_Of (Current_Item, In_Tree, To => First_Declarative_Item); exit When_Loop; else Parse_Choice_List (In_Tree => In_Tree, First_Choice => First_Choice, Flags => Flags, String_Type => Present (String_Type)); Set_First_Choice_Of (Current_Item, In_Tree, To => First_Choice); Expect (Tok_Arrow, "`=>`"); Set_End_Of_Line (Current_Item); Set_Previous_Line_Node (Current_Item); Parse_Declarative_Items (In_Tree => In_Tree, Declarations => First_Declarative_Item, In_Zone => In_Case_Construction, First_Attribute => First_Attribute, Current_Project => Current_Project, Current_Package => Current_Package, Packages_To_Check => Packages_To_Check, Is_Config_File => Is_Config_File, Flags => Flags); Set_First_Declarative_Item_Of (Current_Item, In_Tree, To => First_Declarative_Item); end if; end loop When_Loop; End_Case_Construction (Check_All_Labels => not When_Others and not Quiet_Output, Case_Location => Location_Of (Case_Construction, In_Tree), Flags => Flags, String_Type => Present (String_Type)); Expect (Tok_End, "`END CASE`"); Remove_Next_End_Node; if Token = Tok_End then -- Scan past "end" Scan (In_Tree); Expect (Tok_Case, "CASE"); end if; -- Scan past "case" Scan (In_Tree); Expect (Tok_Semicolon, "`;`"); Set_Previous_End_Node (Case_Construction); end Parse_Case_Construction; ----------------------------- -- Parse_Declarative_Items -- ----------------------------- procedure Parse_Declarative_Items (In_Tree : Project_Node_Tree_Ref; Declarations : out Project_Node_Id; In_Zone : Zone; First_Attribute : Attribute_Node_Id; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; Packages_To_Check : String_List_Access; Is_Config_File : Boolean; Flags : Processing_Flags) is Current_Declarative_Item : Project_Node_Id := Empty_Project_Node; Next_Declarative_Item : Project_Node_Id := Empty_Project_Node; Current_Declaration : Project_Node_Id := Empty_Project_Node; Item_Location : Source_Ptr := No_Location; begin Declarations := Empty_Project_Node; loop -- We are always positioned at the token that precedes the first -- token of the declarative element. Scan past it. Scan (In_Tree); Item_Location := Token_Ptr; case Token is when Tok_Identifier => if In_Zone = In_Case_Construction then -- Check if the variable has already been declared declare The_Variable : Project_Node_Id := Empty_Project_Node; begin if Present (Current_Package) then The_Variable := First_Variable_Of (Current_Package, In_Tree); elsif Present (Current_Project) then The_Variable := First_Variable_Of (Current_Project, In_Tree); end if; Find_Variable (The_Variable, Token_Name, In_Tree); -- If inside a package and the variable is not found, -- check if it is declared at the project level. if No (The_Variable) and then Present (Current_Package) and then Present (Current_Project) then The_Variable := First_Variable_Of (Current_Project, In_Tree); Find_Variable (The_Variable, Token_Name, In_Tree); end if; -- It is an error to declare a variable in a case -- construction for the first time. if No (The_Variable) then Error_Msg (Flags, "a variable cannot be declared for the first time" & " here", Token_Ptr); end if; end; end if; Parse_Variable_Declaration (In_Tree, Current_Declaration, Current_Project => Current_Project, Current_Package => Current_Package, Flags => Flags); Set_End_Of_Line (Current_Declaration); Set_Previous_Line_Node (Current_Declaration); when Tok_For => Parse_Attribute_Declaration (In_Tree => In_Tree, Attribute => Current_Declaration, First_Attribute => First_Attribute, Current_Project => Current_Project, Current_Package => Current_Package, Packages_To_Check => Packages_To_Check, Flags => Flags); Set_End_Of_Line (Current_Declaration); Set_Previous_Line_Node (Current_Declaration); when Tok_Null => Scan (In_Tree); -- past "null" when Tok_Package => -- Package declaration if In_Zone /= In_Project then Error_Msg (Flags, "a package cannot be declared here", Token_Ptr); end if; Parse_Package_Declaration (In_Tree => In_Tree, Package_Declaration => Current_Declaration, Current_Project => Current_Project, Packages_To_Check => Packages_To_Check, Is_Config_File => Is_Config_File, Flags => Flags); Set_Previous_End_Node (Current_Declaration); when Tok_Type => -- Type String Declaration if In_Zone /= In_Project then Error_Msg (Flags, "a string type cannot be declared here", Token_Ptr); end if; Parse_String_Type_Declaration (In_Tree => In_Tree, String_Type => Current_Declaration, Current_Project => Current_Project, Flags => Flags); Set_End_Of_Line (Current_Declaration); Set_Previous_Line_Node (Current_Declaration); when Tok_Case => -- Case construction Parse_Case_Construction (In_Tree => In_Tree, Case_Construction => Current_Declaration, First_Attribute => First_Attribute, Current_Project => Current_Project, Current_Package => Current_Package, Packages_To_Check => Packages_To_Check, Is_Config_File => Is_Config_File, Flags => Flags); Set_Previous_End_Node (Current_Declaration); when others => exit; -- We are leaving Parse_Declarative_Items positioned -- at the first token after the list of declarative items. -- It could be "end" (for a project, a package declaration or -- a case construction) or "when" (for a case construction) end case; Expect (Tok_Semicolon, "`;` after declarative items"); -- Insert an N_Declarative_Item in the tree, but only if -- Current_Declaration is not an empty node. if Present (Current_Declaration) then if No (Current_Declarative_Item) then Current_Declarative_Item := Default_Project_Node (Of_Kind => N_Declarative_Item, In_Tree => In_Tree); Declarations := Current_Declarative_Item; else Next_Declarative_Item := Default_Project_Node (Of_Kind => N_Declarative_Item, In_Tree => In_Tree); Set_Next_Declarative_Item (Current_Declarative_Item, In_Tree, To => Next_Declarative_Item); Current_Declarative_Item := Next_Declarative_Item; end if; Set_Current_Item_Node (Current_Declarative_Item, In_Tree, To => Current_Declaration); Set_Location_Of (Current_Declarative_Item, In_Tree, To => Item_Location); end if; end loop; end Parse_Declarative_Items; ------------------------------- -- Parse_Package_Declaration -- ------------------------------- procedure Parse_Package_Declaration (In_Tree : Project_Node_Tree_Ref; Package_Declaration : out Project_Node_Id; Current_Project : Project_Node_Id; Packages_To_Check : String_List_Access; Is_Config_File : Boolean; Flags : Processing_Flags) is First_Attribute : Attribute_Node_Id := Empty_Attribute; Current_Package : Package_Node_Id := Empty_Package; First_Declarative_Item : Project_Node_Id := Empty_Project_Node; Package_Location : constant Source_Ptr := Token_Ptr; Renaming : Boolean := False; Extending : Boolean := False; begin Package_Declaration := Default_Project_Node (Of_Kind => N_Package_Declaration, In_Tree => In_Tree); Set_Location_Of (Package_Declaration, In_Tree, To => Package_Location); -- Scan past "package" Scan (In_Tree); Expect (Tok_Identifier, "identifier"); if Token = Tok_Identifier then Set_Name_Of (Package_Declaration, In_Tree, To => Token_Name); Current_Package := Package_Node_Id_Of (Token_Name); if Current_Package = Empty_Package then if not Quiet_Output then declare List : constant Strings.String_List := Package_Name_List; Name : constant String := Get_Name_String (Token_Name); Pack : String_Access; Test : Natural; Dist : Natural := Natural'Last; function Close_Enough return Boolean is (Dist < 3); begin -- Check for possible misspelling of a known package name for P of List loop Test := Distance (Name, P.all); if Dist > Test then Dist := Test; Pack := P; end if; end loop; -- Issue warnings when a possible misspelling has been found -- otherwise simply inform in verbose mode if Close_Enough then Error_Msg (Flags, "?""" & Name & """ is not a known package name", Token_Ptr); Error_Msg -- CODEFIX (Flags, "\?possible misspelling of """ & Pack.all & '"', Token_Ptr); else if Verbose_Mode and then Opt.Verbosity_Level > Opt.Low then declare Sfile : Source_File_Index; Line : Line_Number; Col : Column_Number; FNT : File_Name_Type; begin Sfile := Get_Source_File_Index (Token_Ptr); if Full_Path_Name_For_Brief_Errors then FNT := Full_Ref_Name (Sfile); else FNT := Reference_Name (Sfile); end if; Line := Get_Line_Number (Token_Ptr); Col := Get_Column_Number (Token_Ptr); Write_Line (Get_Name_String (FNT) & ":" & Line'Img (Line'Img'First + 1 .. Line'Img'Last) & ":" & Col'Img (Col'Img'First + 1 .. Col'Img'Last) & ": """ & Name & """ is not a known package name"); end; end if; end if; end; end if; -- Set the package declaration to "ignored" so that it is not -- processed by GPR.Proc.Process. Set_Expression_Kind_Of (Package_Declaration, In_Tree, Ignored); -- Add the unknown package in the list of packages Add_Unknown_Package (Token_Name, Current_Package); elsif Current_Package = Unknown_Package then -- Set the package declaration to "ignored" so that it is not -- processed by GPR.Proc.Process. Set_Expression_Kind_Of (Package_Declaration, In_Tree, Ignored); else First_Attribute := First_Attribute_Of (Current_Package); end if; Set_Package_Id_Of (Package_Declaration, In_Tree, To => Current_Package); declare Current : Project_Node_Id := First_Package_Of (Current_Project, In_Tree); begin while Present (Current) and then Name_Of (Current, In_Tree) /= Token_Name loop Current := Next_Package_In_Project (Current, In_Tree); end loop; if Present (Current) then Error_Msg (Flags, "package """ & Get_Name_String_Safe (Name_Of (Package_Declaration, In_Tree)) & """ is declared twice in the same project", Token_Ptr); else -- Add the package to the project list Set_Next_Package_In_Project (Package_Declaration, In_Tree, To => First_Package_Of (Current_Project, In_Tree)); Set_First_Package_Of (Current_Project, In_Tree, To => Package_Declaration); end if; end; -- Scan past the package name Scan (In_Tree); end if; Check_Package_Allowed (In_Tree, Current_Project, Package_Declaration, Flags); if Token = Tok_Renames then Renaming := True; elsif Token = Tok_Extends then Extending := True; end if; if Renaming or else Extending then if Is_Config_File then Error_Msg (Flags, "no package rename or extension in configuration projects", Token_Ptr); end if; -- Scan past "renames" or "extends" Scan (In_Tree); declare Buffer : String (1 .. 1_024); Buffer_Last : Natural := 0; -- Local buffer for the renames/extends clause. -- The global buffer is already used by the scanner. Last_Dot_Index : Natural := 0; Project_Name : Name_Id := No_Name; Package_Name : Name_Id := No_Name; Project_Source_Ptr : Source_Ptr := No_Location; Package_Source_Ptr : Source_Ptr := No_Location; Success : Boolean := True; procedure Add_To_Buffer (S : String); -- Add S to the local buffer procedure Add_To_Buffer (S : String) is New_Buffer_Last : constant Integer := Buffer_Last + S'Length; begin Buffer (Buffer_Last + 1 .. New_Buffer_Last) := S; Buffer_Last := New_Buffer_Last; end Add_To_Buffer; begin loop Expect (Tok_Identifier, "identifier"); if Token /= Tok_Identifier then Success := False; exit; end if; -- On the first iteration we have the source pointer for the -- project name. After that, every iteration is assumed to give -- the source pointer and identifier for the package. if Project_Source_Ptr = No_Location then Project_Source_Ptr := Token_Ptr; else Package_Source_Ptr := Token_Ptr; Package_Name := Token_Name; end if; -- Add the identifier name to the buffer Add_To_Buffer (Get_Name_String (Token_Name)); -- Scan past the identifier Scan (In_Tree); exit when Token /= Tok_Dot; -- If we have a dot, add a dot to the Buffer and look for the -- next identifier. Add_To_Buffer ("."); Last_Dot_Index := Buffer_Last; -- Scan past the dot Scan (In_Tree); end loop; -- If no package name is set, it means we only did one iteration -- of the loop i.e. there was only one identifier. if Package_Name = No_Name then Success := False; Expect (Tok_Dot, "`.`"); -- we were indeed expecting a dot end if; if Success then -- The project name is the idenfier or group of identifiers -- that prefixes the package name (last dot excluded). Project_Name := Get_Name_Id (Buffer (1 .. Last_Dot_Index - 1)); -- Now check the project and package declare The_Project : Project_Node_Id := Empty_Project_Node; begin -- Look for a possible project name The_Project := Imported_Or_Extended_Project_Of (Current_Project, In_Tree, Project_Name); if Present (The_Project) then Set_Project_Of_Renamed_Package_Of (Package_Declaration, In_Tree, To => The_Project); else Error_Msg_Name_1 := Project_Name; Error_Msg (Flags, "% is not an imported or extended project", Project_Source_Ptr); end if; end; if Name_Of (Package_Declaration, In_Tree) /= Package_Name then Error_Msg (Flags, "not the same package name", Package_Source_Ptr); elsif Present (Project_Of_Renamed_Package_Of (Package_Declaration, In_Tree)) then declare Current : Project_Node_Id := First_Package_Of (Project_Of_Renamed_Package_Of (Package_Declaration, In_Tree), In_Tree); begin while Present (Current) and then Name_Of (Current, In_Tree) /= Package_Name loop Current := Next_Package_In_Project (Current, In_Tree); end loop; if No (Current) then Error_Msg (Flags, '"' & Get_Name_String_Safe (Package_Name) & """ is not a package declared by the project", Package_Source_Ptr); end if; end; end if; end if; end; end if; if Renaming then Expect (Tok_Semicolon, "`;`"); Set_End_Of_Line (Package_Declaration); Set_Previous_Line_Node (Package_Declaration); elsif Token = Tok_Is then Set_End_Of_Line (Package_Declaration); Set_Previous_Line_Node (Package_Declaration); Set_Next_End_Node (Package_Declaration); Parse_Declarative_Items (In_Tree => In_Tree, Declarations => First_Declarative_Item, In_Zone => In_Package, First_Attribute => First_Attribute, Current_Project => Current_Project, Current_Package => Package_Declaration, Packages_To_Check => Packages_To_Check, Is_Config_File => Is_Config_File, Flags => Flags); Set_First_Declarative_Item_Of (Package_Declaration, In_Tree, To => First_Declarative_Item); Expect (Tok_End, "END"); if Token = Tok_End then -- Scan past "end" Scan (In_Tree); end if; -- We should have the name of the package after "end" Expect (Tok_Identifier, "identifier"); if Token = Tok_Identifier and then Name_Of (Package_Declaration, In_Tree) /= No_Name and then Token_Name /= Name_Of (Package_Declaration, In_Tree) then Error_Msg_Name_1 := Name_Of (Package_Declaration, In_Tree); Error_Msg (Flags, "expected %%", Token_Ptr); end if; if Token /= Tok_Semicolon then -- Scan past the package name Scan (In_Tree); end if; Expect (Tok_Semicolon, "`;`"); Remove_Next_End_Node; else Error_Msg (Flags, "expected IS", Token_Ptr); end if; end Parse_Package_Declaration; ----------------------------------- -- Parse_String_Type_Declaration -- ----------------------------------- procedure Parse_String_Type_Declaration (In_Tree : Project_Node_Tree_Ref; String_Type : out Project_Node_Id; Current_Project : Project_Node_Id; Flags : Processing_Flags) is Current : Project_Node_Id := Empty_Project_Node; First_String : Project_Node_Id := Empty_Project_Node; begin String_Type := Default_Project_Node (Of_Kind => N_String_Type_Declaration, In_Tree => In_Tree); Set_Location_Of (String_Type, In_Tree, To => Token_Ptr); Set_Project_Node_Of (String_Type, In_Tree, To => Current_Project); -- Scan past "type" Scan (In_Tree); Expect (Tok_Identifier, "identifier"); if Token = Tok_Identifier then Set_Name_Of (String_Type, In_Tree, To => Token_Name); Current := First_String_Type_Of (Current_Project, In_Tree); while Present (Current) and then Name_Of (Current, In_Tree) /= Token_Name loop Current := Next_String_Type (Current, In_Tree); end loop; if Present (Current) then Error_Msg (Flags, "duplicate string type name """ & Get_Name_String_Safe (Token_Name) & '"', Token_Ptr); else Current := First_Variable_Of (Current_Project, In_Tree); while Present (Current) and then Name_Of (Current, In_Tree) /= Token_Name loop Current := Next_Variable (Current, In_Tree); end loop; if Present (Current) then Error_Msg (Flags, '"' & Get_Name_String_Safe (Token_Name) & """ is already a variable name", Token_Ptr); else Set_Next_String_Type (String_Type, In_Tree, To => First_String_Type_Of (Current_Project, In_Tree)); Set_First_String_Type_Of (Current_Project, In_Tree, To => String_Type); end if; end if; -- Scan past the name Scan (In_Tree); end if; Expect (Tok_Is, "IS"); if Token = Tok_Is then Scan (In_Tree); end if; Expect (Tok_Left_Paren, "`(`"); if Token = Tok_Left_Paren then Scan (In_Tree); end if; Parse_String_Type_List (In_Tree => In_Tree, First_String => First_String, Flags => Flags); Set_First_Literal_String (String_Type, In_Tree, To => First_String); Expect (Tok_Right_Paren, "`)`"); if Token = Tok_Right_Paren then Scan (In_Tree); end if; end Parse_String_Type_Declaration; -------------------------------- -- Parse_Variable_Declaration -- -------------------------------- procedure Parse_Variable_Declaration (In_Tree : Project_Node_Tree_Ref; Variable : out Project_Node_Id; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; Flags : Processing_Flags) is Expression_Location : Source_Ptr; String_Type_Name : Name_Id := No_Name; Project_String_Type_Name : Name_Id := No_Name; Type_Location : Source_Ptr := No_Location; Project_Location : Source_Ptr := No_Location; Expression : Project_Node_Id := Empty_Project_Node; Variable_Name : constant Name_Id := Token_Name; OK : Boolean := True; begin Variable := Default_Project_Node (Of_Kind => N_Variable_Declaration, In_Tree => In_Tree); Set_Name_Of (Variable, In_Tree, To => Variable_Name); Set_Location_Of (Variable, In_Tree, To => Token_Ptr); -- Scan past the variable name Scan (In_Tree); if Token = Tok_Colon then -- Typed string variable declaration Scan (In_Tree); Set_Kind_Of (Variable, In_Tree, N_Typed_Variable_Declaration); Set_Project_Node_Of (Variable, In_Tree, To => Current_Project); Expect (Tok_Identifier, "identifier"); OK := Token = Tok_Identifier; if OK then String_Type_Name := Token_Name; Type_Location := Token_Ptr; Scan (In_Tree); if Token = Tok_Dot then Project_String_Type_Name := String_Type_Name; Project_Location := Type_Location; -- Scan past the dot Scan (In_Tree); Expect (Tok_Identifier, "identifier"); if Token = Tok_Identifier then String_Type_Name := Token_Name; Type_Location := Token_Ptr; Scan (In_Tree); else OK := False; end if; end if; if OK then declare Proj : Project_Node_Id := Current_Project; Current : Project_Node_Id := Empty_Project_Node; begin if Project_String_Type_Name /= No_Name then declare The_Project_Name_And_Node : constant Tree_Private_Part.Project_Name_And_Node := Tree_Private_Part.Projects_Htable.Get (In_Tree.Projects_HT, Project_String_Type_Name); use Tree_Private_Part; begin if The_Project_Name_And_Node = Tree_Private_Part.No_Project_Name_And_Node then Error_Msg (Flags, "unknown project """ & Get_Name_String_Safe (Project_String_Type_Name) & '"', Project_Location); Current := Empty_Project_Node; else Current := First_String_Type_Of (The_Project_Name_And_Node.Node, In_Tree); while Present (Current) and then Name_Of (Current, In_Tree) /= String_Type_Name loop Current := Next_String_Type (Current, In_Tree); end loop; end if; end; else -- Look for a string type with the correct name in this -- project or in any of its ancestors. loop Current := First_String_Type_Of (Proj, In_Tree); while Present (Current) and then Name_Of (Current, In_Tree) /= String_Type_Name loop Current := Next_String_Type (Current, In_Tree); end loop; exit when Present (Current); Proj := Parent_Project_Of (Proj, In_Tree); exit when No (Proj); end loop; end if; if No (Current) then Error_Msg (Flags, "unknown string type """ & Get_Name_String_Safe (String_Type_Name) & '"', Type_Location); OK := False; else Set_String_Type_Of (Variable, In_Tree, To => Current); end if; end; end if; end if; end if; Expect (Tok_Colon_Equal, "`:=`"); OK := OK and then Token = Tok_Colon_Equal; if Token = Tok_Colon_Equal then Scan (In_Tree); end if; -- Get the single string or string list value Expression_Location := Token_Ptr; Parse_Expression (In_Tree => In_Tree, Expression => Expression, Flags => Flags, Current_Project => Current_Project, Current_Package => Current_Package, Optional_Index => False); Set_Expression_Of (Variable, In_Tree, To => Expression); if Present (Expression) then -- A typed string must have a single string value, not a list if Kind_Of (Variable, In_Tree) = N_Typed_Variable_Declaration and then Expression_Kind_Of (Expression, In_Tree) = List then Error_Msg (Flags, "expression must be a single string", Expression_Location); end if; Set_Expression_Kind_Of (Variable, In_Tree, To => Expression_Kind_Of (Expression, In_Tree)); end if; if OK then declare The_Variable : Project_Node_Id := Empty_Project_Node; begin if Present (Current_Package) then The_Variable := First_Variable_Of (Current_Package, In_Tree); elsif Present (Current_Project) then The_Variable := First_Variable_Of (Current_Project, In_Tree); end if; Find_Variable (The_Variable, Variable_Name, In_Tree); if No (The_Variable) then if Present (Current_Package) then Set_Next_Variable (Variable, In_Tree, To => First_Variable_Of (Current_Package, In_Tree)); Set_First_Variable_Of (Current_Package, In_Tree, To => Variable); elsif Present (Current_Project) then Set_Next_Variable (Variable, In_Tree, To => First_Variable_Of (Current_Project, In_Tree)); Set_First_Variable_Of (Current_Project, In_Tree, To => Variable); end if; else if Expression_Kind_Of (Variable, In_Tree) /= Undefined then if Expression_Kind_Of (The_Variable, In_Tree) = Undefined then Set_Expression_Kind_Of (The_Variable, In_Tree, To => Expression_Kind_Of (Variable, In_Tree)); else if Expression_Kind_Of (The_Variable, In_Tree) /= Expression_Kind_Of (Variable, In_Tree) then Error_Msg (Flags, "wrong expression kind for variable """ & Get_Name_String_Safe (Name_Of (The_Variable, In_Tree)) & '"', Expression_Location); end if; end if; end if; end if; end; end if; end Parse_Variable_Declaration; end GPR.Dect; gprbuild-25.0.0/gpr/src/gpr-dect.ads000066400000000000000000000061201470075373400171740ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2015, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- Parse a list of declarative items in a project file with GPR.Tree; private package GPR.Dect is procedure Parse (In_Tree : GPR.Tree.Project_Node_Tree_Ref; Declarations : out GPR.Project_Node_Id; Current_Project : GPR.Project_Node_Id; Extends : GPR.Project_Node_Id; Packages_To_Check : String_List_Access; Is_Config_File : Boolean; Flags : Processing_Flags); -- Parse project declarative items -- -- In_Tree is the project node tree -- -- Declarations is the resulting project node -- -- Current_Project is the project node of the project for which the -- declarative items are parsed. -- -- Extends is the project node of the project that project Current_Project -- extends. If project Current-Project does not extend any project, -- Extends has the value Empty_Node. -- -- Packages_To_Check is the list of packages that needs to be checked. -- For legal packages declared in project Current_Project that are not in -- Packages_To_Check, only the syntax of the declarations are checked, not -- the attribute names and kinds. -- -- Is_Config_File should be set to True if the project represents a config -- file (.cgpr) since some specific checks apply. end GPR.Dect; gprbuild-25.0.0/gpr/src/gpr-env.adb000066400000000000000000002167571470075373400170470ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2022, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Strings.Unbounded; with Ada.Text_IO; use Ada.Text_IO; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.HTable; with GNAT.String_Split; with GPR.Opt; with GPR.Com; use GPR.Com; with GPR.Names; use GPR.Names; with GPR.Osint; use GPR.Osint; with GPR.Output; use GPR.Output; with GPR.Tempdir; with GPR.Util; use GPR.Util; package body GPR.Env is Buffer_Initial : constant := 1_000; -- Initial arbitrary size of buffers No_Project_Default_Dir : constant String := "-"; -- Indicator in the project path to indicate that the default search -- directories should not be added to the path ----------------------- -- Local Subprograms -- ----------------------- package Source_Path_Table is new GNAT.Dynamic_Tables (Table_Component_Type => Name_Id, Table_Index_Type => Natural, Table_Low_Bound => 1, Table_Initial => 50, Table_Increment => 100); -- A table to store the source dirs before creating the source path file package Object_Path_Table is new GNAT.Dynamic_Tables (Table_Component_Type => Path_Name_Type, Table_Index_Type => Natural, Table_Low_Bound => 1, Table_Initial => 50, Table_Increment => 100); -- A table to store the object dirs, before creating the object path file procedure Add_To_Buffer (S : String; Buffer : in out String_Access; Buffer_Last : in out Natural); -- Add a string to Buffer, extending Buffer if needed procedure Add_To_Path (Source_Dirs : String_List_Id; Shared : Shared_Project_Tree_Data_Access; Buffer : in out String_Access; Buffer_Last : in out Natural); -- Add to Ada_Path_Buffer all the source directories in string list -- Source_Dirs, if any. procedure Add_To_Path (Dir : String; Buffer : in out String_Access; Buffer_Last : in out Natural); -- If Dir is not already in the global variable Ada_Path_Buffer, add it. -- If Buffer_Last /= 0, prepend a Path_Separator character to Path. procedure Add_To_Source_Path (Source_Dirs : String_List_Id; Shared : Shared_Project_Tree_Data_Access; Source_Paths : in out Source_Path_Table.Instance); -- Add to Ada_Path_B all the source directories in string list -- Source_Dirs, if any. Increment Ada_Path_Length. procedure Add_To_Object_Path (Object_Dir : Path_Name_Type; Object_Paths : in out Object_Path_Table.Instance); -- Add Object_Dir to object path table. Make sure it is not duplicate -- and it is the last one in the current table. function To_Vector (Path : String) return Util.String_Vectors.Vector; ---------------------- -- Ada_Include_Path -- ---------------------- function Ada_Include_Path (Project : Project_Id; In_Tree : Project_Tree_Ref; Recursive : Boolean := False) return String is Buffer : String_Access; Buffer_Last : Natural := 0; procedure Add (Project : Project_Id; In_Tree : Project_Tree_Ref; Dummy : in out Boolean); -- Add source dirs of Project to the path --------- -- Add -- --------- procedure Add (Project : Project_Id; In_Tree : Project_Tree_Ref; Dummy : in out Boolean) is begin Add_To_Path (Project.Source_Dirs, In_Tree.Shared, Buffer, Buffer_Last); end Add; procedure For_All_Projects is new For_Every_Project_Imported (Boolean, Add); Dummy : Boolean := False; -- Start of processing for Ada_Include_Path begin if Recursive then -- If it is the first time we call this function for this project, -- compute the source path. if Project.Ada_Include_Path = null then Buffer := new String (1 .. Buffer_Initial); For_All_Projects (Project, In_Tree, Dummy, Include_Aggregated => True); Project.Ada_Include_Path := new String'(Buffer (1 .. Buffer_Last)); Free (Buffer); end if; return Project.Ada_Include_Path.all; else Buffer := new String (1 .. Buffer_Initial); Add_To_Path (Project.Source_Dirs, In_Tree.Shared, Buffer, Buffer_Last); declare Result : constant String := Buffer (1 .. Buffer_Last); begin Free (Buffer); return Result; end; end if; end Ada_Include_Path; ---------------------- -- Ada_Objects_Path -- ---------------------- function Ada_Objects_Path (Project : Project_Id; In_Tree : Project_Tree_Ref; Including_Libraries : Boolean := True) return String_Access is Buffer : String_Access; Buffer_Last : Natural := 0; procedure Add (Project : Project_Id; In_Tree : Project_Tree_Ref; Dummy : in out Boolean); -- Add all the object directories of a project to the path --------- -- Add -- --------- procedure Add (Project : Project_Id; In_Tree : Project_Tree_Ref; Dummy : in out Boolean) is pragma Unreferenced (In_Tree); Path : constant Path_Name_Type := Get_Object_Directory (Project, Including_Libraries => Including_Libraries, Only_If_Ada => False); begin if Path /= No_Path then Add_To_Path (Get_Name_String (Path), Buffer, Buffer_Last); end if; end Add; procedure For_All_Projects is new For_Every_Project_Imported (Boolean, Add); Dummy : Boolean := False; Result : String_Access; -- Start of processing for Ada_Objects_Path begin -- If it is the first time we call this function for -- this project, compute the objects path if Including_Libraries and then Project.Ada_Objects_Path /= null then return Project.Ada_Objects_Path; elsif not Including_Libraries and then Project.Ada_Objects_Path_No_Libs /= null then return Project.Ada_Objects_Path_No_Libs; else Buffer := new String (1 .. Buffer_Initial); For_All_Projects (Project, In_Tree, Dummy); Result := new String'(Buffer (1 .. Buffer_Last)); Free (Buffer); if Including_Libraries then Project.Ada_Objects_Path := Result; else Project.Ada_Objects_Path_No_Libs := Result; end if; return Result; end if; end Ada_Objects_Path; ------------------- -- Add_To_Buffer -- ------------------- procedure Add_To_Buffer (S : String; Buffer : in out String_Access; Buffer_Last : in out Natural) is Last : constant Natural := Buffer_Last + S'Length; begin while Last > Buffer'Last loop declare New_Buffer : constant String_Access := new String (1 .. 2 * Buffer'Last); begin New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last); Free (Buffer); Buffer := New_Buffer; end; end loop; Buffer (Buffer_Last + 1 .. Last) := S; Buffer_Last := Last; end Add_To_Buffer; ------------------------ -- Add_To_Object_Path -- ------------------------ procedure Add_To_Object_Path (Object_Dir : Path_Name_Type; Object_Paths : in out Object_Path_Table.Instance) is begin -- Check if the directory is already in the table for Index in Object_Path_Table.First .. Object_Path_Table.Last (Object_Paths) loop -- If it is, remove it, and add it as the last one if Object_Paths.Table (Index) = Object_Dir then for Index2 in Index + 1 .. Object_Path_Table.Last (Object_Paths) loop Object_Paths.Table (Index2 - 1) := Object_Paths.Table (Index2); end loop; Object_Paths.Table (Object_Path_Table.Last (Object_Paths)) := Object_Dir; return; end if; end loop; -- The directory is not already in the table, add it Object_Path_Table.Append (Object_Paths, Object_Dir); end Add_To_Object_Path; ----------------- -- Add_To_Path -- ----------------- procedure Add_To_Path (Source_Dirs : String_List_Id; Shared : Shared_Project_Tree_Data_Access; Buffer : in out String_Access; Buffer_Last : in out Natural) is Current : String_List_Id; Source_Dir : String_Element; begin Current := Source_Dirs; while Current /= Nil_String loop Source_Dir := Shared.String_Elements.Table (Current); Add_To_Path (Get_Name_String (Source_Dir.Display_Value), Buffer, Buffer_Last); Current := Source_Dir.Next; end loop; end Add_To_Path; procedure Add_To_Path (Dir : String; Buffer : in out String_Access; Buffer_Last : in out Natural) is Len : Natural; New_Buffer : String_Access; Min_Len : Natural; function Is_Present (Path : String; Dir : String) return Boolean; -- Return True if Dir is part of Path ---------------- -- Is_Present -- ---------------- function Is_Present (Path : String; Dir : String) return Boolean is Last : constant Integer := Path'Last - Dir'Length + 1; begin for J in Path'First .. Last loop -- Note: the order of the conditions below is important, since -- it ensures a minimal number of string comparisons. if (J = Path'First or else Path (J - 1) = Path_Separator) and then (J + Dir'Length > Path'Last or else Path (J + Dir'Length) = Path_Separator) and then Dir = Path (J .. J + Dir'Length - 1) then return True; end if; end loop; return False; end Is_Present; -- Start of processing for Add_To_Path begin if Is_Present (Buffer (1 .. Buffer_Last), Dir) then -- Dir is already in the path, nothing to do return; end if; Min_Len := Buffer_Last + Dir'Length; if Buffer_Last > 0 then -- Add 1 for the Path_Separator character Min_Len := Min_Len + 1; end if; -- If Ada_Path_Buffer is too small, increase it Len := Buffer'Last; if Len < Min_Len then loop Len := Len * 2; exit when Len >= Min_Len; end loop; New_Buffer := new String (1 .. Len); New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last); Free (Buffer); Buffer := New_Buffer; end if; if Buffer_Last > 0 then Buffer_Last := Buffer_Last + 1; Buffer (Buffer_Last) := Path_Separator; end if; Buffer (Buffer_Last + 1 .. Buffer_Last + Dir'Length) := Dir; Buffer_Last := Buffer_Last + Dir'Length; end Add_To_Path; ------------------------ -- Add_To_Source_Path -- ------------------------ procedure Add_To_Source_Path (Source_Dirs : String_List_Id; Shared : Shared_Project_Tree_Data_Access; Source_Paths : in out Source_Path_Table.Instance) is Current : String_List_Id; Source_Dir : String_Element; Add_It : Boolean; begin -- Add each source directory Current := Source_Dirs; while Current /= Nil_String loop Source_Dir := Shared.String_Elements.Table (Current); Add_It := True; -- Check if the source directory is already in the table for Index in Source_Path_Table.First .. Source_Path_Table.Last (Source_Paths) loop -- If it is already, no need to add it if Source_Paths.Table (Index) = Source_Dir.Value then Add_It := False; exit; end if; end loop; if Add_It then Source_Path_Table.Append (Source_Paths, Source_Dir.Display_Value); end if; -- Next source directory Current := Source_Dir.Next; end loop; end Add_To_Source_Path; -------------------------------- -- Create_Config_Pragmas_File -- -------------------------------- procedure Create_Config_Pragmas_File (For_Project : Project_Id; In_Tree : Project_Tree_Ref) is type Naming_Id is new Nat; package Naming_Table is new GNAT.Dynamic_Tables (Table_Component_Type => Lang_Naming_Data, Table_Index_Type => Naming_Id, Table_Low_Bound => 1, Table_Initial => 5, Table_Increment => 100); Default_Naming : constant Naming_Id := Naming_Table.First; Namings : Naming_Table.Instance; -- Table storing the naming data for gnatmake/gprmake Buffer : String_Access := new String (1 .. Buffer_Initial); Buffer_Last : Natural := 0; File_Name : Path_Name_Type := No_Path; File : File_Descriptor := Invalid_FD; Current_Naming : Naming_Id; procedure Check (Project : Project_Id; In_Tree : Project_Tree_Ref; State : in out Integer); -- Recursive procedure that put in the config pragmas file any non -- standard naming schemes, if it is not already in the file, then call -- itself for any imported project. procedure Put (Source : Source_Id); -- Put an SFN pragma in the temporary file procedure Put (S : String); procedure Put_Line (S : String); -- Output procedures, analogous to normal Text_IO procs of same name. -- The text is put in Buffer, then it will be written into a temporary -- file with procedure Write_Temp_File below. procedure Write_Temp_File; -- Create a temporary file and put the content of the buffer in it ----------- -- Check -- ----------- procedure Check (Project : Project_Id; In_Tree : Project_Tree_Ref; State : in out Integer) is pragma Unreferenced (State); Lang : constant Language_Ptr := Get_Language_From_Name (Project, "ada"); Naming : Lang_Naming_Data; Iter : Source_Iterator; Source : Source_Id; begin if Current_Verbosity = High then Debug_Output ("Checking project file:", Project.Name); end if; if Lang = null then if Current_Verbosity = High then Debug_Output ("Languages does not contain Ada, nothing to do"); end if; return; end if; -- Visit all the files and process those that need an SFN pragma Iter := For_Each_Source (In_Tree, Project); while Element (Iter) /= No_Source loop Source := Element (Iter); if not Source.Locally_Removed and then Source.Unit /= null and then (Source.Index >= 1 or else Source.Naming_Exception /= No) then Put (Source); end if; Next (Iter); end loop; Naming := Lang.Config.Naming_Data; -- Is the naming scheme of this project one that we know? Current_Naming := Default_Naming; while Current_Naming <= Naming_Table.Last (Namings) and then Namings.Table (Current_Naming).Dot_Replacement = Naming.Dot_Replacement and then Namings.Table (Current_Naming).Casing = Naming.Casing and then Namings.Table (Current_Naming).Separate_Suffix = Naming.Separate_Suffix loop Current_Naming := Current_Naming + 1; end loop; -- If we don't know it, add it if Current_Naming > Naming_Table.Last (Namings) then Naming_Table.Increment_Last (Namings); Namings.Table (Naming_Table.Last (Namings)) := Naming; -- Put the SFN pragmas for the naming scheme -- Spec Put_Line ("pragma Source_File_Name_Project"); Put_Line (" (Spec_File_Name => ""*" & Get_Name_String (Naming.Spec_Suffix) & ""","); Put_Line (" Casing => " & Image (Naming.Casing) & ","); Put_Line (" Dot_Replacement => """ & Get_Name_String (Naming.Dot_Replacement) & """);"); -- and body Put_Line ("pragma Source_File_Name_Project"); Put_Line (" (Body_File_Name => ""*" & Get_Name_String (Naming.Body_Suffix) & ""","); Put_Line (" Casing => " & Image (Naming.Casing) & ","); Put_Line (" Dot_Replacement => """ & Get_Name_String (Naming.Dot_Replacement) & """);"); -- and maybe separate if Naming.Body_Suffix /= Naming.Separate_Suffix then Put_Line ("pragma Source_File_Name_Project"); Put_Line (" (Subunit_File_Name => ""*" & Get_Name_String (Naming.Separate_Suffix) & ""","); Put_Line (" Casing => " & Image (Naming.Casing) & ","); Put_Line (" Dot_Replacement => """ & Get_Name_String (Naming.Dot_Replacement) & """);"); end if; end if; end Check; --------- -- Put -- --------- procedure Put (Source : Source_Id) is begin -- Put the pragma SFN for the unit kind (spec or body) Put ("pragma Source_File_Name_Project ("); Put (Get_Name_String (Source.Unit.Name)); if Source.Kind = Spec then Put (", Spec_File_Name => """); else Put (", Body_File_Name => """); end if; Put (Get_Name_String (Source.File)); Put (""""); if Source.Index /= 0 then Put (", Index =>"); Put (Source.Index'Img); end if; Put_Line (");"); end Put; procedure Put (S : String) is begin Add_To_Buffer (S, Buffer, Buffer_Last); if Current_Verbosity = High then Write_Str (S); end if; end Put; -------------- -- Put_Line -- -------------- procedure Put_Line (S : String) is begin -- Add an ASCII.LF to the string. As this config file is supposed to -- be used only by the compiler, we don't care about the characters -- for the end of line. In fact we could have put a space, but -- it is more convenient to be able to read gnat.adc during -- development, for which the ASCII.LF is fine. Put (S); Put (S => (1 => ASCII.LF)); end Put_Line; --------------------- -- Write_Temp_File -- --------------------- procedure Write_Temp_File is Status : Boolean := False; Last : Natural; begin Create_Temp_File (In_Tree.Shared, File, File_Name, "config pragmas"); if File /= Invalid_FD then Last := Write (File, Buffer (1)'Address, Buffer_Last); if Last = Buffer_Last then Close (File, Status); end if; end if; if not Status then GPR.Com.Fail ("unable to create temporary file"); end if; end Write_Temp_File; procedure Check_Imported_Projects is new For_Every_Project_Imported (Integer, Check); Dummy : Integer := 0; -- Start of processing for Create_Config_Pragmas_File use Opt; begin if not For_Project.Config_Checked then Naming_Table.Init (Namings); -- Check the naming schemes Check_Imported_Projects (For_Project, In_Tree, Dummy, Imported_First => False); -- If there are no non standard naming scheme, issue the GNAT -- standard naming scheme. This will tell the compiler that -- a project file is used and will forbid any pragma SFN. if Buffer_Last = 0 then Put_Line ("pragma Source_File_Name_Project"); Put_Line (" (Spec_File_Name => ""*.ads"","); Put_Line (" Dot_Replacement => ""-"","); Put_Line (" Casing => lowercase);"); Put_Line ("pragma Source_File_Name_Project"); Put_Line (" (Body_File_Name => ""*.adb"","); Put_Line (" Dot_Replacement => ""-"","); Put_Line (" Casing => lowercase);"); end if; -- Close the temporary file Write_Temp_File; if Opt.Verbosity_Level > Opt.Low then Write_Str ("Created configuration file """); Write_Str (Get_Name_String (File_Name)); Write_Line (""""); end if; For_Project.Config_File_Name := File_Name; For_Project.Config_File_Temp := True; For_Project.Config_Checked := True; end if; Free (Buffer); end Create_Config_Pragmas_File; ------------------------- -- Create_Mapping_File -- ------------------------- package Mapping is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, Element => Source_Id, No_Element => No_Source, Key => Name_Id, Hash => Hash, Equal => "="); -- A table to store the non excluded sources type Source_Unit is record Source : Source_Id := No_Source; Unit : Name_Id := No_Name; end record; No_Source_Unit : constant Source_Unit := (No_Source, No_Name); package Mapping_Excluded_Paths is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, Element => Source_Unit, No_Element => No_Source_Unit, Key => Path_Name_Type, Hash => Hash, Equal => "="); -- A table to store the excluded sources procedure Create_Mapping_File (Project : Project_Id; Language : Name_Id; In_Tree : Project_Tree_Ref; Name : out Path_Name_Type) is File : File_Descriptor := Invalid_FD; Buffer : String_Access := new String (1 .. Buffer_Initial); Buffer_Last : Natural := 0; procedure Put_Name_Buffer; -- Put the line contained in the Name_Buffer in the global buffer procedure Process (Project : Project_Id; In_Tree : Project_Tree_Ref; State : in out Integer); -- Generate the mapping file for Project (not recursively) --------------------- -- Put_Name_Buffer -- --------------------- procedure Put_Name_Buffer is begin if Current_Verbosity = High then Debug_Output (Name_Buffer (1 .. Name_Len)); end if; Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := ASCII.LF; Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last); end Put_Name_Buffer; ------------- -- Process -- ------------- procedure Process (Project : Project_Id; In_Tree : Project_Tree_Ref; State : in out Integer) is pragma Unreferenced (State); Source : Source_Id; Iter : Source_Iterator; Unit : Name_Id; begin Debug_Output ("Add mapping for project", Project.Name); Iter := For_Each_Source (In_Tree, Project, Language => Language); loop Source := GPR.Element (Iter); exit when Source = No_Source; if Source.Replaced_By = No_Source and then Source.Path.Name /= No_Path and then Source.Unit /= No_Unit_Index then -- Get the encoded unit name in the name buffer declare Uname : constant String := Get_Name_String (Source.Unit.Name); begin Name_Len := 0; for J in Uname'Range loop if Uname (J) in Upper_Half_Character then Store_Encoded_Character (Get_Char_Code (Uname (J))); else Add_Char_To_Name_Buffer (Uname (J)); end if; end loop; end; Add_Char_To_Name_Buffer ('%'); if Source.Kind = Spec then Add_Char_To_Name_Buffer ('s'); else Add_Char_To_Name_Buffer ('b'); end if; Unit := Name_Find; declare Src : constant Source_Id := Mapping.Get (Unit); begin if Src = No_Source or else not (Source.Locally_Removed or else Source.Suppressed) then if Source.Locally_Removed or else Source.Suppressed then if Src = No_Source then Mapping_Excluded_Paths.Set (Source.Path.Name, (Source, Unit)); end if; else Mapping.Set (Unit, Source); -- Remove any excluded source with the same path, if -- any. Mapping_Excluded_Paths.Remove (Source.Path.Name); -- Also remove any excluded source with the same unit -- name. declare Src_Unit : Source_Unit := No_Source_Unit; Path : Path_Name_Type := No_Path; begin Mapping_Excluded_Paths.Get_First (Path, Src_Unit); while Src_Unit /= No_Source_Unit loop if Src_Unit.Unit = Unit then Mapping_Excluded_Paths.Remove (Path); exit; end if; Mapping_Excluded_Paths.Get_Next (Path, Src_Unit); end loop; end; end if; end if; end; end if; Next (Iter); end loop; end Process; procedure For_Every_Imported_Project is new For_Every_Project_Imported (State => Integer, Action => Process); -- Local variables Dummy : Integer := 0; -- Start of processing for Create_Mapping_File begin if Current_Verbosity = High then Debug_Output ("Create mapping file for", Debug_Name (In_Tree)); end if; Create_Temp_File (In_Tree.Shared, File, Name, "mapping"); if Current_Verbosity = High then Debug_Increase_Indent ("Create mapping file ", Name_Id (Name)); end if; Mapping.Reset; Mapping_Excluded_Paths.Reset; For_Every_Imported_Project (Project, In_Tree, Dummy, Include_Aggregated => False); declare Last : Natural; Status : Boolean := False; Unit : Name_Id := No_Name; Source : Source_Id; Path : Path_Name_Type := No_Path; Src_Unit : Source_Unit; begin if File /= Invalid_FD then -- First the non excluded sources Mapping.Get_First (Unit, Source); while Source /= No_Source loop Get_Name_String (Unit); Put_Name_Buffer; Get_Name_String (Source.Display_File); Put_Name_Buffer; Get_Name_String (Source.Path.Display_Name); Put_Name_Buffer; Mapping.Get_Next (Unit, Source); end loop; -- Then the excluded sources, if any Mapping_Excluded_Paths.Get_First (Path, Src_Unit); while Src_Unit /= No_Source_Unit loop Get_Name_String (Src_Unit.Unit); Put_Name_Buffer; Get_Name_String (Src_Unit.Source.Display_File); Put_Name_Buffer; Name_Len := 1; Name_Buffer (1) := '/'; Put_Name_Buffer; Mapping_Excluded_Paths.Get_Next (Path, Src_Unit); end loop; Last := Write (File, Buffer (1)'Address, Buffer_Last); if Last = Buffer_Last then GNAT.OS_Lib.Close (File, Status); end if; end if; if not Status then GPR.Com.Fail ("could not write mapping file"); end if; end; Free (Buffer); Debug_Decrease_Indent ("Done create mapping file"); end Create_Mapping_File; ---------------------- -- Create_Temp_File -- ---------------------- procedure Create_Temp_File (Shared : Shared_Project_Tree_Data_Access; Path_FD : out File_Descriptor; Path_Name : out Path_Name_Type; File_Use : String) is begin Tempdir.Create_Temp_File (Path_FD, Path_Name); if Path_Name /= No_Path then if Current_Verbosity = High then Write_Line ("Create temp file (" & File_Use & ") " & Get_Name_String_Safe (Path_Name)); end if; Record_Temp_File (Shared, Path_Name); else GPR.Com.Fail ("unable to create temporary " & File_Use & " file"); end if; end Create_Temp_File; -------------------------- -- Create_New_Path_File -- -------------------------- procedure Create_New_Path_File (Shared : Shared_Project_Tree_Data_Access; Path_FD : out File_Descriptor; Path_Name : out Path_Name_Type) is begin Create_Temp_File (Shared, Path_FD, Path_Name, "path file"); end Create_New_Path_File; ------------------------------------ -- File_Name_Of_Library_Unit_Body -- ------------------------------------ function File_Name_Of_Library_Unit_Body (Name : String; Project : Project_Id; In_Tree : Project_Tree_Ref; Main_Project_Only : Boolean := True; Full_Path : Boolean := False) return String is Lang : constant Language_Ptr := Get_Language_From_Name (Project, "ada"); The_Project : Project_Id := Project; Original_Name : String := Name; Unit : Unit_Index; The_Original_Name : Name_Id; The_Spec_Name : Name_Id; The_Body_Name : Name_Id; begin -- ??? Same block in Project_Of Canonical_Case_File_Name (Original_Name); Name_Len := Original_Name'Length; Name_Buffer (1 .. Name_Len) := Original_Name; The_Original_Name := Name_Find; if Lang /= null then declare Naming : constant Lang_Naming_Data := Lang.Config.Naming_Data; Extended_Spec_Name : String := Name & Get_Name_String (Naming.Spec_Suffix); Extended_Body_Name : String := Name & Get_Name_String (Naming.Body_Suffix); begin Canonical_Case_File_Name (Extended_Spec_Name); Name_Len := Extended_Spec_Name'Length; Name_Buffer (1 .. Name_Len) := Extended_Spec_Name; The_Spec_Name := Name_Find; Canonical_Case_File_Name (Extended_Body_Name); Name_Len := Extended_Body_Name'Length; Name_Buffer (1 .. Name_Len) := Extended_Body_Name; The_Body_Name := Name_Find; end; else Name_Len := Name'Length; Name_Buffer (1 .. Name_Len) := Name; Canonical_Case_File_Name (Name_Buffer); The_Spec_Name := Name_Find; The_Body_Name := The_Spec_Name; end if; if Current_Verbosity = High then Write_Str ("Looking for file name of """); Write_Str (Name); Write_Char ('"'); Write_Eol; Write_Str (" Extended Spec Name = """); Write_Str (Get_Name_String (The_Spec_Name)); Write_Char ('"'); Write_Eol; Write_Str (" Extended Body Name = """); Write_Str (Get_Name_String (The_Body_Name)); Write_Char ('"'); Write_Eol; end if; -- For extending project, search in the extended project if the source -- is not found. For non extending projects, this loop will be run only -- once. loop -- Loop through units Unit := Units_Htable.Get_First (In_Tree.Units_HT); while Unit /= null loop -- Check for body if not Main_Project_Only or else (Unit.File_Names (Impl) /= null and then Unit.File_Names (Impl).Project = The_Project) then declare Current_Name : File_Name_Type; begin -- Case of a body present if Unit.File_Names (Impl) /= null then Current_Name := Unit.File_Names (Impl).File; if Current_Verbosity = High then Write_Str (" Comparing with """); Write_Str (Get_Name_String (Current_Name)); Write_Char ('"'); Write_Eol; end if; -- If it has the name of the original name, return the -- original name. if Unit.Name = The_Original_Name or else Current_Name = File_Name_Type (The_Original_Name) then if Current_Verbosity = High then Write_Line (" OK"); end if; if Full_Path then return Get_Name_String (Unit.File_Names (Impl).Path.Name); else return Get_Name_String (Current_Name); end if; -- If it has the name of the extended body name, -- return the extended body name elsif Current_Name = File_Name_Type (The_Body_Name) then if Current_Verbosity = High then Write_Line (" OK"); end if; if Full_Path then return Get_Name_String (Unit.File_Names (Impl).Path.Name); else return Get_Name_String (The_Body_Name); end if; else if Current_Verbosity = High then Put_Line (" not good"); end if; end if; end if; end; end if; -- Check for spec if not Main_Project_Only or else (Unit.File_Names (Spec) /= null and then Unit.File_Names (Spec).Project = The_Project) then declare Current_Name : File_Name_Type; begin -- Case of spec present if Unit.File_Names (Spec) /= null then Current_Name := Unit.File_Names (Spec).File; if Current_Verbosity = High then Write_Str (" Comparing with """); Write_Str (Get_Name_String (Current_Name)); Write_Char ('"'); Write_Eol; end if; -- If name same as original name, return original name if Unit.Name = The_Original_Name or else Current_Name = File_Name_Type (The_Original_Name) then if Current_Verbosity = High then Write_Line (" OK"); end if; if Full_Path then return Get_Name_String (Unit.File_Names (Spec).Path.Name); else return Get_Name_String (Current_Name); end if; -- If it has the same name as the extended spec name, -- return the extended spec name. elsif Current_Name = File_Name_Type (The_Spec_Name) then if Current_Verbosity = High then Write_Line (" OK"); end if; if Full_Path then return Get_Name_String (Unit.File_Names (Spec).Path.Name); else return Get_Name_String (The_Spec_Name); end if; else if Current_Verbosity = High then Write_Line (" not good"); end if; end if; end if; end; end if; Unit := Units_Htable.Get_Next (In_Tree.Units_HT); end loop; -- If we are not in an extending project, give up exit when not Main_Project_Only or else The_Project.Extends = No_Project; -- Otherwise, look in the project we are extending The_Project := The_Project.Extends; end loop; -- We don't know this file name, return an empty string return ""; end File_Name_Of_Library_Unit_Body; ------------------------- -- For_All_Object_Dirs -- ------------------------- procedure For_All_Object_Dirs (Project : Project_Id; Tree : Project_Tree_Ref) is procedure For_Project (Prj : Project_Id; Tree : Project_Tree_Ref; Dummy : in out Integer); -- Get all object directories of Prj ----------------- -- For_Project -- ----------------- procedure For_Project (Prj : Project_Id; Tree : Project_Tree_Ref; Dummy : in out Integer) is pragma Unreferenced (Tree); begin -- ??? Set_Ada_Paths has a different behavior for library project -- files, should we have the same ? if Prj.Object_Directory /= No_Path_Information then Get_Name_String (Prj.Object_Directory.Display_Name); Action (Name_Buffer (1 .. Name_Len)); end if; end For_Project; procedure Get_Object_Dirs is new For_Every_Project_Imported (Integer, For_Project); Dummy : Integer := 1; -- Start of processing for For_All_Object_Dirs begin Get_Object_Dirs (Project, Tree, Dummy); end For_All_Object_Dirs; ------------------------- -- For_All_Source_Dirs -- ------------------------- procedure For_All_Source_Dirs (Project : Project_Id; In_Tree : Project_Tree_Ref) is procedure For_Project (Prj : Project_Id; In_Tree : Project_Tree_Ref; Dummy : in out Integer); -- Get all object directories of Prj ----------------- -- For_Project -- ----------------- procedure For_Project (Prj : Project_Id; In_Tree : Project_Tree_Ref; Dummy : in out Integer) is Current : String_List_Id := Prj.Source_Dirs; The_String : String_Element; begin -- If there are Ada sources, call action with the name of every -- source directory. if Has_Ada_Sources (Prj) then while Current /= Nil_String loop The_String := In_Tree.Shared.String_Elements.Table (Current); Action (Get_Name_String (The_String.Display_Value)); Current := The_String.Next; end loop; end if; end For_Project; procedure Get_Source_Dirs is new For_Every_Project_Imported (Integer, For_Project); Dummy : Integer := 1; -- Start of processing for For_All_Source_Dirs begin Get_Source_Dirs (Project, In_Tree, Dummy); end For_All_Source_Dirs; ------------------- -- Get_Reference -- ------------------- procedure Get_Reference (Source_File_Name : String; In_Tree : Project_Tree_Ref; Project : out Project_Id; Path : out Path_Name_Type) is begin -- Body below could use some comments ??? if Current_Verbosity > Default then Write_Str ("Getting Reference_Of ("""); Write_Str (Source_File_Name); Write_Str (""") ... "); end if; declare Original_Name : String := Source_File_Name; Unit : Unit_Index; begin Canonical_Case_File_Name (Original_Name); Unit := Units_Htable.Get_First (In_Tree.Units_HT); while Unit /= null loop if Unit.File_Names (Spec) /= null and then not Unit.File_Names (Spec).Locally_Removed and then Unit.File_Names (Spec).File /= No_File and then (Get_Name_String (Unit.File_Names (Spec).File) = Original_Name or else (Unit.File_Names (Spec).Path /= No_Path_Information and then Get_Name_String (Unit.File_Names (Spec).Path.Name) = Original_Name)) then Project := Ultimate_Extending_Project_Of (Unit.File_Names (Spec).Project); Path := Unit.File_Names (Spec).Path.Display_Name; if Current_Verbosity > Default then Write_Str ("Done: Spec."); Write_Eol; end if; return; elsif Unit.File_Names (Impl) /= null and then Unit.File_Names (Impl).File /= No_File and then not Unit.File_Names (Impl).Locally_Removed and then (Get_Name_String (Unit.File_Names (Impl).File) = Original_Name or else (Unit.File_Names (Impl).Path /= No_Path_Information and then Get_Name_String (Unit.File_Names (Impl).Path.Name) = Original_Name)) then Project := Ultimate_Extending_Project_Of (Unit.File_Names (Impl).Project); Path := Unit.File_Names (Impl).Path.Display_Name; if Current_Verbosity > Default then Write_Str ("Done: Body."); Write_Eol; end if; return; end if; Unit := Units_Htable.Get_Next (In_Tree.Units_HT); end loop; end; Project := No_Project; Path := No_Path; if Current_Verbosity > Default then Write_Str ("Cannot be found."); Write_Eol; end if; end Get_Reference; ---------------------- -- Get_Runtime_Path -- ---------------------- function Get_Runtime_Path (Self : in out Project_Search_Path; Name : String) return String_Access is function Find_Rts_In_Path is new GPR.Env.Find_Name_In_Path (Check_Filename => Is_Directory); begin return Find_Rts_In_Path (Self, Name); end Get_Runtime_Path; ---------------- -- Initialize -- ---------------- procedure Initialize (In_Tree : Project_Tree_Ref) is begin In_Tree.Shared.Private_Part.Current_Source_Path_File := No_Path; In_Tree.Shared.Private_Part.Current_Object_Path_File := No_Path; end Initialize; ------------------- -- Print_Sources -- ------------------- -- Could use some comments in this body ??? procedure Print_Sources (In_Tree : Project_Tree_Ref) is Unit : Unit_Index; begin Write_Line ("List of Sources:"); Unit := Units_Htable.Get_First (In_Tree.Units_HT); while Unit /= No_Unit_Index loop Write_Str (" "); Write_Line (Get_Name_String (Unit.Name)); if Unit.File_Names (Spec).File /= No_File then if Unit.File_Names (Spec).Project = No_Project then Write_Line (" No project"); else Write_Str (" Project: "); Get_Name_String (Unit.File_Names (Spec).Project.Path.Name); Write_Line (Name_Buffer (1 .. Name_Len)); end if; Write_Str (" spec: "); Write_Line (Get_Name_String (Unit.File_Names (Spec).File)); end if; if Unit.File_Names (Impl).File /= No_File then if Unit.File_Names (Impl).Project = No_Project then Write_Line (" No project"); else Write_Str (" Project: "); Get_Name_String (Unit.File_Names (Impl).Project.Path.Name); Write_Line (Name_Buffer (1 .. Name_Len)); end if; Write_Str (" body: "); Write_Line (Get_Name_String (Unit.File_Names (Impl).File)); end if; Unit := Units_Htable.Get_Next (In_Tree.Units_HT); end loop; Write_Line ("end of List of Sources."); end Print_Sources; ---------------- -- Project_Of -- ---------------- function Project_Of (Name : String; Main_Project : Project_Id; In_Tree : Project_Tree_Ref) return Project_Id is Result : Project_Id := No_Project; Original_Name : String := Name; Lang : constant Language_Ptr := Get_Language_From_Name (Main_Project, "ada"); Unit : Unit_Index; Current_Name : File_Name_Type; The_Original_Name : File_Name_Type; The_Spec_Name : File_Name_Type; The_Body_Name : File_Name_Type; begin -- ??? Same block in File_Name_Of_Library_Unit_Body Canonical_Case_File_Name (Original_Name); Name_Len := Original_Name'Length; Name_Buffer (1 .. Name_Len) := Original_Name; The_Original_Name := Name_Find; if Lang /= null then declare Naming : Lang_Naming_Data renames Lang.Config.Naming_Data; Extended_Spec_Name : String := Name & Get_Name_String (Naming.Spec_Suffix); Extended_Body_Name : String := Name & Get_Name_String (Naming.Body_Suffix); begin Canonical_Case_File_Name (Extended_Spec_Name); Name_Len := Extended_Spec_Name'Length; Name_Buffer (1 .. Name_Len) := Extended_Spec_Name; The_Spec_Name := Name_Find; Canonical_Case_File_Name (Extended_Body_Name); Name_Len := Extended_Body_Name'Length; Name_Buffer (1 .. Name_Len) := Extended_Body_Name; The_Body_Name := Name_Find; end; else The_Spec_Name := The_Original_Name; The_Body_Name := The_Original_Name; end if; Unit := Units_Htable.Get_First (In_Tree.Units_HT); while Unit /= null loop -- Case of a body present if Unit.File_Names (Impl) /= null then Current_Name := Unit.File_Names (Impl).File; -- If it has the name of the original name or the body name, -- we have found the project. if Unit.Name = Name_Id (The_Original_Name) or else Current_Name = The_Original_Name or else Current_Name = The_Body_Name then Result := Unit.File_Names (Impl).Project; exit; end if; end if; -- Check for spec if Unit.File_Names (Spec) /= null then Current_Name := Unit.File_Names (Spec).File; -- If name same as the original name, or the spec name, we have -- found the project. if Unit.Name = Name_Id (The_Original_Name) or else Current_Name = The_Original_Name or else Current_Name = The_Spec_Name then Result := Unit.File_Names (Spec).Project; exit; end if; end if; Unit := Units_Htable.Get_Next (In_Tree.Units_HT); end loop; return Ultimate_Extending_Project_Of (Result); end Project_Of; ------------------- -- Set_Ada_Paths -- ------------------- procedure Set_Ada_Paths (Project : Project_Id; In_Tree : Project_Tree_Ref; Including_Libraries : Boolean; Include_Path : Boolean := True; Objects_Path : Boolean := True) is Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared; Source_Paths : Source_Path_Table.Instance; Object_Paths : Object_Path_Table.Instance; -- List of source or object dirs. Only computed the first time this -- procedure is called (since Source_FD is then reused) Source_FD : File_Descriptor := Invalid_FD; Object_FD : File_Descriptor := Invalid_FD; -- The temporary files to store the paths. These are only created the -- first time this procedure is called, and reused from then on. Process_Source_Dirs : Boolean := False; Process_Object_Dirs : Boolean := False; Status : Boolean; -- For calls to Close Last : Natural; Buffer : String_Access := new String (1 .. Buffer_Initial); Buffer_Last : Natural := 0; procedure Recursive_Add (Project : Project_Id; In_Tree : Project_Tree_Ref; Dummy : in out Boolean); -- Recursive procedure to add the source/object paths of extended/ -- imported projects. ------------------- -- Recursive_Add -- ------------------- procedure Recursive_Add (Project : Project_Id; In_Tree : Project_Tree_Ref; Dummy : in out Boolean) is pragma Unreferenced (In_Tree); Path : Path_Name_Type; begin if Process_Source_Dirs then -- Add to path all source directories of this project if there are -- Ada sources. if Has_Ada_Sources (Project) then Add_To_Source_Path (Project.Source_Dirs, Shared, Source_Paths); end if; end if; if Process_Object_Dirs then Path := Get_Object_Directory (Project, Including_Libraries => Including_Libraries, Only_If_Ada => True); if Path /= No_Path then Add_To_Object_Path (Path, Object_Paths); end if; end if; end Recursive_Add; procedure For_All_Projects is new For_Every_Project_Imported (Boolean, Recursive_Add); Dummy : Boolean := False; -- Start of processing for Set_Ada_Paths begin -- If it is the first time we call this procedure for this project, -- compute the source path and/or the object path. if Include_Path and then Project.Include_Path_File = No_Path then Source_Path_Table.Init (Source_Paths); Process_Source_Dirs := True; Create_New_Path_File (Shared, Source_FD, Project.Include_Path_File); end if; -- For the object path, we make a distinction depending on -- Including_Libraries. if Objects_Path and Including_Libraries then if Project.Objects_Path_File_With_Libs = No_Path then Object_Path_Table.Init (Object_Paths); Process_Object_Dirs := True; Create_New_Path_File (Shared, Object_FD, Project.Objects_Path_File_With_Libs); end if; elsif Objects_Path then if Project.Objects_Path_File_Without_Libs = No_Path then Object_Path_Table.Init (Object_Paths); Process_Object_Dirs := True; Create_New_Path_File (Shared, Object_FD, Project.Objects_Path_File_Without_Libs); end if; end if; -- If there is something to do, set Seen to False for all projects, -- then call the recursive procedure Add for Project. if Process_Source_Dirs or Process_Object_Dirs then For_All_Projects (Project, In_Tree, Dummy); end if; -- Write and close any file that has been created. Source_FD is not set -- when this subprogram is called a second time or more, since we reuse -- the previous version of the file. if Source_FD /= Invalid_FD then Buffer_Last := 0; for Index in Source_Path_Table.First .. Source_Path_Table.Last (Source_Paths) loop Get_Name_String (Source_Paths.Table (Index)); Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := ASCII.LF; Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last); end loop; Last := Write (Source_FD, Buffer (1)'Address, Buffer_Last); if Last = Buffer_Last then Close (Source_FD, Status); else Status := False; end if; if not Status then GPR.Com.Fail ("could not write temporary file"); end if; end if; if Object_FD /= Invalid_FD then Buffer_Last := 0; for Index in Object_Path_Table.First .. Object_Path_Table.Last (Object_Paths) loop Get_Name_String (Object_Paths.Table (Index)); Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := ASCII.LF; Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last); end loop; Last := Write (Object_FD, Buffer (1)'Address, Buffer_Last); if Last = Buffer_Last then Close (Object_FD, Status); else Status := False; end if; if not Status then GPR.Com.Fail ("could not write temporary file"); end if; end if; -- Set the env vars, if they need to be changed, and set the -- corresponding flags. if Include_Path and then Shared.Private_Part.Current_Source_Path_File /= Project.Include_Path_File then Shared.Private_Part.Current_Source_Path_File := Project.Include_Path_File; Set_Path_File_Var (Project_Include_Path_File, Get_Name_String (Shared.Private_Part.Current_Source_Path_File)); end if; if Objects_Path then if Including_Libraries then if Shared.Private_Part.Current_Object_Path_File /= Project.Objects_Path_File_With_Libs then Shared.Private_Part.Current_Object_Path_File := Project.Objects_Path_File_With_Libs; Set_Path_File_Var (Project_Objects_Path_File, Get_Name_String (Shared.Private_Part.Current_Object_Path_File)); end if; else if Shared.Private_Part.Current_Object_Path_File /= Project.Objects_Path_File_Without_Libs then Shared.Private_Part.Current_Object_Path_File := Project.Objects_Path_File_Without_Libs; Set_Path_File_Var (Project_Objects_Path_File, Get_Name_String (Shared.Private_Part.Current_Object_Path_File)); end if; end if; end if; Free (Buffer); end Set_Ada_Paths; --------------- -- To_Vector -- --------------- function To_Vector (Path : String) return Util.String_Vectors.Vector is use GNAT.String_Split; Result : Util.String_Vectors.Vector; begin for P of Create (Path, (1 => Path_Separator), Mode => Multiple) loop Result.Append (P); end loop; return Result; end To_Vector; --------------------- -- Add_Directories -- --------------------- procedure Add_Directories (Self : in out Project_Search_Path; Path : String; Prepend : Boolean := False) is begin if Prepend then Self.Path.Prepend_Vector (To_Vector (Path)); else Self.Path.Append_Vector (To_Vector (Path)); end if; if Current_Verbosity = High then Debug_Output ("Adding directories to Project_Path: """ & Path & '"'); end if; end Add_Directories; ---------------------- -- Initialize_Empty -- ---------------------- procedure Initialize_Empty (Self : in out Project_Search_Path) is begin Self.Path.Clear; Self.Initialized := True; end Initialize_Empty; ------------------------------------- -- Initialize_Default_Project_Path -- ------------------------------------- procedure Initialize_Default_Project_Path (Self : in out Project_Search_Path; Target_Name : String; Runtime_Name : String := "") is Add_Default_Dir : Boolean := Target_Name /= "-"; Index : Positive; Ada_Project_Path : constant String := "ADA_PROJECT_PATH"; Gpr_Project_Path : constant String := "GPR_PROJECT_PATH"; Gpr_Project_Path_File : constant String := "GPR_PROJECT_PATH_FILE"; -- Names of alternate env. variable that contain path name(s) of -- directories where project files may reside. They are taken into -- account in this order: GPR_PROJECT_PATH_FILE, GPR_PROJECT_PATH, -- ADA_PROJECT_PATH. Gpr_Prj_Path_File : String_Access; Gpr_Prj_Path : String_Access; Ada_Prj_Path : String_Access; -- The path name(s) of directories where project files may reside. -- May be empty. -- Start of processing for Initialize_Default_Project_Path begin if Is_Initialized (Self) then return; end if; -- The current directory is always first in the search path. Since the -- Project_Path currently starts with '#:' as a sign that it isn't -- initialized, we simply replace '#' with '.' Self.Path.Prepend ("."); Self.Initialized := True; -- Then the reset of the project path (if any) currently contains the -- directories added through Add_Search_Project_Directory -- If environment variables are defined and not empty, add their content Gpr_Prj_Path_File := Getenv (Gpr_Project_Path_File); Gpr_Prj_Path := Getenv (Gpr_Project_Path); Ada_Prj_Path := Getenv (Ada_Project_Path); if Gpr_Prj_Path_File.all /= "" then declare File : Ada.Text_IO.File_Type; Line : String (1 .. 10_000); Last : Natural; begin Open (File, In_File, Gpr_Prj_Path_File.all); while not End_Of_File (File) loop Get_Line (File, Line, Last); if Last /= 0 and then (Last = 1 or else Line (1 .. 2) /= "--") then Self.Path.Append (Line (1 .. Last)); end if; if Current_Verbosity = High then Debug_Output ("Adding directory to Project_Path: """ & Line (1 .. Last) & '"'); end if; end loop; Close (File); exception when others => Write_Str ("warning: could not read project path file """); Write_Str (Gpr_Prj_Path_File.all); Write_Line (""""); end; end if; Free (Gpr_Prj_Path_File); if Gpr_Prj_Path.all /= "" then Add_Directories (Self, Gpr_Prj_Path.all); end if; Free (Gpr_Prj_Path); if Ada_Prj_Path.all /= "" then Add_Directories (Self, Ada_Prj_Path.all); end if; Free (Ada_Prj_Path); -- Scan the directory path to see if "-" is one of the directories. -- Remove each occurrence of "-" and set Add_Default_Dir to False. -- Also resolve relative paths and symbolic links. Index := 2; while Index <= Self.Path.Last_Index loop -- If the directory is "-", set Add_Default_Dir to False and -- remove from path. if Self.Path (Index) = No_Project_Default_Dir then Add_Default_Dir := False; Self.Path.Delete (Index); else declare New_Dir : constant String := Normalize_Pathname (Self.Path (Index), Resolve_Links => Opt.Follow_Links_For_Dirs); begin -- If the absolute path was resolved and is different from -- the original, replace original with the resolved path. if New_Dir /= Self.Path (Index) and then New_Dir /= "" then Self.Path.Replace_Element (Index, New_Dir); end if; end; Index := Index + 1; end if; end loop; -- Set the initial value of Current_Project_Path if Add_Default_Dir and then Target_Name /= "" and then Runtime_Name /= "" and then Base_Name (Runtime_Name) /= Runtime_Name then declare Runtime_Dir : constant String := Normalize_Pathname (Runtime_Name) & Directory_Separator; begin -- $runtime_dir/lib/gnat Self.Path.Append (Runtime_Dir & "lib" & Directory_Separator & "gnat"); -- $runtime_dir/share/gpr Self.Path.Append (Runtime_Dir & "share" & Directory_Separator & "gpr"); end; end if; end Initialize_Default_Project_Path; ------------- -- Iterate -- ------------- procedure Iterate (Self : Project_Search_Path; Action : not null access procedure (Path : String)) is procedure Process (Position : Util.String_Vectors.Cursor); -- Calls Action for element at Position ------------- -- Process -- ------------- procedure Process (Position : Util.String_Vectors.Cursor) is begin Action (Util.String_Vectors.Element (Position)); end Process; begin Self.Path.Iterate (Process'Access); end Iterate; -------------- -- Get_Path -- -------------- function Get_Path (Self : Project_Search_Path) return String is Length : Integer := Self.Path.Last_Index - 1; Index : Positive := 1; begin pragma Assert (Is_Initialized (Self)); for P of Self.Path loop Length := Length + P'Length; end loop; if Self.Path.Is_Empty then return ""; end if; return Path : String (1 .. Length) do for Idx in Self.Path.First_Index .. Self.Path.Last_Index - 1 loop declare P : constant Util.String_Vectors.Constant_Reference_Type := Self.Path (Idx); begin Path (Index .. Index + P.Element'Length - 1) := P; Index := Index + P.Element'Length; Path (Index) := Path_Separator; Index := Index + 1; end; end loop; Path (Index .. Path'Last) := Self.Path.Last_Element; end return; end Get_Path; -------------- -- Set_Path -- -------------- procedure Set_Path (Self : in out Project_Search_Path; Path : String) is begin Self.Path := To_Vector (Path); Self.Cache.Clear; end Set_Path; ----------------------- -- Find_Name_In_Path -- ----------------------- function Find_Name_In_Path (Self : in out Project_Search_Path; Path : String) return String_Access is use Ada.Strings.Unbounded; Current_Dir : Unbounded_String; CF : Project_Path_Maps.Cursor; function Current_Dir_Cached return String; function Current_Dir_Cached return String is begin if Current_Dir = Null_Unbounded_String then Current_Dir := To_Unbounded_String (Get_Current_Dir); end if; return To_String (Current_Dir); end Current_Dir_Cached; begin if Current_Verbosity = High then Debug_Output ("Trying " & Path); end if; if Is_Absolute_Path (Path) then if Check_Filename (Path) then return new String'(Path); else return null; end if; end if; CF := Self.Found.Find (Path); if Project_Path_Maps.Has_Element (CF) then declare P : constant String_Vectors.Constant_Reference_Type := Self.Path (Project_Path_Maps.Element (CF)); Candidate : constant String := (if Is_Absolute_Path (P) then "" else Current_Dir_Cached) & Ensure_Directory (P) & Path; begin if Check_Filename (Candidate) then return new String'(Candidate); else -- Cache miss Self.Found.Clear; end if; end; end if; -- Because we don't want to resolve symbolic links, we cannot use -- Locate_Regular_File. So, we try each possible path successively. for CP in Self.Path.Iterate loop Name_Len := 0; if not Is_Absolute_Path (Self.Path (CP)) then Add_Str_To_Name_Buffer (Current_Dir_Cached); end if; Add_Str_To_Name_Buffer (Ensure_Directory (Self.Path (CP))); Add_Str_To_Name_Buffer (Path); if Current_Verbosity = High then Debug_Output ("Testing file " & Name_Buffer (1 .. Name_Len)); end if; if Check_Filename (Name_Buffer (1 .. Name_Len)) then Self.Found.Insert (Path, String_Vectors.To_Index (CP)); return new String'(Name_Buffer (1 .. Name_Len)); end if; end loop; return null; end Find_Name_In_Path; ------------------ -- Find_Project -- ------------------ procedure Find_Project (Self : in out Project_Search_Path; Project_File_Name : String; Directory : String; Path : out Path_Name_Type) is File : constant String := Ensure_Extension (Project_File_Name, Project_File_Extension); -- Check if File contains an extension (a dot before a directory -- separator). If it is the case we do not try project file with an -- added extension as it is not possible to have multiple dots on a -- project file name. Result : String_Access; -- Keep temporary search results here before final conversion into Path Normalized : Boolean := False; function Is_Regular_File_Cached (Name : String) return Boolean; -- Calls GNAT.OS_Lib.Is_Regular_File is Name not found in Self.Cache -- and put result into the cache. ---------------------------- -- Is_Regular_File_Cached -- ---------------------------- function Is_Regular_File_Cached (Name : String) return Boolean is Position : constant Projects_Paths.Cursor := Self.Cache.Find (Name); begin if Projects_Paths.Has_Element (Position) then return Projects_Paths.Element (Position); end if; return Result : constant Boolean := Is_Regular_File (Name) do Self.Cache.Insert (Name, Result); end return; end Is_Regular_File_Cached; function Try_Path_Name is new Find_Name_In_Path (Check_Filename => Is_Regular_File_Cached); -- Find a file in the project search path -- Start of processing for Find_Project begin pragma Assert (Is_Initialized (Self)); if Current_Verbosity = High then Debug_Increase_Indent ("Searching for project """ & File & """ in """ & Directory & '"'); end if; if not Is_Absolute_Path (File) and then Directory /= "" then Result := Try_Path_Name (Self, GNAT.OS_Lib.Normalize_Pathname (File, Directory => Directory, Resolve_Links => Opt.Follow_Links_For_Files, Case_Sensitive => True)); Normalized := Result /= null; end if; if Result = null then Result := Try_Path_Name (Self, File); end if; -- If we cannot find the project file, we return an empty string if Result = null then Path := No_Path; return; else Path := Get_Path_Name_Id (if Normalized then Result.all else GNAT.OS_Lib.Normalize_Pathname (Result.all, Directory => Directory, Resolve_Links => Opt.Follow_Links_For_Files, Case_Sensitive => True)); Free (Result); end if; Debug_Decrease_Indent; end Find_Project; ---------- -- Free -- ---------- procedure Free (Self : in out Project_Search_Path) is begin Self.Path.Clear; Self.Cache.Clear; end Free; ---------- -- Copy -- ---------- procedure Copy (From : Project_Search_Path; To : out Project_Search_Path) is begin Free (To); To.Path := From.Path; -- No need to copy the Cache, it will be recomputed as needed end Copy; ----------------- -- Reset_Cache -- ----------------- procedure Reset_Cache (Self : in out Project_Search_Path) is begin Self.Cache.Clear; end Reset_Cache; end GPR.Env; gprbuild-25.0.0/gpr/src/gpr-env.ads000066400000000000000000000312341470075373400170510ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2022, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package implements services for Project-aware tools, mostly related -- to the environment (configuration pragma files, path files, mapping files). with Ada.Containers.Indefinite_Hashed_Maps; with Ada.Strings.Hash; with GPR.Util; package GPR.Env is procedure Initialize (In_Tree : Project_Tree_Ref); -- Initialize global components relative to environment variables procedure Print_Sources (In_Tree : Project_Tree_Ref); -- Output the list of sources after Project files have been scanned procedure Create_Temp_File (Shared : Shared_Project_Tree_Data_Access; Path_FD : out File_Descriptor; Path_Name : out Path_Name_Type; File_Use : String); -- Create temporary file, fail with an error if it could not be created procedure Create_Mapping_File (Project : Project_Id; Language : Name_Id; In_Tree : Project_Tree_Ref; Name : out Path_Name_Type); -- Create a temporary mapping file for project Project. For each source or -- template of Language in the Project, put the mapping of its file name -- and path name in this file. See fmap for a description of the format -- of the mapping file. -- -- Implementation note: we pass a language name, not a language_index here, -- since the latter would have to match exactly the index of that language -- for the specified project, and that is not information available in -- buildgpr.adb. procedure Create_Config_Pragmas_File (For_Project : Project_Id; In_Tree : Project_Tree_Ref); -- If we need SFN pragmas, either for non standard naming schemes or for -- individual units. procedure Create_New_Path_File (Shared : Shared_Project_Tree_Data_Access; Path_FD : out File_Descriptor; Path_Name : out Path_Name_Type); -- Create a new temporary path file, placing file name in Path_Name function Ada_Include_Path (Project : Project_Id; In_Tree : Project_Tree_Ref; Recursive : Boolean := False) return String; -- Get the source search path of a Project file. If Recursive it True, get -- all the source directories of the imported and modified project files -- (recursively). If Recursive is False, just get the path for the source -- directories of Project. Note: the resulting String may be empty if there -- is no source directory in the project file. function Ada_Objects_Path (Project : Project_Id; In_Tree : Project_Tree_Ref; Including_Libraries : Boolean := True) return String_Access; -- Get the ADA_OBJECTS_PATH of a Project file. For the first call with the -- exact same parameters, compute it and cache it. When Including_Libraries -- is True, the object directory of a library project is replaced with the -- library ALI directory of this project (usually the library directory of -- the project, except when attribute Library_ALI_Dir is declared) except -- when the library ALI directory does not contain any ALI file. procedure Set_Ada_Paths (Project : Project_Id; In_Tree : Project_Tree_Ref; Including_Libraries : Boolean; Include_Path : Boolean := True; Objects_Path : Boolean := True); -- Set the environment variables for additional project path files, after -- creating the path files if necessary. function File_Name_Of_Library_Unit_Body (Name : String; Project : Project_Id; In_Tree : Project_Tree_Ref; Main_Project_Only : Boolean := True; Full_Path : Boolean := False) return String; -- Returns the file name of a library unit, in canonical case. Name may or -- may not have an extension (corresponding to the naming scheme of the -- project). If there is no body with this name, but there is a spec, the -- name of the spec is returned. -- -- If Full_Path is False (the default), the simple file name is returned. -- If Full_Path is True, the absolute path name is returned. -- -- If neither a body nor a spec can be found, an empty string is returned. -- If Main_Project_Only is True, the unit must be an immediate source of -- Project. If it is False, it may be a source of one of its imported -- projects. function Project_Of (Name : String; Main_Project : Project_Id; In_Tree : Project_Tree_Ref) return Project_Id; -- Get the project of a source. The source file name may be truncated -- (".adb" or ".ads" may be missing). If the source is in a project being -- extended, return the ultimate extending project. If it is not a source -- of any project, return No_Project. procedure Get_Reference (Source_File_Name : String; In_Tree : Project_Tree_Ref; Project : out Project_Id; Path : out Path_Name_Type); -- Returns the project of a source and its path in displayable form generic with procedure Action (Path : String); procedure For_All_Source_Dirs (Project : Project_Id; In_Tree : Project_Tree_Ref); -- Iterate through all the source directories of a project, including those -- of imported or modified projects. Only returns those directories that -- potentially contain Ada sources (ie ignore projects that have no Ada -- sources generic with procedure Action (Path : String); procedure For_All_Object_Dirs (Project : Project_Id; Tree : Project_Tree_Ref); -- Iterate through all the object directories of a project, including those -- of imported or modified projects. ------------------ -- Project Path -- ------------------ type Project_Search_Path is private; -- An abstraction of the project path. This object provides subprograms -- to search for projects on the path (and caches the results to improve -- efficiency). No_Project_Search_Path : constant Project_Search_Path; procedure Initialize_Default_Project_Path (Self : in out Project_Search_Path; Target_Name : String; Runtime_Name : String := ""); -- Initialize Self. It will then contain the default project path on -- the given target and runtime (including directories specified by the -- environment variables GPR_PROJECT_PATH_FILE, GPR_PROJECT_PATH and -- ADA_PROJECT_PATH). If one of the directory or Target_Name is "-", then -- the path contains only those directories specified by the environment -- variables (except "-"). This does nothing if Self has already been -- initialized. procedure Copy (From : Project_Search_Path; To : out Project_Search_Path); -- Copy From into To procedure Initialize_Empty (Self : in out Project_Search_Path); -- Initialize self with an empty list of directories. If Self had already -- been set, it is reset. function Is_Initialized (Self : Project_Search_Path) return Boolean; -- Whether Self has been initialized procedure Free (Self : in out Project_Search_Path); -- Free the memory used by Self procedure Add_Directories (Self : in out Project_Search_Path; Path : String; Prepend : Boolean := False); -- Add one or more directories to the path. Directories added with this -- procedure are added in order after the current directory and before the -- path given by the environment variable GPR_PROJECT_PATH. A value of "-" -- will remove the default project directory from the project path. -- -- Calls to this subprogram must be performed before the first call to -- Find_Project below, or PATH will be added at the end of the search path. function Get_Path (Self : Project_Search_Path) return String; -- Return the current value of the project path, either the value set -- during elaboration of the package or, if procedure Set_Project_Path has -- been called, the value set by the last call to Set_Project_Path. -- Self must have been initialized first. procedure Iterate (Self : Project_Search_Path; Action : not null access procedure (Path : String)); -- Calls Process for each path in Self procedure Set_Path (Self : in out Project_Search_Path; Path : String); -- Override the value of the project path. This also removes the implicit -- default search directories. procedure Reset_Cache (Self : in out Project_Search_Path); -- Remove from the cache the project paths that have already been found generic with function Check_Filename (Name : String) return Boolean; function Find_Name_In_Path (Self : in out Project_Search_Path; Path : String) return String_Access; -- Find a name in the project search path of Self. Check_Filename is -- the predicate to valid the search. If Path is an absolute filename, -- simply calls the predicate with Path. Otherwise, calls the predicate -- for each component of the path. Stops as soon as the predicate -- returns True and returns the name, or returns null in case of failure. procedure Find_Project (Self : in out Project_Search_Path; Project_File_Name : String; Directory : String; Path : out Path_Name_Type); -- Search for a project with the given name either in Directory (which -- often will be the directory contain the project we are currently parsing -- and which we found a reference to another project), or in the project -- path Self. Self must have been initialized first. -- -- Project_File_Name can optionally contain a path, and the extension -- (.gpr) for the file name is optional. -- -- Returns No_Name if no such project was found function Get_Runtime_Path (Self : in out Project_Search_Path; Name : String) return String_Access; -- Compute the full path for the project-based runtime name. -- Name is simply searched on the project path. private package Projects_Paths is new Ada.Containers.Indefinite_Hashed_Maps (Key_Type => String, Element_Type => Boolean, Hash => Ada.Strings.Hash, Equivalent_Keys => "="); package Project_Path_Maps is new Ada.Containers.Indefinite_Hashed_Maps (Key_Type => String, Element_Type => Positive, Hash => Ada.Strings.Hash, Equivalent_Keys => "="); type Project_Search_Path is record Path : Util.String_Vectors.Vector; -- As a special case, if the first character is '#:" or this variable -- is unset, this means that the PATH has not been fully initialized -- yet (although subprograms above will properly take care of that). Cache : Projects_Paths.Map; Found : Project_Path_Maps.Map; Initialized : Boolean := False; end record; No_Project_Search_Path : constant Project_Search_Path := (others => <>); function Is_Initialized (Self : Project_Search_Path) return Boolean is (Self.Initialized); end GPR.Env; gprbuild-25.0.0/gpr/src/gpr-err-scanner.adb000066400000000000000000002507141470075373400204650ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2015-2021, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ pragma Warnings (Off); with System.CRC32; with System.UTF_32; use System.UTF_32; with System.WCh_Con; use System.WCh_Con; with System.WCh_Cnv; use System.WCh_Cnv; pragma Warnings (On); with GPR.Snames; use GPR.Snames; separate (GPR.Err) package body Scanner is subtype Line_Terminator is Character range ASCII.LF .. ASCII.CR; -- Line terminator characters (LF, VT, FF, CR) subtype Graphic_Character is Character range ' ' .. '~'; Language_For_Scanner : Language := Project; Special_Characters : array (Character) of Boolean := (others => False); -- For characters that are Special token, the value is True Comment_Is_Token : Boolean := False; -- True if comments are tokens End_Of_Line_Is_Token : Boolean := False; -- True if End_Of_Line is a token String_Buffer : array (1 .. 10_000) of Char_Code; String_Last : Natural := 0; String_Buffer_Overflow : Boolean := False; -- Flag that String_Buffer overflow ----------------------- -- Local Subprograms -- ----------------------- procedure Accumulate_Token_Checksum; pragma Inline (Accumulate_Token_Checksum); -- Called after each numeric literal and identifier/keyword. For keywords, -- the token used is Tok_Identifier. This allows detection of additional -- spaces added in sources when using the builder switch -m. procedure Accumulate_Token_Checksum_GNAT_6_3; -- Used in place of Accumulate_Token_Checksum for GNAT versions 5.04 to -- 6.3, when Tok_Some was not included in Token_Type and the actual -- Token_Type was used for keywords. This procedure is never used in the -- compiler or gnatmake, only in gprbuild. procedure Accumulate_Token_Checksum_GNAT_5_03; -- Used in place of Accumulate_Token_Checksum for GNAT version 5.03, when -- Tok_Interface, Tok_Some, Tok_Synchronized and Tok_Overriding were not -- included in Token_Type and the actual Token_Type was used for keywords. -- This procedure is never used in the compiler or gnatmake, only in -- gprbuild. procedure Accumulate_Checksum (C : Character); pragma Inline (Accumulate_Checksum); -- This routine accumulates the checksum given character C. During the -- scanning of a source file, this routine is called with every character -- in the source, excluding blanks, and all control characters (except -- that ESC is included in the checksum). Upper case letters not in string -- literals are folded by the caller. See Sinput spec for the documentation -- of the checksum algorithm. Note: checksum values are only used if we -- generate code, so it is not necessary to worry about making the right -- sequence of calls in any error situation. procedure Accumulate_Checksum (C : Char_Code); pragma Inline (Accumulate_Checksum); -- This version is identical, except that the argument, C, is a character -- code value instead of a character. This is used when wide characters -- are scanned. We use the character code rather than the ASCII characters -- so that the checksum is independent of wide character encoding method. function End_String return Name_Id; procedure Error_Illegal_Character; -- Give illegal character error, Scan_Ptr points to character. On return, -- Scan_Ptr is bumped past the illegal character. procedure Initialize_Checksum; pragma Inline (Initialize_Checksum); -- Initialize checksum value function Is_Keyword_Name (N : Name_Id) return Boolean; -- Test to see if the name N is one of the (reserved) keyword names. procedure Scan_Wide (S : Source_Buffer_Ptr; P : in out Source_Ptr; C : out Char_Code; Err : out Boolean); -- On entry S (P) points to the first character in the source text for -- a wide character (i.e. to an ESC character, a left bracket, or an -- upper half character, depending on the representation method). A -- single wide character is scanned. If no error is found, the value -- stored in C is the code for this wide character, P is updated past -- the sequence and Err is set to False. If an error is found, then -- P points to the improper character, C is undefined, and Err is -- set to True. function Set_Start_Column return Column_Number; -- This routine is called with Scan_Ptr pointing to the first character -- of a line. On exit, Scan_Ptr is advanced to the first non-blank -- character of this line (or to the terminating format effector if the -- line contains no non-blank characters), and the returned result is the -- column number of this non-blank character (zero origin), which is the -- value to be stored in the Start_Column scan variable. procedure Skip_Line_Terminators (P : in out Source_Ptr; Physical : out Boolean); -- On entry, P points to a line terminator that has been encountered, -- which is one of FF,LF,VT,CR or a wide character sequence whose value is -- in category Separator,Line or Separator,Paragraph. P points just past -- the character that was scanned. The purpose of this routine is to -- distinguish physical and logical line endings. A physical line ending -- is one of: -- -- CR on its own (MAC System 7) -- LF on its own (Unix and unix-like systems) -- CR/LF (DOS, Windows) -- Wide character in Separator,Line or Separator,Paragraph category -- -- Note: we no longer recognize LF/CR (which we did in some earlier -- versions of GNAT. The reason for this is that this sequence is not -- used and recognizing it generated confusion. For example given the -- sequence LF/CR/LF we were interpreting that as (LF/CR) ending the -- first line and a blank line ending with CR following, but it is -- clearly better to interpret this as LF, with a blank line terminated -- by CR/LF, given that LF and CR/LF are both in common use, but no -- system we know of uses LF/CR. -- -- A logical line ending (that is not a physical line ending) is one of: -- -- VT on its own -- FF on its own -- -- On return, P is bumped past the line ending sequence (one of the above -- seven possibilities). Physical is set to True to indicate that a -- physical end of line was encountered, in which case this routine also -- makes sure that the lines table for the current source file has an -- appropriate entry for the start of the new physical line. procedure Start_String; -- Initialize String_Buffer to empty procedure Store_String_Char (Code : Char_Code); -- Put one Char_Code in the String_Buffer function Token_Value (N : Name_Id) return Token_Type; -- Return the content of the String_Buffer as a Name_Id. May only be -- called if N is a keyword name. ------------------------- -- Accumulate_Checksum -- ------------------------- procedure Accumulate_Checksum (C : Character) is begin System.CRC32.Update (System.CRC32.CRC32 (Checksum), C); end Accumulate_Checksum; procedure Accumulate_Checksum (C : Char_Code) is begin if C > 16#FFFF# then Accumulate_Checksum (Character'Val (C / 2 ** 24)); Accumulate_Checksum (Character'Val ((C / 2 ** 16) mod 256)); Accumulate_Checksum (Character'Val ((C / 256) mod 256)); else Accumulate_Checksum (Character'Val (C / 256)); end if; Accumulate_Checksum (Character'Val (C mod 256)); end Accumulate_Checksum; ------------------------------- -- Accumulate_Token_Checksum -- ------------------------------- procedure Accumulate_Token_Checksum is begin System.CRC32.Update (System.CRC32.CRC32 (Checksum), Character'Val (Token_Type'Pos (Token))); end Accumulate_Token_Checksum; ---------------------------------------- -- Accumulate_Token_Checksum_GNAT_6_3 -- ---------------------------------------- procedure Accumulate_Token_Checksum_GNAT_6_3 is begin -- Individual values of Token_Type are used, instead of subranges, so -- that additions or suppressions of enumerated values in type -- Token_Type are detected by the compiler. case Token is when Tok_Integer_Literal | Tok_Real_Literal | Tok_String_Literal | Tok_Char_Literal | Tok_Operator_Symbol | Tok_Identifier | Tok_Double_Asterisk | Tok_Ampersand | Tok_Minus | Tok_Plus | Tok_Asterisk | Tok_Mod | Tok_Rem | Tok_Slash | Tok_New | Tok_Abs | Tok_Others | Tok_Null | Tok_Dot | Tok_Apostrophe | Tok_Left_Paren | Tok_Delta | Tok_Digits | Tok_Range | Tok_Right_Paren | Tok_Comma | Tok_And | Tok_Or | Tok_Xor | Tok_Less | Tok_Equal | Tok_Greater | Tok_Not_Equal | Tok_Greater_Equal | Tok_Less_Equal | Tok_In | Tok_Not | Tok_Box | Tok_Colon_Equal | Tok_Colon | Tok_Greater_Greater | Tok_Abstract | Tok_Access | Tok_Aliased | Tok_All | Tok_Array | Tok_At | Tok_Body | Tok_Constant | Tok_Do | Tok_Is | Tok_Interface | Tok_Limited | Tok_Of | Tok_Out | Tok_Record | Tok_Renames | Tok_Reverse => System.CRC32.Update (System.CRC32.CRC32 (Checksum), Character'Val (Token_Type'Pos (Token))); when Tok_Some => System.CRC32.Update (System.CRC32.CRC32 (Checksum), Character'Val (Token_Type'Pos (Tok_Identifier))); when Tok_Tagged | Tok_Then | Tok_Less_Less | Tok_Abort | Tok_Accept | Tok_Case | Tok_Delay | Tok_Else | Tok_Elsif | Tok_End | Tok_Exception | Tok_Exit | Tok_Goto | Tok_If | Tok_Pragma | Tok_Raise | Tok_Requeue | Tok_Return | Tok_Select | Tok_Terminate | Tok_Until | Tok_When | Tok_Begin | Tok_Declare | Tok_For | Tok_Loop | Tok_While | Tok_Entry | Tok_Protected | Tok_Task | Tok_Type | Tok_Subtype | Tok_Overriding | Tok_Synchronized | Tok_Use | Tok_Function | Tok_Generic | Tok_Package | Tok_Procedure | Tok_Private | Tok_With | Tok_Separate | Tok_EOF | Tok_Semicolon | Tok_Arrow | Tok_Vertical_Bar | Tok_Dot_Dot | Tok_Project | Tok_Extends | Tok_External | Tok_External_As_List | Tok_Comment | Tok_End_Of_Line | Tok_Special | Tok_SPARK_Hide | No_Token => System.CRC32.Update (System.CRC32.CRC32 (Checksum), Character'Val (Token_Type'Pos (Token_Type'Pred (Token)))); end case; end Accumulate_Token_Checksum_GNAT_6_3; ----------------------------------------- -- Accumulate_Token_Checksum_GNAT_5_03 -- ----------------------------------------- procedure Accumulate_Token_Checksum_GNAT_5_03 is begin -- Individual values of Token_Type are used, instead of subranges, so -- that additions or suppressions of enumerated values in type -- Token_Type are detected by the compiler. case Token is when Tok_Integer_Literal | Tok_Real_Literal | Tok_String_Literal | Tok_Char_Literal | Tok_Operator_Symbol | Tok_Identifier | Tok_Double_Asterisk | Tok_Ampersand | Tok_Minus | Tok_Plus | Tok_Asterisk | Tok_Mod | Tok_Rem | Tok_Slash | Tok_New | Tok_Abs | Tok_Others | Tok_Null | Tok_Dot | Tok_Apostrophe | Tok_Left_Paren | Tok_Delta | Tok_Digits | Tok_Range | Tok_Right_Paren | Tok_Comma | Tok_And | Tok_Or | Tok_Xor | Tok_Less | Tok_Equal | Tok_Greater | Tok_Not_Equal | Tok_Greater_Equal | Tok_Less_Equal | Tok_In | Tok_Not | Tok_Box | Tok_Colon_Equal | Tok_Colon | Tok_Greater_Greater | Tok_Abstract | Tok_Access | Tok_Aliased | Tok_All | Tok_Array | Tok_At | Tok_Body | Tok_Constant | Tok_Do | Tok_Is => System.CRC32.Update (System.CRC32.CRC32 (Checksum), Character'Val (Token_Type'Pos (Token))); when Tok_Interface | Tok_Some | Tok_Overriding | Tok_Synchronized => System.CRC32.Update (System.CRC32.CRC32 (Checksum), Character'Val (Token_Type'Pos (Tok_Identifier))); when Tok_Limited | Tok_Of | Tok_Out | Tok_Record | Tok_Renames | Tok_Reverse => System.CRC32.Update (System.CRC32.CRC32 (Checksum), Character'Val (Token_Type'Pos (Token) - 1)); when Tok_Tagged | Tok_Then | Tok_Less_Less | Tok_Abort | Tok_Accept | Tok_Case | Tok_Delay | Tok_Else | Tok_Elsif | Tok_End | Tok_Exception | Tok_Exit | Tok_Goto | Tok_If | Tok_Pragma | Tok_Raise | Tok_Requeue | Tok_Return | Tok_Select | Tok_Terminate | Tok_Until | Tok_When | Tok_Begin | Tok_Declare | Tok_For | Tok_Loop | Tok_While | Tok_Entry | Tok_Protected | Tok_Task | Tok_Type | Tok_Subtype => System.CRC32.Update (System.CRC32.CRC32 (Checksum), Character'Val (Token_Type'Pos (Token) - 2)); when Tok_Use | Tok_Function | Tok_Generic | Tok_Package | Tok_Procedure | Tok_Private | Tok_With | Tok_Separate | Tok_EOF | Tok_Semicolon | Tok_Arrow | Tok_Vertical_Bar | Tok_Dot_Dot | Tok_Project | Tok_Extends | Tok_External | Tok_External_As_List | Tok_Comment | Tok_End_Of_Line | Tok_Special | Tok_SPARK_Hide | No_Token => System.CRC32.Update (System.CRC32.CRC32 (Checksum), Character'Val (Token_Type'Pos (Token) - 4)); end case; end Accumulate_Token_Checksum_GNAT_5_03; ---------------- -- End_String -- ---------------- function End_String return Name_Id is Ellipsis : constant String := " ..."; begin Name_Len := String_Last; for J in 1 .. String_Last loop Name_Buffer (J) := Character'Val (String_Buffer (J) mod 255); end loop; if String_Last = String_Buffer'Last and then String_Buffer_Overflow then -- Add ellipses at the end of string literal in case of String_Buffer -- overflow. Add_Str_To_Name_Buffer (Ellipsis); end if; return Name_Find; end End_String; ----------------------------- -- Error_Illegal_Character -- ----------------------------- procedure Error_Illegal_Character is begin Error_Msg ("illegal character", Scan_Ptr); Scan_Ptr := Scan_Ptr + 1; end Error_Illegal_Character; ------------------------- -- Initialize_Checksum -- ------------------------- procedure Initialize_Checksum is begin System.CRC32.Initialize (System.CRC32.CRC32 (Checksum)); end Initialize_Checksum; ------------------------ -- Initialize_Scanner -- ------------------------ procedure Initialize_Scanner (Index : Source_File_Index; Lang : Language) is begin Language_For_Scanner := Lang; -- Initialize scan control variables Current_Source_File := Index; Source := Source_Text (Current_Source_File); Scan_Ptr := Source_First (Current_Source_File); Token := No_Token; Token_Ptr := Scan_Ptr; Current_Line_Start := Scan_Ptr; Token_Node := Empty_Node; Token_Name := No_Name; Start_Column := Set_Start_Column; First_Non_Blank_Location := Scan_Ptr; Upper_Half_Encoding := False; Check_For_BOM; Initialize_Checksum; end Initialize_Scanner; --------------------- -- Is_Keyword_Name -- --------------------- function Is_Keyword_Name (N : Name_Id) return Boolean is begin case Language_For_Scanner is when Ada => return N in Reserved_Ada_95 | Reserved_Ada_Other; when Project => return N in Reserved_Ada_Project; end case; end Is_Keyword_Name; ------------------------------ -- Reset_Special_Characters -- ------------------------------ procedure Reset_Special_Characters is begin Special_Characters := (others => False); end Reset_Special_Characters; ---------- -- Scan -- ---------- procedure Scan is Start_Of_Comment : Source_Ptr; -- Record start of comment position Underline_Found : Boolean; -- During scanning of an identifier, set to True if last character -- scanned was an underline or other punctuation character. This -- is used to flag the error of two underlines/punctuations in a -- row or ending an identifier with a underline/punctuation. Here -- punctuation means any UTF_32 character in the Unicode category -- Punctuation,Connector. Wptr : Source_Ptr; -- Used to remember start of last wide character scanned function Double_Char_Token (C : Character) return Boolean; -- This function is used for double character tokens like := or <>. It -- checks if the character following Source (Scan_Ptr) is C, and if so -- bumps Scan_Ptr past the pair of characters and returns True. A space -- between the two characters is also recognized with an appropriate -- error message being issued. If C is not present, False is returned. -- Note that Double_Char_Token can only be used for tokens defined in -- the Ada syntax (it's use for error cases like && is not appropriate -- since we do not want a junk message for a case like &-space-&). procedure Nlit; -- This is the procedure for scanning out numeric literals. On entry, -- Scan_Ptr points to the digit that starts the numeric literal (the -- checksum for this character has not been accumulated yet). On return -- Scan_Ptr points past the last character of the numeric literal, Token -- and Token_Node are set appropriately, and the checksum is updated. procedure Slit; -- This is the procedure for scanning out string literals. On entry, -- Scan_Ptr points to the opening string quote (the checksum for this -- character has not been accumulated yet). On return Scan_Ptr points -- past the closing quote of the string literal, Token and Token_Node -- are set appropriately, and the checksum is updated. procedure Skip_Other_Format_Characters; -- Skips past any "other format" category characters at the current -- cursor location (does not skip past spaces or any other characters). function Start_Of_Wide_Character return Boolean; -- Returns True if the scan pointer is pointing to the start of a wide -- character sequence, does not modify the scan pointer in any case. ----------------------- -- Double_Char_Token -- ----------------------- function Double_Char_Token (C : Character) return Boolean is begin if Source (Scan_Ptr + 1) = C then Accumulate_Checksum (C); Scan_Ptr := Scan_Ptr + 2; return True; elsif Source (Scan_Ptr + 1) = ' ' and then Source (Scan_Ptr + 2) = C then Scan_Ptr := Scan_Ptr + 3; return True; else return False; end if; end Double_Char_Token; ---------- -- Nlit -- ---------- procedure Nlit is C : Character; -- Current source program character Base_Char : Character; -- Either # or : (character at start of based number) Base : Int; -- Value of base Int_Value : Int; -- Value of integer scanned by Scan_Integer Num_Value : Int; -- Value of integer in numeric value being scanned Scale : Int; -- Scale value for real literal Exponent_Is_Negative : Boolean; -- Set true for negative exponent Extended_Digit_Value : Int; -- Extended digit value Point_Scanned : Boolean; -- Flag for decimal point scanned in numeric literal ----------------------- -- Local Subprograms -- ----------------------- procedure Scan_Integer; -- Scan integer literal. On entry, Scan_Ptr points to a digit, on -- exit Scan_Ptr points past the last character of the integer. -- -- For each digit encountered, Int_Value is multiplied by 10, and -- the value of the digit added to the result. In addition, the value -- in Scale is decremented by one for each actual digit scanned. Int_Max : constant Int := 10_000; -- Arbitrary number to limit the value of any integer, so as to not -- overflow. function Max_Int (N : Int) return Int; pragma Inline (Max_Int); -- Return Int_Max if N is greater ------------------ -- Scan_Integer -- ------------------ procedure Scan_Integer is C : Character; -- Next character scanned begin C := Source (Scan_Ptr); -- Loop through digits (allowing underlines) loop Accumulate_Checksum (C); Int_Value := Max_Int (Int_Value * 10 + (Character'Pos (C) - Character'Pos ('0'))); Scan_Ptr := Scan_Ptr + 1; Scale := Scale - 1; C := Source (Scan_Ptr); -- Case of underline encountered if C = '_' then -- We do not accumulate the '_' in the checksum, so that -- 1_234 is equivalent to 1234, and does not trigger -- compilation for "minimal recompilation" (gnatmake -m). loop Scan_Ptr := Scan_Ptr + 1; C := Source (Scan_Ptr); exit when C /= '_'; end loop; if C not in '0' .. '9' then exit; end if; else exit when C not in '0' .. '9'; end if; end loop; end Scan_Integer; ------------- -- Max_Int -- ------------- function Max_Int (N : Int) return Int is begin return Int'Min (Int_Max, N); end Max_Int; -- Start of Processing for Nlit begin Base := 10; Int_Value := 0; Scale := 0; Scan_Integer; Point_Scanned := False; Num_Value := Int_Value; -- Various possibilities now for continuing the literal are period, -- E/e (for exponent), or :/# (for based literal). Scale := 0; C := Source (Scan_Ptr); if C = '.' then -- Scan out point, but do not scan past .. which is a range -- sequence, and must not be eaten up scanning a numeric literal. while C = '.' and then Source (Scan_Ptr + 1) /= '.' loop Accumulate_Checksum ('.'); Point_Scanned := True; Scan_Ptr := Scan_Ptr + 1; C := Source (Scan_Ptr); if C in '0' .. '9' then Scan_Integer; Num_Value := Int_Value; end if; end loop; -- Based literal case. The base is the value we already scanned. -- In the case of colon, we insist that the following character -- is indeed an extended digit or a period. This catches a number -- of common errors, as well as catching the well known tricky -- bug otherwise arising from "x : integer range 1 .. 10:= 6;" elsif C = '#' or else (C = ':' and then (Source (Scan_Ptr + 1) = '.' or else Source (Scan_Ptr + 1) in '0' .. '9' or else Source (Scan_Ptr + 1) in 'A' .. 'Z' or else Source (Scan_Ptr + 1) in 'a' .. 'z')) then Accumulate_Checksum (C); Base_Char := C; Base := Int_Value; if Base < 2 or else Base > 16 then Base := 16; end if; Scan_Ptr := Scan_Ptr + 1; -- Scan out extended integer [. integer] C := Source (Scan_Ptr); Int_Value := 0; Scale := 0; loop if C in '0' .. '9' then Accumulate_Checksum (C); Extended_Digit_Value := Int'(Character'Pos (C)) - Int'(Character'Pos ('0')); elsif C in 'A' .. 'F' then Accumulate_Checksum (Character'Val (Character'Pos (C) + 32)); Extended_Digit_Value := Int'(Character'Pos (C)) - Int'(Character'Pos ('A')) + 10; elsif C in 'a' .. 'f' then Accumulate_Checksum (C); Extended_Digit_Value := Int'(Character'Pos (C)) - Int'(Character'Pos ('a')) + 10; else exit; end if; Int_Value := Max_Int (Int_Value * Base + Extended_Digit_Value); Scale := Scale - 1; Scan_Ptr := Scan_Ptr + 1; C := Source (Scan_Ptr); if C = '_' then loop Accumulate_Checksum ('_'); Scan_Ptr := Scan_Ptr + 1; C := Source (Scan_Ptr); exit when C /= '_'; end loop; elsif C = '.' then Accumulate_Checksum ('.'); Scan_Ptr := Scan_Ptr + 1; C := Source (Scan_Ptr); Point_Scanned := True; Scale := 0; elsif C = Base_Char then Accumulate_Checksum (C); Scan_Ptr := Scan_Ptr + 1; exit; elsif C = '#' or else C = ':' then Scan_Ptr := Scan_Ptr + 1; exit; elsif not Identifier_Char (C) then exit; end if; end loop; Num_Value := Int_Value; end if; -- Scan out exponent if not Point_Scanned then Scale := 0; end if; if Source (Scan_Ptr) = 'e' or else Source (Scan_Ptr) = 'E' then Accumulate_Checksum ('e'); Scan_Ptr := Scan_Ptr + 1; Exponent_Is_Negative := False; if Source (Scan_Ptr) = '+' then Accumulate_Checksum ('+'); Scan_Ptr := Scan_Ptr + 1; elsif Source (Scan_Ptr) = '-' then Accumulate_Checksum ('-'); if Point_Scanned then Exponent_Is_Negative := True; end if; Scan_Ptr := Scan_Ptr + 1; end if; Int_Value := 0; if Source (Scan_Ptr) in '0' .. '9' then Scan_Integer; end if; if Exponent_Is_Negative then Scale := Scale - Int_Value; else Scale := Scale + Int_Value; end if; end if; -- Case of real literal to be returned if Point_Scanned then Token := Tok_Real_Literal; -- Case of integer literal to be returned else Token := Tok_Integer_Literal; if Scale = 0 then Int_Literal_Value := Num_Value; -- Avoid doing possibly expensive calculations in cases like -- parsing 163E800_000# when semantics will not be done anyway. -- This is especially useful when parsing garbled input. else Int_Literal_Value := 0; end if; end if; if Checksum_Accumulate_Token_Checksum then Accumulate_Token_Checksum; end if; return; end Nlit; ---------- -- Slit -- ---------- procedure Slit is Delimiter : Character; -- Delimiter (first character of string) C : Character; -- Current source program character Code : Char_Code; -- Current character code value Err : Boolean; -- Error flag for Scan_Wide call -- Start of processing for Slit begin -- On entry, Scan_Ptr points to the opening character of the string -- which is either a percent, double quote, or apostrophe (single -- quote). The latter case is an error detected by the character -- literal circuit. Delimiter := Source (Scan_Ptr); Accumulate_Checksum (Delimiter); Start_String; Scan_Ptr := Scan_Ptr + 1; -- Loop to scan out characters of string literal loop C := Source (Scan_Ptr); if C = Delimiter then Accumulate_Checksum (C); Scan_Ptr := Scan_Ptr + 1; exit when Source (Scan_Ptr) /= Delimiter; Code := Get_Char_Code (C); Accumulate_Checksum (C); Scan_Ptr := Scan_Ptr + 1; else if C = '"' and then Delimiter = '%' then Code := Get_Char_Code (C); Scan_Ptr := Scan_Ptr + 1; elsif Start_Of_Wide_Character then Wptr := Scan_Ptr; Scan_Wide (Source, Scan_Ptr, Code, Err); if Err then Code := Get_Char_Code (' '); end if; Accumulate_Checksum (Code); else Accumulate_Checksum (C); if C not in Graphic_Character then if C in Line_Terminator then Error_Msg ("missing string quote", Scan_Ptr); exit; elsif C not in Upper_Half_Character then Error_Msg ("invalid character in string", Scan_Ptr); end if; end if; Code := Get_Char_Code (C); Scan_Ptr := Scan_Ptr + 1; end if; end if; Store_String_Char (Code); end loop; if Language_For_Scanner = Project then Token_Name := End_String; end if; Token := Tok_String_Literal; end Slit; ---------------------------------- -- Skip_Other_Format_Characters -- ---------------------------------- procedure Skip_Other_Format_Characters is P : Source_Ptr; Code : Char_Code; Err : Boolean; begin while Start_Of_Wide_Character loop P := Scan_Ptr; Scan_Wide (Source, Scan_Ptr, Code, Err); if not Is_UTF_32_Other (UTF_32 (Code)) then Scan_Ptr := P; return; end if; end loop; end Skip_Other_Format_Characters; ----------------------------- -- Start_Of_Wide_Character -- ----------------------------- function Start_Of_Wide_Character return Boolean is C : constant Character := Source (Scan_Ptr); use ASCII; begin -- ESC encoding method with ESC present if C = ESC and then Wide_Character_Encoding_Method in WC_ESC_Encoding_Method then return True; -- Upper half character with upper half encoding elsif C in Upper_Half_Character and then Upper_Half_Encoding then return True; -- Brackets encoding elsif C = '[' and then Source (Scan_Ptr + 1) = '"' and then Identifier_Char (Source (Scan_Ptr + 2)) then return True; -- Not the start of a wide character else return False; end if; end Start_Of_Wide_Character; use ASCII; -- Start of processing for Scan begin Prev_Token := Token; Prev_Token_Ptr := Token_Ptr; Token_Name := Error_Name; -- The following loop runs more than once only if a format effector -- (tab, vertical tab, form feed, line feed, carriage return) is -- encountered and skipped, or some error situation, such as an -- illegal character, is encountered. <> loop -- Skip past blanks, loop is opened up for speed while Source (Scan_Ptr) = ' ' loop if Source (Scan_Ptr + 1) /= ' ' then Scan_Ptr := Scan_Ptr + 1; exit; end if; if Source (Scan_Ptr + 2) /= ' ' then Scan_Ptr := Scan_Ptr + 2; exit; end if; if Source (Scan_Ptr + 3) /= ' ' then Scan_Ptr := Scan_Ptr + 3; exit; end if; if Source (Scan_Ptr + 4) /= ' ' then Scan_Ptr := Scan_Ptr + 4; exit; end if; if Source (Scan_Ptr + 5) /= ' ' then Scan_Ptr := Scan_Ptr + 5; exit; end if; if Source (Scan_Ptr + 6) /= ' ' then Scan_Ptr := Scan_Ptr + 6; exit; end if; if Source (Scan_Ptr + 7) /= ' ' then Scan_Ptr := Scan_Ptr + 7; exit; end if; Scan_Ptr := Scan_Ptr + 8; end loop; -- We are now at a non-blank character, which is the first character -- of the token we will scan, and hence the value of Token_Ptr. Token_Ptr := Scan_Ptr; -- Here begins the main case statement which transfers control on the -- basis of the non-blank character we have encountered. case Source (Scan_Ptr) is -- Line terminator characters when ASCII.CR | ASCII.LF | ASCII.FF | ASCII.VT => goto Scan_Line_Terminator; -- Horizontal tab, just skip past it when ASCII.HT => Scan_Ptr := Scan_Ptr + 1; -- End of file character, treated as an end of file only if it is -- the last character in the buffer, otherwise it is ignored. when EOF => if Scan_Ptr = Source_Last (Current_Source_File) then Token := Tok_EOF; return; else Scan_Ptr := Scan_Ptr + 1; end if; -- Ampersand when '&' => Accumulate_Checksum ('&'); if Source (Scan_Ptr + 1) = '&' then Scan_Ptr := Scan_Ptr + 2; Token := Tok_And; return; else Scan_Ptr := Scan_Ptr + 1; Token := Tok_Ampersand; return; end if; -- Asterisk (can be multiplication operator or double asterisk which -- is the exponentiation compound delimiter). when '*' => Accumulate_Checksum ('*'); if Source (Scan_Ptr + 1) = '*' then Accumulate_Checksum ('*'); Scan_Ptr := Scan_Ptr + 2; Token := Tok_Double_Asterisk; return; else Scan_Ptr := Scan_Ptr + 1; Token := Tok_Asterisk; return; end if; -- Colon, which can either be an isolated colon, or part of an -- assignment compound delimiter. when ':' => Accumulate_Checksum (':'); if Double_Char_Token ('=') then Token := Tok_Colon_Equal; return; elsif Source (Scan_Ptr + 1) = '-' and then Source (Scan_Ptr + 2) /= '-' then Token := Tok_Colon_Equal; Scan_Ptr := Scan_Ptr + 2; return; else Scan_Ptr := Scan_Ptr + 1; Token := Tok_Colon; return; end if; -- Left parenthesis when '(' => Accumulate_Checksum ('('); Scan_Ptr := Scan_Ptr + 1; Token := Tok_Left_Paren; return; -- Left bracket when '[' => -- Here was code to support wide characters square brackets -- encoding. It was checking that next char is '"' and conditional -- jumping to Scan_Wide_Character. Now it is removed and we -- support square brackets only for Ada 2022 syntax because it is -- too tricky to detect whether the source is going to be compiled -- with new syntax support. Scan_Ptr := Scan_Ptr + 1; Token := Tok_Left_Paren; return; -- Left brace when '{' => Scan_Ptr := Scan_Ptr + 1; Token := Tok_Left_Paren; return; -- Comma when ',' => Accumulate_Checksum (','); Scan_Ptr := Scan_Ptr + 1; Token := Tok_Comma; return; -- Dot, which is either an isolated period, or part of a double dot -- compound delimiter sequence. We also check for the case of a -- digit following the period, to give a better error message. when '.' => Accumulate_Checksum ('.'); if Double_Char_Token ('.') then Token := Tok_Dot_Dot; return; elsif Source (Scan_Ptr + 1) in '0' .. '9' then Scan_Ptr := Scan_Ptr + 1; else Scan_Ptr := Scan_Ptr + 1; Token := Tok_Dot; return; end if; -- Equal, which can either be an equality operator, or part of the -- arrow (=>) compound delimiter. when '=' => Accumulate_Checksum ('='); if Double_Char_Token ('>') then Token := Tok_Arrow; return; elsif Source (Scan_Ptr + 1) = '=' then Scan_Ptr := Scan_Ptr + 1; end if; Scan_Ptr := Scan_Ptr + 1; Token := Tok_Equal; return; -- Greater than, which can be a greater than operator, greater than -- or equal operator, or first character of a right label bracket. when '>' => Accumulate_Checksum ('>'); if Double_Char_Token ('=') then Token := Tok_Greater_Equal; return; elsif Double_Char_Token ('>') then Token := Tok_Greater_Greater; return; else Scan_Ptr := Scan_Ptr + 1; Token := Tok_Greater; return; end if; -- Less than, which can be a less than operator, less than or equal -- operator, or the first character of a left label bracket, or the -- first character of a box (<>) compound delimiter. when '<' => Accumulate_Checksum ('<'); if Double_Char_Token ('=') then Token := Tok_Less_Equal; return; elsif Double_Char_Token ('>') then Token := Tok_Box; return; elsif Double_Char_Token ('<') then Token := Tok_Less_Less; return; else Scan_Ptr := Scan_Ptr + 1; Token := Tok_Less; return; end if; -- Minus, which is either a subtraction operator, or the first -- character of double minus starting a comment when '-' => Minus_Case : begin if Source (Scan_Ptr + 1) = '>' then Scan_Ptr := Scan_Ptr + 2; Token := Tok_Arrow; return; elsif Source (Scan_Ptr + 1) /= '-' then Accumulate_Checksum ('-'); Scan_Ptr := Scan_Ptr + 1; Token := Tok_Minus; return; -- Comment else -- Source (Scan_Ptr + 1) = '-' then Scan_Ptr := Scan_Ptr + 2; Start_Of_Comment := Scan_Ptr; -- Loop to scan comment (this loop runs more than once only if -- a horizontal tab or other non-graphic character is scanned) loop -- Scan to non graphic character (opened up for speed) -- Note that we just eat left brackets, which means that -- bracket notation cannot be used for end of line -- characters in comments. This seems a reasonable choice, -- since no one would ever use brackets notation in a real -- program in this situation, and if we allow brackets -- notation, we forbid some valid comments which contain a -- brackets sequence that happens to match an end of line -- character. loop exit when Source (Scan_Ptr) not in Graphic_Character; Scan_Ptr := Scan_Ptr + 1; exit when Source (Scan_Ptr) not in Graphic_Character; Scan_Ptr := Scan_Ptr + 1; exit when Source (Scan_Ptr) not in Graphic_Character; Scan_Ptr := Scan_Ptr + 1; exit when Source (Scan_Ptr) not in Graphic_Character; Scan_Ptr := Scan_Ptr + 1; exit when Source (Scan_Ptr) not in Graphic_Character; Scan_Ptr := Scan_Ptr + 1; end loop; -- Keep going if horizontal tab if Source (Scan_Ptr) = HT then Scan_Ptr := Scan_Ptr + 1; -- Terminate scan of comment if line terminator elsif Source (Scan_Ptr) in Line_Terminator then exit; -- Terminate scan of comment if end of file encountered -- (embedded EOF character or real last character in file) elsif Source (Scan_Ptr) = EOF then exit; -- If we have a wide character, we have to scan it out, -- because it might be a legitimate line terminator elsif Start_Of_Wide_Character then declare Wptr : constant Source_Ptr := Scan_Ptr; Code : Char_Code; Err : Boolean; begin Scan_Wide (Source, Scan_Ptr, Code, Err); -- If not well formed wide character, then just skip -- past it and ignore it. if Err then Scan_Ptr := Wptr + 1; -- If UTF_32 terminator, terminate comment scan elsif Is_UTF_32_Line_Terminator (UTF_32 (Code)) then Scan_Ptr := Wptr; exit; end if; end; -- Keep going if character in 80-FF range, or is ESC. These -- characters are allowed in comments by RM-2.1(1), 2.7(2). -- They are allowed even in Ada 83 mode according to the -- approved AI. ESC was added to the AI in June 93. elsif Source (Scan_Ptr) in Upper_Half_Character | ASCII.ESC | ASCII.DEL then Scan_Ptr := Scan_Ptr + 1; else Error_Illegal_Character; end if; end loop; -- Note that, except when comments are tokens, we do NOT -- execute a return here, instead we fall through to reexecute -- the scan loop to look for a token. if Comment_Is_Token then Name_Len := Integer (Scan_Ptr - Start_Of_Comment); Name_Buffer (1 .. Name_Len) := String (Source (Start_Of_Comment .. Scan_Ptr - 1)); Comment_Id := Name_Find; Token := Tok_Comment; return; end if; end if; end Minus_Case; -- Double quote or percent starting a string literal when '"' | '%' => Slit; Post_Scan; return; -- Apostrophe. This can either be the start of a character literal, -- or an isolated apostrophe used in a qualified expression or an -- attribute. We treat it as a character literal if it does not -- follow a right parenthesis, identifier, the keyword ALL or -- a literal. This means that we correctly treat constructs like: -- A := CHARACTER'('A'); -- Note that RM-2.2(7) does not require a separator between -- "CHARACTER" and "'" in the above. when ''' => Char_Literal_Case : declare Code : Char_Code; Err : Boolean; begin Accumulate_Checksum ('''); Scan_Ptr := Scan_Ptr + 1; -- Here is where we make the test to distinguish the cases. Treat -- as apostrophe if previous token is an identifier, right paren -- or the reserved word "all" (latter case as in A.all'Address) -- (or the reserved word "project" in project files). Also treat -- it as apostrophe after a literal (this catches some legitimate -- cases, like A."abs"'Address, and also gives better error -- behavior for impossible cases like 123'xxx). if Prev_Token = Tok_Identifier or else Prev_Token = Tok_Right_Paren or else Prev_Token = Tok_All or else Prev_Token = Tok_Project or else Prev_Token in Token_Class_Literal then Token := Tok_Apostrophe; return; -- Otherwise the apostrophe starts a character literal else -- Case of wide character literal if Start_Of_Wide_Character then Wptr := Scan_Ptr; Scan_Wide (Source, Scan_Ptr, Code, Err); Accumulate_Checksum (Code); if Err then Code := Character'Pos (' '); end if; if Source (Scan_Ptr) = ''' then Scan_Ptr := Scan_Ptr + 1; end if; -- If we do not find a closing quote in the expected place then -- assume that we have a misguided attempt at a string literal. -- However, if previous token is RANGE, then we return an -- apostrophe instead since this gives better error recovery elsif Source (Scan_Ptr + 1) /= ''' then if Prev_Token = Tok_Range then Token := Tok_Apostrophe; return; else Scan_Ptr := Scan_Ptr - 1; Error_Msg ("strings are delimited by double quote character", Scan_Ptr); Slit; Post_Scan; return; end if; -- Otherwise we have a (non-wide) character literal else Accumulate_Checksum (Source (Scan_Ptr)); Code := Get_Char_Code (Source (Scan_Ptr)); Scan_Ptr := Scan_Ptr + 2; end if; -- Fall through here with Scan_Ptr updated past the closing -- quote, and Code set to the Char_Code value for the literal Accumulate_Checksum ('''); Token := Tok_Char_Literal; Character_Code := Code; Post_Scan; return; end if; end Char_Literal_Case; -- Right parenthesis when ')' => Accumulate_Checksum (')'); Scan_Ptr := Scan_Ptr + 1; Token := Tok_Right_Paren; return; -- Right bracket or right brace, treated as right paren when ']' | '}' => Scan_Ptr := Scan_Ptr + 1; Token := Tok_Right_Paren; return; -- Slash (can be division operator or first character of not equal) when '/' => Accumulate_Checksum ('/'); if Double_Char_Token ('=') then Token := Tok_Not_Equal; return; else Scan_Ptr := Scan_Ptr + 1; Token := Tok_Slash; return; end if; -- Semicolon when ';' => Accumulate_Checksum (';'); Scan_Ptr := Scan_Ptr + 1; Token := Tok_Semicolon; return; -- Vertical bar when '|' => Vertical_Bar_Case : begin Accumulate_Checksum ('|'); -- Special check for || to give nice message if Source (Scan_Ptr + 1) = '|' then Scan_Ptr := Scan_Ptr + 2; Token := Tok_Or; return; else Scan_Ptr := Scan_Ptr + 1; Token := Tok_Vertical_Bar; Post_Scan; return; end if; end Vertical_Bar_Case; -- Exclamation, replacement character for vertical bar when '!' => Exclamation_Case : begin Accumulate_Checksum ('!'); if Source (Scan_Ptr + 1) = '=' then Scan_Ptr := Scan_Ptr + 2; Token := Tok_Not_Equal; return; else Scan_Ptr := Scan_Ptr + 1; Token := Tok_Vertical_Bar; Post_Scan; return; end if; end Exclamation_Case; -- Plus when '+' => Plus_Case : begin Accumulate_Checksum ('+'); Scan_Ptr := Scan_Ptr + 1; Token := Tok_Plus; return; end Plus_Case; -- Digits starting a numeric literal when '0' .. '9' => -- First a bit of a scan ahead to see if we have a case of an -- identifier starting with a digit (remembering exponent case). declare C : constant Character := Source (Scan_Ptr + 1); begin -- OK literal if digit followed by digit or underscore if C in '0' .. '9' or else C = '_' then null; -- OK literal if digit not followed by identifier char elsif not Identifier_Char (C) then null; -- OK literal if digit followed by e/E followed by digit/sign. -- We also allow underscore after the E, which is an error, but -- better handled by Nlit than deciding this is an identifier. elsif (C = 'e' or else C = 'E') and then (Source (Scan_Ptr + 2) in '0' .. '9' or else Source (Scan_Ptr + 2) = '+' or else Source (Scan_Ptr + 2) = '-' or else Source (Scan_Ptr + 2) = '_') then null; -- Here we have what really looks like an identifier that -- starts with a digit, so give error msg. else Name_Len := 1; Underline_Found := False; Name_Buffer (1) := Source (Scan_Ptr); Accumulate_Checksum (Name_Buffer (1)); Scan_Ptr := Scan_Ptr + 1; goto Scan_Identifier; end if; end; -- Here we have an OK integer literal Nlit; -- Check for proper delimiter, ignoring other format characters Skip_Other_Format_Characters; Post_Scan; return; -- Lower case letters when 'a' .. 'z' => Name_Len := 1; Underline_Found := False; Name_Buffer (1) := Source (Scan_Ptr); Accumulate_Checksum (Name_Buffer (1)); Scan_Ptr := Scan_Ptr + 1; goto Scan_Identifier; -- Upper case letters when 'A' .. 'Z' => Name_Len := 1; Underline_Found := False; Name_Buffer (1) := Character'Val (Character'Pos (Source (Scan_Ptr)) + 32); Accumulate_Checksum (Name_Buffer (1)); Scan_Ptr := Scan_Ptr + 1; goto Scan_Identifier; -- Underline character when '_' => if Special_Characters ('_') then Token_Ptr := Scan_Ptr; Scan_Ptr := Scan_Ptr + 1; Token := Tok_Special; Special_Character := '_'; return; end if; Name_Len := 1; Name_Buffer (1) := '_'; Scan_Ptr := Scan_Ptr + 1; Underline_Found := False; goto Scan_Identifier; -- Space (not possible, because we scanned past blanks) when ' ' => raise Program_Error; -- Characters in top half of ASCII 8-bit chart when Upper_Half_Character => -- Wide character case if Upper_Half_Encoding then goto Scan_Wide_Character; -- Otherwise we have Latin-1 character else -- Upper half characters may possibly be identifier letters -- but can never be digits, so Identifier_Char can be used to -- test for a valid start of identifier character. if Identifier_Char (Source (Scan_Ptr)) then Name_Len := 0; Underline_Found := False; goto Scan_Identifier; else Error_Illegal_Character; end if; end if; when ESC => -- ESC character, possible start of identifier if wide characters -- using ESC encoding are allowed in identifiers, which we can -- tell by looking at the Identifier_Char flag for ESC, which is -- only true if these conditions are met. In Ada 2005 mode, may -- also be valid UTF_32 space or line terminator character. if Identifier_Char (ESC) then Name_Len := 0; goto Scan_Wide_Character; end if; -- Invalid control characters when NUL | SOH | STX | ETX | EOT | ENQ | ACK | BEL | BS | ASCII.SO | SI | DLE | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN | EM | FS | GS | RS | US | DEL => Error_Illegal_Character; if Language_For_Scanner = Ada then Token := Tok_EOF; return; end if; -- Invalid graphic characters when '#' | '$' | '?' | '@' | '`' | '\' | '^' | '~' => -- If Set_Special_Character has been called for this character, -- set Scans.Special_Character and return a Special token. if Special_Characters (Source (Scan_Ptr)) then Token_Ptr := Scan_Ptr; Token := Tok_Special; Special_Character := Source (Scan_Ptr); Scan_Ptr := Scan_Ptr + 1; return; -- Check for something looking like a preprocessor directive elsif Source (Scan_Ptr) = '#' and then (Source (Scan_Ptr + 1 .. Scan_Ptr + 2) = "if" or else Source (Scan_Ptr + 1 .. Scan_Ptr + 5) = "elsif" or else Source (Scan_Ptr + 1 .. Scan_Ptr + 4) = "else" or else Source (Scan_Ptr + 1 .. Scan_Ptr + 3) = "end") then -- Skip to end of line loop if Source (Scan_Ptr) in Graphic_Character or else Source (Scan_Ptr) = HT then Scan_Ptr := Scan_Ptr + 1; -- Done if line terminator or EOF elsif Source (Scan_Ptr) in Line_Terminator or else Source (Scan_Ptr) = EOF then exit; -- If we have a wide character, we have to scan it out, -- because it might be a legitimate line terminator elsif Start_Of_Wide_Character then declare Wptr : constant Source_Ptr := Scan_Ptr; Code : Char_Code; Err : Boolean; begin Scan_Wide (Source, Scan_Ptr, Code, Err); -- If not well formed wide character, then just skip -- past it and ignore it. if Err then Scan_Ptr := Wptr + 1; -- If UTF_32 terminator, terminate comment scan elsif Is_UTF_32_Line_Terminator (UTF_32 (Code)) then Scan_Ptr := Wptr; exit; end if; end; -- Else keep going (don't worry about bad comment chars -- in this context, we just want to find the end of line. else Scan_Ptr := Scan_Ptr + 1; end if; end loop; elsif Source (Scan_Ptr) = '$' then Scan_Ptr := Scan_Ptr + 1; if Identifier_Char (Source (Scan_Ptr)) then goto Scan_Identifier; else Error_Illegal_Character; end if; elsif Source (Scan_Ptr) = '@' then Scan_Ptr := Scan_Ptr + 1; Accumulate_Checksum ('@'); else Error_Illegal_Character; end if; -- End switch on non-blank character end case; -- End loop past format effectors. The exit from this loop is by -- executing a return statement following completion of token scan -- (control never falls out of this loop to the code which follows) end loop; -- Wide_Character scanning routine. On entry we have encountered the -- initial character of a wide character sequence. <> declare Code : Char_Code; Cat : Category; Err : Boolean; begin Wptr := Scan_Ptr; Scan_Wide (Source, Scan_Ptr, Code, Err); -- If bad wide character, signal error and continue scan if Err then goto Scan_Next_Character; end if; Cat := Get_Category (UTF_32 (Code)); -- If OK letter, reset scan ptr and go scan identifier if Is_UTF_32_Letter (Cat) then Scan_Ptr := Wptr; Name_Len := 0; Underline_Found := False; goto Scan_Identifier; -- If OK wide space, ignore and keep scanning (we do not include -- any ignored spaces in checksum) elsif Is_UTF_32_Space (Cat) then goto Scan_Next_Character; -- If other format character, ignore and keep scanning (again we -- do not include in the checksum) (this is for AI-0079). elsif Is_UTF_32_Other (Cat) then goto Scan_Next_Character; -- If OK wide line terminator, terminate current line elsif Is_UTF_32_Line_Terminator (UTF_32 (Code)) then Scan_Ptr := Wptr; goto Scan_Line_Terminator; -- Punctuation is an error (at start of identifier) elsif Is_UTF_32_Punctuation (Cat) then Scan_Ptr := Wptr; Name_Len := 0; Underline_Found := False; goto Scan_Identifier; -- Mark character is an error (at start of identifier) elsif Is_UTF_32_Mark (Cat) then Scan_Ptr := Wptr; Name_Len := 0; Underline_Found := False; goto Scan_Identifier; -- Extended digit character is an error. Could be bad start of -- identifier or bad literal. Not worth doing too much to try to -- distinguish these cases, but we will do a little bit. elsif Is_UTF_32_Digit (Cat) then Scan_Ptr := Wptr; Name_Len := 0; Underline_Found := False; goto Scan_Identifier; -- All other wide characters are illegal here else goto Scan_Next_Character; end if; end; -- Routine to scan line terminator. On entry Scan_Ptr points to a -- character which is one of FF,LR,CR,VT, or one of the wide characters -- that is treated as a line terminator. <> if Scan_Ptr - Current_Line_Start > 32766 then Error_Msg ("this line is longer than 32766 characters", Current_Line_Start); raise Unrecoverable_Error; end if; -- Set Token_Ptr, if End_Of_Line is a token, for the case when it is -- a physical line. if End_Of_Line_Is_Token then Token_Ptr := Scan_Ptr; end if; declare Physical : Boolean; begin Skip_Line_Terminators (Scan_Ptr, Physical); -- If we are at start of physical line, update scan pointers to -- reflect the start of the new line. if Physical then Current_Line_Start := Scan_Ptr; Start_Column := Set_Start_Column; First_Non_Blank_Location := Scan_Ptr; -- If End_Of_Line is a token, we return it as it is a -- physical line. if End_Of_Line_Is_Token then Token := Tok_End_Of_Line; return; end if; end if; end; goto Scan_Next_Character; -- Identifier scanning routine. On entry, some initial characters of -- the identifier may have already been stored in Name_Buffer. If so, -- Name_Len has the number of characters stored, otherwise Name_Len is -- set to zero on entry. Underline_Found is also set False on entry. <> -- This loop scans as fast as possible past lower half letters and -- digits, which we expect to be the most common characters. loop if Source (Scan_Ptr) in 'a' .. 'z' or else Source (Scan_Ptr) in '0' .. '9' then Name_Buffer (Name_Len + 1) := Source (Scan_Ptr); Accumulate_Checksum (Source (Scan_Ptr)); elsif Source (Scan_Ptr) in 'A' .. 'Z' then Name_Buffer (Name_Len + 1) := Character'Val (Character'Pos (Source (Scan_Ptr)) + 32); Accumulate_Checksum (Name_Buffer (Name_Len + 1)); else exit; end if; Underline_Found := False; Scan_Ptr := Scan_Ptr + 1; Name_Len := Name_Len + 1; end loop; -- If we fall through, then we have encountered either an underline -- character, or an extended identifier character (i.e. one from the -- upper half), or a wide character, or an identifier terminator. The -- initial test speeds us up in the most common case where we have -- an identifier terminator. Note that ESC is an identifier character -- only if a wide character encoding method that uses ESC encoding -- is active, so if we find an ESC character we know that we have a -- wide character. if Identifier_Char (Source (Scan_Ptr)) or else (Source (Scan_Ptr) in Upper_Half_Character and then Upper_Half_Encoding) then -- Case of underline if Source (Scan_Ptr) = '_' then Accumulate_Checksum ('_'); if not Underline_Found then Underline_Found := True; Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := '_'; end if; Scan_Ptr := Scan_Ptr + 1; goto Scan_Identifier; -- Upper half character elsif Source (Scan_Ptr) in Upper_Half_Character and then not Upper_Half_Encoding then Accumulate_Checksum (Source (Scan_Ptr)); Store_Encoded_Character (Get_Char_Code (Fold_Lower (Source (Scan_Ptr)))); Scan_Ptr := Scan_Ptr + 1; Underline_Found := False; goto Scan_Identifier; -- Left bracket not followed by a quote terminates an identifier. -- This is an error, but we don't want to give a junk error msg -- about wide characters in this case. elsif Source (Scan_Ptr) = '[' and then Source (Scan_Ptr + 1) /= '"' then null; -- We know we have a wide character encoding here (the current -- character is either ESC, left bracket, or an upper half -- character depending on the encoding method). else -- Scan out the wide character and insert the appropriate -- encoding into the name table entry for the identifier. declare Code : Char_Code; Err : Boolean; Chr : Character; Cat : Category; begin Wptr := Scan_Ptr; Scan_Wide (Source, Scan_Ptr, Code, Err); -- If error, signal error if Err then null; -- If the character scanned is a normal identifier -- character, then we treat it that way. elsif In_Character_Range (Code) and then Identifier_Char (Get_Character (Code)) then Chr := Get_Character (Code); Accumulate_Checksum (Chr); Store_Encoded_Character (Get_Char_Code (Fold_Lower (Chr))); Underline_Found := False; -- Here if not a normal identifier character else Cat := Get_Category (UTF_32 (Code)); -- Wide character in Unicode category "Other, Format" -- is not accepted in an identifier. This is because it -- it is considered a security risk (AI-0091). -- However, it is OK for such a character to appear at -- the end of an identifier. if Is_UTF_32_Other (Cat) then if not Identifier_Char (Source (Scan_Ptr)) then goto Scan_Identifier_Complete; else goto Scan_Identifier; end if; -- Wide character in category Separator,Space terminates elsif Is_UTF_32_Space (Cat) then goto Scan_Identifier_Complete; end if; -- Here if wide character is part of the identifier -- Make sure we are allowing wide characters in -- identifiers. Note that we allow wide character -- notation for an OK identifier character. This in -- particular allows bracket or other notation to be -- used for upper half letters. -- If OK letter, store it folding to upper case. Note -- that we include the folded letter in the checksum. if Is_UTF_32_Letter (Cat) then Code := Char_Code (UTF_32_To_Upper_Case (UTF_32 (Code))); Accumulate_Checksum (Code); Store_Encoded_Character (Code); Underline_Found := False; -- If OK extended digit or mark, then store it elsif Is_UTF_32_Digit (Cat) or else Is_UTF_32_Mark (Cat) then Accumulate_Checksum (Code); Store_Encoded_Character (Code); Underline_Found := False; -- Wide punctuation is also stored, but counts as an -- underline character for error checking purposes. elsif Is_UTF_32_Punctuation (Cat) then Accumulate_Checksum (Code); if Underline_Found then declare Cend : constant Source_Ptr := Scan_Ptr; begin Scan_Ptr := Wptr; Scan_Ptr := Cend; end; else Store_Encoded_Character (Code); Underline_Found := True; end if; -- Any other wide character is not acceptable else null; end if; end if; goto Scan_Identifier; end; end if; end if; -- Scan of identifier is complete. The identifier is stored in -- Name_Buffer, and Scan_Ptr points past the last character. <> Token_Name := Name_Find; -- Check for identifier ending with underline or punctuation char if Underline_Found then Underline_Found := False; end if; -- We will assume it is an identifier, not a keyword, so that the -- checksum is independent of the Ada version. Token := Tok_Identifier; -- Here is where we check if it was a keyword if Is_Keyword_Name (Token_Name) then if Opt.Checksum_GNAT_6_3 then Token := Token_Value (Token_Name); if Checksum_Accumulate_Token_Checksum then if Checksum_GNAT_5_03 then Accumulate_Token_Checksum_GNAT_5_03; else Accumulate_Token_Checksum_GNAT_6_3; end if; end if; else Accumulate_Token_Checksum; Token := Token_Value (Token_Name); end if; -- We must reset Token_Name since this is not an identifier and -- if we leave Token_Name set, the parser gets confused because -- it thinks it is dealing with an identifier instead of the -- corresponding keyword. Token_Name := No_Name; return; -- It is an identifier after all else if Checksum_Accumulate_Token_Checksum then Accumulate_Token_Checksum; end if; Post_Scan; return; end if; end Scan; -------------------------- -- Set_Comment_As_Token -- -------------------------- procedure Set_Comment_As_Token (Value : Boolean) is begin Comment_Is_Token := Value; end Set_Comment_As_Token; ------------------------------ -- Set_End_Of_Line_As_Token -- ------------------------------ procedure Set_End_Of_Line_As_Token (Value : Boolean) is begin End_Of_Line_Is_Token := Value; end Set_End_Of_Line_As_Token; --------------------------- -- Set_Special_Character -- --------------------------- procedure Set_Special_Character (C : Character) is begin case C is when '#' | '$' | '_' | '?' | '@' | '`' | '\' | '^' | '~' => Special_Characters (C) := True; when others => null; end case; end Set_Special_Character; --------------- -- Scan_Wide -- --------------- procedure Scan_Wide (S : Source_Buffer_Ptr; P : in out Source_Ptr; C : out Char_Code; Err : out Boolean) is -- P_Init : constant Source_Ptr := P; Chr : Character; function In_Char return Character; -- Function to obtain characters of wide character escape sequence ------------- -- In_Char -- ------------- function In_Char return Character is begin P := P + 1; return S (P - 1); end In_Char; function WC_In is new Char_Sequence_To_UTF_32 (In_Char); -- Start of processing for Scan_Wide begin Chr := In_Char; -- Scan out the wide character. If the first character is a bracket, -- we allow brackets encoding regardless of the standard encoding -- method being used, but otherwise we use this standard method. if Chr = '[' then C := Char_Code (WC_In (Chr, WCEM_Brackets)); else C := Char_Code (WC_In (Chr, Wide_Character_Encoding_Method)); end if; Err := False; exception when Constraint_Error => C := Char_Code (0); P := P - 1; Err := True; end Scan_Wide; ---------------------- -- Set_Start_Column -- ---------------------- -- Note: it seems at first glance a little expensive to compute this value -- for every source line (since it is certainly not used for all source -- lines). On the other hand, it doesn't take much more work to skip past -- the initial white space on the line counting the columns than it would -- to scan past the white space using the standard scanning circuits. function Set_Start_Column return Column_Number is Start_Column : Column_Number := 0; begin -- Outer loop scans past horizontal tab characters Tabs_Loop : loop -- Inner loop scans past blanks as fast as possible, bumping Scan_Ptr -- past the blanks and adjusting Start_Column to account for them. Blanks_Loop : loop if Source (Scan_Ptr) = ' ' then if Source (Scan_Ptr + 1) = ' ' then if Source (Scan_Ptr + 2) = ' ' then if Source (Scan_Ptr + 3) = ' ' then if Source (Scan_Ptr + 4) = ' ' then if Source (Scan_Ptr + 5) = ' ' then if Source (Scan_Ptr + 6) = ' ' then Scan_Ptr := Scan_Ptr + 7; Start_Column := Start_Column + 7; else Scan_Ptr := Scan_Ptr + 6; Start_Column := Start_Column + 6; exit Blanks_Loop; end if; else Scan_Ptr := Scan_Ptr + 5; Start_Column := Start_Column + 5; exit Blanks_Loop; end if; else Scan_Ptr := Scan_Ptr + 4; Start_Column := Start_Column + 4; exit Blanks_Loop; end if; else Scan_Ptr := Scan_Ptr + 3; Start_Column := Start_Column + 3; exit Blanks_Loop; end if; else Scan_Ptr := Scan_Ptr + 2; Start_Column := Start_Column + 2; exit Blanks_Loop; end if; else Scan_Ptr := Scan_Ptr + 1; Start_Column := Start_Column + 1; exit Blanks_Loop; end if; else exit Blanks_Loop; end if; end loop Blanks_Loop; -- Outer loop keeps going only if a horizontal tab follows if Source (Scan_Ptr) = ASCII.HT then Scan_Ptr := Scan_Ptr + 1; Start_Column := (Start_Column / 8) * 8 + 8; else exit Tabs_Loop; end if; end loop Tabs_Loop; return Start_Column; -- A constraint error can happen only if we have a compiler with checks on -- and a line with a ludicrous number of tabs or spaces at the start. In -- such a case, we really don't care if Start_Column is right or not. exception when Constraint_Error => return Start_Column; end Set_Start_Column; --------------------------- -- Skip_Line_Terminators -- --------------------------- procedure Skip_Line_Terminators (P : in out Source_Ptr; Physical : out Boolean) is Chr : constant Character := Source (P); use ASCII; begin if Chr = CR then if Source (P + 1) = LF then P := P + 2; else P := P + 1; end if; elsif Chr = LF then P := P + 1; elsif Chr = FF or else Chr = VT then P := P + 1; Physical := False; return; -- Otherwise we have a wide character else Skip_Wide (Source, P); end if; -- Fall through in the physical line terminator case. First deal with -- making a possible entry into the lines table if one is needed. -- Note: we are dealing with a real source file here, this cannot be -- the instantiation case, so we need not worry about Sloc adjustment. declare S : constant access Source_File_Record := Current_Source_Record; begin Physical := True; -- Make entry in lines table if not already made (in some scan backup -- cases, we will be rescanning previously scanned source, so the -- entry may have already been made on the previous forward scan). if Source (P) /= EOF and then P > S.Lines_Table (S.Last_Source_Line) then Add_Line_Tables_Entry (S.all, P); end if; end; end Skip_Line_Terminators; ------------------ -- Start_String -- ------------------ procedure Start_String is begin String_Last := 0; String_Buffer_Overflow := False; end Start_String; ----------------------- -- Store_String_Char -- ----------------------- procedure Store_String_Char (Code : Char_Code) is begin if String_Last < String_Buffer'Last then String_Last := String_Last + 1; String_Buffer (String_Last) := Code; elsif not String_Buffer_Overflow then -- Mark that String_Buffer overflow String_Buffer_Overflow := True; end if; end Store_String_Char; ----------------- -- Token_Value -- ----------------- function Token_Value (N : Name_Id) return Token_Type is begin case N is when Name_Abort => return Tok_Abort; when Name_Abs => return Tok_Abs; when Name_Accept => return Tok_Accept; when Name_And => return Tok_And; when Name_All => return Tok_All; when Name_Array => return Tok_Array; when Name_At => return Tok_At; when Name_Begin => return Tok_Begin; when Name_Body => return Tok_Body; when Name_Case => return Tok_Case; when Name_Constant => return Tok_Constant; when Name_Declare => return Tok_Declare; when Name_Delay => return Tok_Delay; when Name_Do => return Tok_Do; when Name_Else => return Tok_Else; when Name_Elsif => return Tok_Elsif; when Name_End => return Tok_End; when Name_Entry => return Tok_Entry; when Name_Exception => return Tok_Exception; when Name_Exit => return Tok_Exit; when Name_For => return Tok_For; when Name_Function => return Tok_Function; when Name_Generic => return Tok_Generic; when Name_Goto => return Tok_Goto; when Name_If => return Tok_If; when Name_In => return Tok_In; when Name_Is => return Tok_Is; when Name_Limited => return Tok_Limited; when Name_Loop => return Tok_Loop; when Name_New => return Tok_New; when Name_Not => return Tok_Not; when Name_Null => return Tok_Null; when Name_Of => return Tok_Of; when Name_Or => return Tok_Or; when Name_Others => return Tok_Others; when Name_Out => return Tok_Out; when Name_Package => return Tok_Package; when Name_Pragma => return Tok_Pragma; when Name_Private => return Tok_Private; when Name_Procedure => return Tok_Procedure; when Name_Raise => return Tok_Raise; when Name_Record => return Tok_Record; when Name_Rem => return Tok_Rem; when Name_Renames => return Tok_Renames; when Name_Return => return Tok_Return; when Name_Reverse => return Tok_Reverse; when Name_Select => return Tok_Select; when Name_Separate => return Tok_Separate; when Name_Subtype => return Tok_Subtype; when Name_Task => return Tok_Task; when Name_Terminate => return Tok_Terminate; when Name_Then => return Tok_Then; when Name_Type => return Tok_Type; when Name_Use => return Tok_Use; when Name_When => return Tok_When; when Name_With => return Tok_With; when Name_Xor => return Tok_Xor; when Name_Access => return Tok_Access; when Name_Delta => return Tok_Delta; when Name_Digits => return Tok_Digits; when Name_Mod => return Tok_Mod; when Name_Range => return Tok_Range; when Name_Abstract => return Tok_Abstract; when Name_Aliased => return Tok_Aliased; when Name_Protected => return Tok_Protected; when Name_Until => return Tok_Until; when Name_Requeue => return Tok_Requeue; when Name_Tagged => return Tok_Tagged; when Name_Project => return Tok_Project; when Name_Extends => return Tok_Extends; when Name_External => return Tok_External; when Name_External_As_List => return Tok_External_As_List; when Name_Interface => return Tok_Interface; when Name_Overriding => return Tok_Overriding; when Name_Synchronized => return Tok_Synchronized; when Name_Some => return Tok_Some; when others => return No_Token; end case; end Token_Value; end Scanner; gprbuild-25.0.0/gpr/src/gpr-err.adb000066400000000000000000000623211470075373400170310ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2002-2021, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- with Ada.Text_IO; use Ada.Text_IO; with GPR.Cset; use GPR.Cset; with GPR.Erroutc; use GPR.Erroutc; with GPR.Names; use GPR.Names; with GPR.Opt; use GPR.Opt; with GPR.Osint; use GPR.Osint; with GPR.Output; use GPR.Output; with GPR.Scans; use GPR.Scans; with GPR.Sinput; use GPR.Sinput; package body GPR.Err is Current_Error_Source_File : Source_File_Index := No_Source_File; procedure Post_Scan; -- Only for debugging. Does nothing. procedure Output_Source_Line (L : Line_Number; Sfile : Source_File_Index; Errs : Boolean); -- Outputs text of source line L, in file S, together with preceding line -- number, as described above for Output_Line_Number. The Errs parameter -- indicates if there are errors attached to the line, which forces -- listing on, even in the presence of pragma List (Off). procedure Prescan_Message (Msg : String); -- Scans message text and sets the following variables: -- -- Is_Warning_Msg is set True if Msg is a warning message (contains a -- question mark character), and False otherwise. -- -- Is_Info_Msg is set True if Msg is an information message (starts -- with "info: ". Such messages must contain a ? sequence since they -- are also considered to be warning messages, and get a tag. -- -- Is_Serious_Error is set to True unless the message is a warning or -- style message or contains the character | (non-serious error). -- -- Is_Unconditional_Msg is set True if the message contains the character -- ! and is otherwise set False. -- -- Has_Double_Exclam is set True if the message contains the sequence !! -- and is otherwise set False. -- -- We need to know right away these aspects of a message, since we will -- test these values before doing the full error scan. -- -- Note that the call has no effect for continuation messages (those whose -- first character is '\'), and all variables are left unchanged. procedure Set_Msg_Text (Text : String); -- Add a sequence of characters to the current message. The characters may -- be one of the special insertion characters (see documentation in spec). -- Flag is the location at which the error is to be posted, which is used -- to determine whether or not the # insertion needs a file name. The -- variables Msg_Buffer, Msglen, Is_Warning_Msg, and Is_Unconditional_Msg -- are set on return. --------------- -- Error_Msg -- --------------- procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr; One_Line : Boolean := False) is Next_Msg : Error_Msg_Id; -- Pointer to next message at insertion point Prev_Msg : Error_Msg_Id; -- Pointer to previous message at insertion point Sptr : Source_Ptr renames Flag_Location; -- Corresponds to the Sptr value in the error message object Optr : Source_Ptr renames Flag_Location; -- Corresponds to the Optr value in the error message object. Note that -- for this usage, Sptr and Optr always have the same value, since we do -- not have to worry about generic instantiations. Sfile : Source_File_Index; Line : Line_Number; Col : Column_Number; begin Prescan_Message (Msg); Set_Msg_Text (Msg); -- Kill continuation if parent message killed if Continuation and Last_Killed then return; end if; -- Immediate return if warning message and warnings are suppressed. if Is_Warning_Msg and then Opt.Warning_Mode = Suppress then Cur_Msg := No_Error_Msg; return; end if; -- Otherwise build error message object for new message. -- First check that we do want to insert the error. Sfile := Get_Source_File_Index (Sptr); Line := Get_Line_Number (Sptr); Col := Get_Column_Number (Sptr); Prev_Msg := No_Error_Msg; Next_Msg := First_Error_Msg; while Next_Msg /= No_Error_Msg loop exit when Sfile < Errors.Table (Next_Msg).Sfile; if Sfile = Errors.Table (Next_Msg).Sfile then exit when Sptr < Errors.Table (Next_Msg).Sptr; end if; Prev_Msg := Next_Msg; Next_Msg := Errors.Table (Next_Msg).Next; end loop; -- Now we insert the new message in the error chain. The insertion -- point for the message is after Prev_Msg and before Next_Msg. -- The possible insertion point for the new message is after Prev_Msg -- and before Next_Msg. However, this is where we do a special check -- for redundant parsing messages, defined as messages posted on the -- same line. The idea here is that probably such messages are junk -- from the parser recovering. In full errors mode, we don't do this -- deletion, but otherwise such messages are discarded at this stage. if Prev_Msg /= No_Error_Msg and then Errors.Table (Prev_Msg).Line = Line and then (One_Line or else Errors.Table (Prev_Msg).Col = Col) and then Errors.Table (Prev_Msg).Sfile = Sfile then -- Don't delete unconditional messages and at this stage, don't -- delete continuation lines (we attempted to delete those earlier -- if the parent message was deleted. if not Is_Unconditional_Msg and then not Continuation then -- Don't delete if prev msg is warning and new msg is an error. -- This is because we don't want a real error masked by a warning. -- In all other cases (that is parse errors for the same line that -- are not unconditional) we do delete the message. This helps to -- avoid junk extra messages from cascaded parsing errors if not Errors.Table (Prev_Msg).Warn or else Is_Warning_Msg then -- All tests passed, delete the message by simply returning -- without any further processing. if not Continuation then Last_Killed := True; end if; return; end if; end if; end if; -- Come here if message is to be inserted in the error chain Errors.Append (New_Val => (Text => new String'(Msg_Buffer (1 .. Msglen)), Next => No_Error_Msg, Prev => No_Error_Msg, Sfile => Sfile, Sptr => Sptr, Optr => Optr, Line => Line, Col => Get_Column_Number (Sptr), Warn => Is_Warning_Msg, Info => Is_Info_Msg, Warn_Err => Warning_Mode = Treat_As_Error, Warn_Chr => Warning_Msg_Char, Serious => Is_Serious_Error, Uncond => Is_Unconditional_Msg, Msg_Cont => Continuation, Deleted => False)); Cur_Msg := Errors.Last; if not Continuation then Last_Killed := False; end if; if Prev_Msg = No_Error_Msg then First_Error_Msg := Cur_Msg; else Errors.Table (Prev_Msg).Next := Cur_Msg; end if; Errors.Table (Cur_Msg).Next := Next_Msg; -- Bump appropriate statistics count if Errors.Table (Cur_Msg).Warn then Warnings_Detected := Warnings_Detected + 1; if Errors.Table (Cur_Msg).Info then Info_Messages := Info_Messages + 1; end if; else Total_Errors_Detected := Total_Errors_Detected + 1; if Errors.Table (Cur_Msg).Serious then Serious_Errors_Detected := Serious_Errors_Detected + 1; end if; end if; end Error_Msg; -------------- -- Finalize -- -------------- procedure Finalize is Cur : Error_Msg_Id; Nxt : Error_Msg_Id; E, F : Error_Msg_Id; procedure Write_File_Name (Name : File_Name_Type); -- Write name to standard output if it is defined or (null) otherwise --------------------- -- Write_File_Name -- --------------------- procedure Write_File_Name (Name : File_Name_Type) is begin if Name = No_File then Write_Str ("(null)"); else Write_Str (Get_Name_String (Name)); end if; end Write_File_Name; begin -- Eliminate any duplicated error messages from the list. This is -- done after the fact to avoid problems with Change_Error_Text. Cur := First_Error_Msg; while Cur /= No_Error_Msg loop Nxt := Errors.Table (Cur).Next; F := Nxt; while F /= No_Error_Msg and then Errors.Table (F).Sptr = Errors.Table (Cur).Sptr loop Check_Duplicate_Message (Cur, F); F := Errors.Table (F).Next; end loop; Cur := Nxt; end loop; -- Brief Error mode if Brief_Output or not Verbose_Mode then E := First_Error_Msg; Set_Standard_Error; while E /= No_Error_Msg loop if not Errors.Table (E).Deleted then if Full_Path_Name_For_Brief_Errors then Write_File_Name (Full_Ref_Name (Errors.Table (E).Sfile)); else Write_File_Name (Reference_Name (Errors.Table (E).Sfile)); end if; Write_Char (':'); Write_Int (Int (Errors.Table (E).Line)); Write_Char (':'); if Errors.Table (E).Col < 10 then Write_Char ('0'); end if; Write_Int (Int (Errors.Table (E).Col)); Write_Str (": "); Output_Msg_Text (E); Write_Eol; end if; E := Errors.Table (E).Next; end loop; Set_Standard_Output; end if; -- Verbose mode (error lines only with error flags) if Verbose_Mode then E := First_Error_Msg; -- Loop through error lines while E /= No_Error_Msg loop Write_Eol; Output_Source_Line (Errors.Table (E).Line, Errors.Table (E).Sfile, True); Output_Error_Msgs (E); end loop; end if; -- Output error summary if verbose or full list mode if Opt.Verbosity_Level > Opt.Low then -- Extra blank line if error messages or source listing were output if Total_Errors_Detected + Warnings_Detected > 0 then Write_Eol; end if; -- Message giving number of lines read and number of errors detected. -- This normally goes to Standard_Output. The exception is when brief -- mode is not set, verbose mode (or full list mode) is set, and -- there are errors. In this case we send the message to standard -- error to make sure that *something* appears on standard error in -- an error situation. -- Historical note: Formerly, only the "# errors" suffix was sent -- to stderr, whereas "# lines:" appeared on stdout. This caused -- some problems on now-obsolete ports, but there seems to be no -- reason to revert this page since it would be incompatible. if Total_Errors_Detected + Warnings_Detected /= 0 and then not Brief_Output and then Verbose_Mode then Set_Standard_Error; end if; -- Message giving total number of lines Write_Str (" "); Write_Int (Num_Source_Lines (Main_Source_File)); if Num_Source_Lines (Main_Source_File) = 1 then Write_Str (" line: "); else Write_Str (" lines: "); end if; if Total_Errors_Detected = 0 then Write_Str ("No errors"); elsif Total_Errors_Detected = 1 then Write_Str ("1 error"); else Write_Int (Total_Errors_Detected); Write_Str (" errors"); end if; if Warnings_Detected - Info_Messages /= 0 then Write_Str (", "); Write_Int (Warnings_Detected - Info_Messages); Write_Str (" warning"); if Warnings_Detected - Info_Messages /= 1 then Write_Char ('s'); end if; if Warning_Mode = Treat_As_Error then Write_Str (" (treated as error"); if Warnings_Detected - Info_Messages /= 1 then Write_Char ('s'); end if; Write_Char (')'); end if; end if; Write_Eol; Set_Standard_Output; end if; if Warning_Mode = Treat_As_Error then Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected - Info_Messages; Warnings_Detected := Info_Messages; end if; -- Deallocate the memory associated to text Cur := First_Error_Msg; while Cur /= No_Error_Msg loop Free (Errors.Table (Cur).Text); Cur := Errors.Table (Cur).Next; end loop; -- Prevent displaying the same messages again in the future First_Error_Msg := No_Error_Msg; end Finalize; ---------------- -- Initialize -- ---------------- procedure Initialize is Cur : Error_Msg_Id; begin -- Sometimes Initialize is being called to reset the table, while -- memory is still allocated in this table - if so, deallocate -- the memory before resetting. if not Errors.Is_Empty then Cur := First_Error_Msg; while Cur /= No_Error_Msg loop Free (Errors.Table (Cur).Text); Cur := Errors.Table (Cur).Next; end loop; end if; Errors.Init; First_Error_Msg := No_Error_Msg; Last_Error_Msg := No_Error_Msg; Serious_Errors_Detected := 0; Total_Errors_Detected := 0; Warnings_Detected := 0; Info_Messages := 0; Cur_Msg := No_Error_Msg; -- Initialize warnings table, if all warnings are suppressed, supply -- an initial dummy entry covering all possible source locations. Warnings.Init; if Warning_Mode = Suppress then Warnings.Append (New_Val => (Start => Source_Ptr'First, Stop => Source_Ptr'Last, Reason => No_Name)); end if; end Initialize; ----------------------------- -- Mask_Control_Characters -- ----------------------------- function Mask_Control_Characters (Message : String) return String is Result : String (1 .. Message'Length * 2); Last : Natural := 0; begin for C of Message loop if C in '%' | '$' | '{' | '}' | '*' | '&' | '#' | '\' | '@' | '^' | '`' | '!' | '?' | '<' | '|' | ''' | '~' | 'A' .. 'Z' then Last := Last + 1; Result (Last) := '''; end if; Last := Last + 1; Result (Last) := C; end loop; return Result (1 .. Last); end Mask_Control_Characters; ------------------------ -- Output_Source_Line -- ------------------------ procedure Output_Source_Line (L : Line_Number; Sfile : Source_File_Index; Errs : Boolean) is S : Source_Ptr; C : Character; Line_Number_Output : Boolean := False; -- Set True once line number is output begin if Sfile /= Current_Error_Source_File then Write_Str ("==============Messages for file: "); Write_Name (Full_File_Name (Sfile)); Write_Eol; Current_Error_Source_File := Sfile; end if; if Errs then Output_Line_Number (L); Line_Number_Output := True; end if; S := Line_Start (L, Sfile); loop C := Source_Text (Sfile) (S); exit when C = ASCII.LF or else C = ASCII.CR or else C = EOF; if Errs then Write_Char (C); end if; S := S + 1; end loop; -- If we have output a source line, then add the line terminator, with -- training spaces preserved (so we output the line exactly as input). if Line_Number_Output then Write_Eol; end if; end Output_Source_Line; --------------- -- Post_Scan -- --------------- procedure Post_Scan is Debug_Tokens : constant Boolean := False; begin if Debug_Tokens then Write_Line (Token_Type'Image (Token)); if Token = Tok_Identifier or else Token = Tok_String_Literal then Write_Line (" " & Get_Name_String_Safe (Token_Name)); end if; end if; end Post_Scan; --------------- -- Error_Msg -- --------------- procedure Error_Msg (Flags : Processing_Flags; Msg : String; Location : Source_Ptr := No_Location; Project : Project_Id := null; Always : Boolean := False; One_Line : Boolean := False) is Real_Location : Source_Ptr := Location; begin -- Don't post message if incompleted with's (avoid junk cascaded errors) if not Always and then Flags.Incomplete_Withs then return; end if; -- Display the error message in the traces so that it appears in the -- correct location in the traces (otherwise error messages are only -- displayed at the end and it is difficult to see when they were -- triggered) if Current_Verbosity = High then Debug_Output ("ERROR: " & Msg); end if; -- If location of error is unknown, use the location of the project if Real_Location = No_Location and then Project /= null then Real_Location := Project.Location; end if; if not Always and then Real_Location = No_Location then -- If still null, we are parsing a project that was created in-memory -- so we shouldn't report errors for projects that the user has no -- access to in any case. if Current_Verbosity = High then Debug_Output ("Error in in-memory project, ignored"); end if; return; end if; -- Report the error through Errutil, so that duplicate errors are -- properly removed, messages are sorted, and correctly interpreted,... Error_Msg (Msg, Real_Location, One_Line); -- Let the application know there was an error if Flags.Report_Error /= null then Flags.Report_Error (Project, Is_Warning => Msg (Msg'First) = '?' or else (Msg (Msg'First) = '<' and then Error_Msg_Warn) or else (Msg (Msg'First) = '\' and then Msg (Msg'First + 1) = '<' and then Error_Msg_Warn)); end if; end Error_Msg; --------------------- -- Prescan_Message -- --------------------- procedure Prescan_Message (Msg : String) is J : Natural; begin -- Nothing to do for continuation line if Msg (Msg'First) = '\' then return; end if; -- Set initial values of globals (may be changed during scan) Is_Serious_Error := True; Is_Unconditional_Msg := False; Is_Warning_Msg := False; Has_Double_Exclam := False; -- Check info message Is_Info_Msg := Msg'Length > 6 and then Msg (Msg'First .. Msg'First + 5) = "info: "; J := Msg'First; while J <= Msg'Last loop -- If we have a quote, don't look at following character if Msg (J) = ''' then J := J + 2; -- Warning message (? or < insertion sequence) elsif Msg (J) = '?' or else Msg (J) = '<' then Is_Warning_Msg := Msg (J) = '?' or else Error_Msg_Warn; Warning_Msg_Char := ' '; J := J + 1; if Is_Warning_Msg then declare C : constant Character := Msg (J - 1); begin if J <= Msg'Last then if Msg (J) = C then Warning_Msg_Char := '?'; J := J + 1; elsif J < Msg'Last and then Msg (J + 1) = C and then (Msg (J) in 'a' .. 'z' or else Msg (J) in 'A' .. 'Z' or else Msg (J) = '*' or else Msg (J) = '$') then Warning_Msg_Char := Msg (J); J := J + 2; end if; end if; end; end if; -- Bomb if untagged warning message. This code can be uncommented -- for debugging when looking for untagged warning messages. -- if Is_Warning_Msg and then Warning_Msg_Char = ' ' then -- raise Program_Error; -- end if; -- Unconditional message (! insertion) elsif Msg (J) = '!' then Is_Unconditional_Msg := True; J := J + 1; if J <= Msg'Last and then Msg (J) = '!' then Has_Double_Exclam := True; J := J + 1; end if; -- Non-serious error (| insertion) elsif Msg (J) = '|' then Is_Serious_Error := False; J := J + 1; else J := J + 1; end if; end loop; if Is_Warning_Msg then Is_Serious_Error := False; end if; end Prescan_Message; ------------------ -- Set_Msg_Text -- ------------------ procedure Set_Msg_Text (Text : String) is C : Character; -- Current character P : Natural; -- Current index; begin Manual_Quote_Mode := False; Msglen := 0; P := Text'First; while P <= Text'Last loop C := Text (P); P := P + 1; -- Check for insertion character if C = '%' then if P <= Text'Last and then Text (P) = '%' then P := P + 1; Set_Msg_Insertion_Name_Literal; else Set_Msg_Insertion_Name; end if; elsif C = '$' then -- '$' is ignored null; elsif C = '{' then Set_Msg_Insertion_File_Name; elsif C = '}' then -- '}' is ignored null; elsif C = '*' then Set_Msg_Insertion_Reserved_Name; elsif C = '&' then -- '&' is ignored null; elsif C = '#' then null; elsif C = '\' then Continuation := True; elsif C = '@' then null; elsif C = '^' then null; elsif C = '`' then Manual_Quote_Mode := not Manual_Quote_Mode; Set_Msg_Char ('"'); elsif C = '!' then null; elsif C = '?' then null; elsif C = '<' then null; elsif C = '|' then null; elsif C = ''' then Set_Msg_Char (Text (P)); P := P + 1; -- Upper case letter (start of reserved word if 2 or more) elsif C in 'A' .. 'Z' and then P <= Text'Last and then Text (P) in 'A' .. 'Z' then P := P - 1; Set_Msg_Insertion_Reserved_Word (Text, P); elsif C = '~' then Set_Msg_Str (Error_Msg_String (1 .. Error_Msg_Strlen)); -- Normal character with no special treatment else Set_Msg_Char (C); end if; end loop; end Set_Msg_Text; package body Scanner is separate; end GPR.Err; gprbuild-25.0.0/gpr/src/gpr-err.ads000066400000000000000000000131161470075373400170500ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2021, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package contains the routines to output error messages and the scanner -- for the project files. It replaces Errout and Scn. It is not dependent on -- the GNAT tree packages (Atree, Sinfo, ...). It uses exactly the same global -- variables as Errout, located in package Err_Vars. Like Errout, it also uses -- the common variables and routines in package Erroutc. -- -- Parameters are set through Err_Vars.Error_Msg_File_* or -- Err_Vars.Error_Msg_Name_*, and replaced automatically in the messages -- ("{{" for files, "%%" for names). -- -- However, in this package you can configure the error messages to be sent -- to your own callback by setting Report_Error in the flags. This ensures -- that applications can control where error messages are displayed. package GPR.Err is ------------------------------ -- Error Output Subprograms -- ------------------------------ procedure Initialize; -- Initializes for output of error messages. Must be called for each -- file before using any of the other routines in the package. procedure Finalize; -- Finalize processing of error messages for one file and output message -- indicating the number of detected errors. procedure Error_Msg (Flags : Processing_Flags; Msg : String; Location : Source_Ptr := No_Location; Project : Project_Id := null; Always : Boolean := False; One_Line : Boolean := False); -- Output an error message, either through Flags.Error_Report or through -- Errutil. The location defaults to the project's location ("project" -- in the source code). If Msg starts with "?", this is a warning, and -- Warning: is added at the beginning. If Msg starts with "<", see comment -- for Err_Vars.Error_Msg_Warn. -- One_Line flag mean only one error message per line, need to hide some -- wrong error message in project parser. function Mask_Control_Characters (Message : String) return String; -- Returns the message with all control characters masked by apostrophe procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr; One_Line : Boolean := False); -- Output a message at specified location. -- One_Line flag mean only one error message per line, need to hide some -- wrong error message in project parser. ------------- -- Scanner -- ------------- package Scanner is type Language is (Ada, Project); procedure Initialize_Scanner (Index : Source_File_Index; Lang : Language); -- Initialize lexical scanner for scanning a new file referenced by -- Index. Initialize_Scanner does not call Scan. procedure Scan; -- Scan scans out the next token, and advances the scan state -- accordingly (see package Scan_State for details). If the scan -- encounters an illegal token, then an error message is issued pointing -- to the bad character, and Scan returns a reasonable substitute token -- of some kind. For tokens Char_Literal, Identifier, Real_Literal, -- Integer_Literal, String_Literal and Operator_Symbol, Post_Scan is -- called after scanning. procedure Set_End_Of_Line_As_Token (Value : Boolean); -- Indicate if End_Of_Line is a token or not. -- By default, End_Of_Line is not a token. procedure Set_Comment_As_Token (Value : Boolean); -- Indicate if a comment is a token or not. -- By default, a comment is not a token. procedure Set_Special_Character (C : Character); -- Indicate that one of the following character '#', '$', '?', '@', '`', -- '\', '^', '_' or '~', when found is a Special token. procedure Reset_Special_Characters; -- Indicate that there is no characters that are Special tokens., which -- is the default. end Scanner; end GPR.Err; gprbuild-25.0.0/gpr/src/gpr-erroutc.adb000066400000000000000000000710771470075373400177340ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Interfaces; use Interfaces; pragma Warnings (Off); with System.WCh_Con; use System.WCh_Con; pragma Warnings (On); with GPR.Names; use GPR.Names; with GPR.Opt; use GPR.Opt; with GPR.Output; use GPR.Output; with GPR.Sinput; use GPR.Sinput; package body GPR.Erroutc is type UTF_32_Code is range 0 .. 16#7FFF_FFFF#; for UTF_32_Code'Size use 32; -- Range of allowed UTF-32 encoding values function Same_Error (M1, M2 : Error_Msg_Id) return Boolean; -- See if two messages have the same text. Returns true if the text of the -- two messages is identical, or if one of them is the same as the other -- with an appended "instance at xxx" tag. procedure Set_Msg_Blank; -- Sets a single blank in the message if the preceding character is a -- non-blank character other than a left parenthesis or minus. Has no -- effect if manual quote mode is turned on. procedure Set_Msg_Blank_Conditional; -- Sets a single blank in the message if the preceding character is a -- non-blank character other than a left parenthesis or quote. Has no -- effect if manual quote mode is turned on. procedure Set_Msg_Name_Buffer; -- Output name from Name_Buffer, with surrounding quotes unless manual -- quotation mode is in effect. procedure Set_Msg_Quote; -- Set quote if in normal quote mode, nothing if in manual quote mode procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id); -- Given a message id, move to next message id, but skip any deleted -- messages, so that this results in E on output being the first non- -- deleted message following the input value of E, or No_Error_Msg if -- the input value of E was either already No_Error_Msg, or was the -- last non-deleted message. procedure Skip_Wide (S : Source_Buffer_Ptr; P : in out Source_Ptr); -- Similar to the above procedure, but operates on a source buffer -- instead of a string, with P being a Source_Ptr referencing the -- contents of the source buffer. procedure Write_Spaces (N : Nat); -- Write N spaces ----------------------------- -- Check_Duplicate_Message -- ----------------------------- procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id) is L1, L2 : Error_Msg_Id; N1, N2 : Error_Msg_Id; procedure Delete_Msg (Delete, Keep : Error_Msg_Id); -- Called to delete message Delete, keeping message Keep. Marks msg -- Delete and all its continuations with deleted flag set to True. -- Also makes sure that for the error messages that are retained the -- preferred message is the one retained (we prefer the shorter one in -- the case where one has an Instance tag). Note that we always know -- that Keep has at least as many continuations as Delete (since we -- always delete the shorter sequence). ---------------- -- Delete_Msg -- ---------------- procedure Delete_Msg (Delete, Keep : Error_Msg_Id) is D, K : Error_Msg_Id; begin D := Delete; K := Keep; loop Errors.Table (D).Deleted := True; -- Adjust error message count if Errors.Table (D).Warn then Warnings_Detected := Warnings_Detected - 1; if Errors.Table (D).Info then Info_Messages := Info_Messages - 1; end if; -- Note: we do not need to decrement Warnings_Treated_As_Errors -- because this only gets incremented if we actually output the -- message, which we won't do if we are deleting it here! else Total_Errors_Detected := Total_Errors_Detected - 1; if Errors.Table (D).Serious then Serious_Errors_Detected := Serious_Errors_Detected - 1; end if; end if; -- Substitute shorter of the two error messages if Errors.Table (K).Text'Length > Errors.Table (D).Text'Length then Errors.Table (K).Text := Errors.Table (D).Text; end if; D := Errors.Table (D).Next; K := Errors.Table (K).Next; if D = No_Error_Msg or else not Errors.Table (D).Msg_Cont then return; end if; end loop; end Delete_Msg; -- Start of processing for Check_Duplicate_Message begin -- Both messages must be non-continuation messages and not deleted if Errors.Table (M1).Msg_Cont or else Errors.Table (M2).Msg_Cont or else Errors.Table (M1).Deleted or else Errors.Table (M2).Deleted then return; end if; -- Definitely not equal if message text does not match if not Same_Error (M1, M2) then return; end if; -- Same text. See if all continuations are also identical L1 := M1; L2 := M2; loop N1 := Errors.Table (L1).Next; N2 := Errors.Table (L2).Next; -- If M1 continuations have run out, we delete M1, either the -- messages have the same number of continuations, or M2 has -- more and we prefer the one with more anyway. if N1 = No_Error_Msg or else not Errors.Table (N1).Msg_Cont then Delete_Msg (M1, M2); return; -- If M2 continuations have run out, we delete M2 elsif N2 = No_Error_Msg or else not Errors.Table (N2).Msg_Cont then Delete_Msg (M2, M1); return; -- Otherwise see if continuations are the same, if not, keep both -- sequences, a curious case, but better to keep everything. elsif not Same_Error (N1, N2) then return; -- If continuations are the same, continue scan else L1 := N1; L2 := N2; end if; end loop; end Check_Duplicate_Message; ------------------------ -- Compilation_Errors -- ------------------------ function Compilation_Errors return Boolean is begin return Total_Errors_Detected /= 0 or else (Warnings_Detected - Info_Messages /= 0 and then Warning_Mode = Treat_As_Error) or else Warnings_Treated_As_Errors /= 0; end Compilation_Errors; ------------------ -- Get_Location -- ------------------ function Get_Location (E : Error_Msg_Id) return Source_Ptr is begin return Errors.Table (E).Sptr; end Get_Location; ---------------- -- Get_Msg_Id -- ---------------- function Get_Msg_Id return Error_Msg_Id is begin return Cur_Msg; end Get_Msg_Id; --------------------------- -- Is_Start_Of_Wide_Char -- --------------------------- function Is_Start_Of_Wide_Char (S : Source_Buffer_Ptr; P : Source_Ptr) return Boolean is begin case Wide_Character_Encoding_Method is -- For Hex mode, just test for an ESC character. The ESC character -- cannot appear in any other context in a legal Ada program. when WCEM_Hex => return S (P) = ASCII.ESC; -- For brackets, just test ["x where x is a hex character. This is -- sufficient test, since this sequence cannot otherwise appear in a -- legal Ada program. when WCEM_Brackets => return 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'); -- All other encoding methods use the upper bit set in the first -- character to uniquely represent a wide character. when WCEM_Upper | WCEM_Shift_JIS | WCEM_EUC | WCEM_UTF8 => return S (P) >= Character'Val (16#80#); end case; end Is_Start_Of_Wide_Char; ----------------------- -- Output_Error_Msgs -- ----------------------- procedure Output_Error_Msgs (E : in out Error_Msg_Id) is P : Source_Ptr; T : Error_Msg_Id; S : Error_Msg_Id; Flag_Num : Pos; Mult_Flags : Boolean := False; begin S := E; -- Figure out if we will place more than one error flag on this line T := S; while T /= No_Error_Msg and then Errors.Table (T).Line = Errors.Table (E).Line and then Errors.Table (T).Sfile = Errors.Table (E).Sfile loop if Errors.Table (T).Sptr > Errors.Table (E).Sptr then Mult_Flags := True; end if; Set_Next_Non_Deleted_Msg (T); end loop; -- Output the error flags. The circuit here makes sure that the tab -- characters in the original line are properly accounted for. The -- eight blanks at the start are to match the line number. Write_Str (" "); P := Line_Start (Errors.Table (E).Sptr); if P = No_Location then return; end if; Flag_Num := 1; -- Loop through error messages for this line to place flags T := S; while T /= No_Error_Msg and then Errors.Table (T).Line = Errors.Table (E).Line and then Errors.Table (T).Sfile = Errors.Table (E).Sfile loop declare Src : Source_Buffer_Ptr renames Source_Text (Errors.Table (T).Sfile); begin -- Loop to output blanks till current flag position while P < Errors.Table (T).Sptr loop -- Horizontal tab case, just echo the tab if Src (P) = ASCII.HT then Write_Char (ASCII.HT); P := P + 1; -- Deal with wide character case, but don't include brackets -- notation in this circuit, since we know that this will -- display unencoded (no one encodes brackets notation). elsif Src (P) /= '[' and then Is_Start_Of_Wide_Char (Src, P) then Skip_Wide (Src, P); Write_Char (' '); -- Normal non-wide character case (or bracket) else P := P + 1; Write_Char (' '); end if; end loop; -- Output flag (unless already output, this happens if more -- than one error message occurs at the same flag position). if P = Errors.Table (T).Sptr then if (Flag_Num = 1 and then not Mult_Flags) or else Flag_Num > 9 then Write_Char ('|'); else Write_Char (Character'Val (Character'Pos ('0') + Flag_Num)); end if; -- Skip past the corresponding source text character -- Horizontal tab case, we output a flag at the tab position -- so now we output a tab to match up with the text. if Src (P) = ASCII.HT then Write_Char (ASCII.HT); P := P + 1; -- Skip wide character other than left bracket elsif Src (P) /= '[' and then Is_Start_Of_Wide_Char (Src, P) then Skip_Wide (Src, P); -- Skip normal non-wide character case (or bracket) else P := P + 1; end if; end if; end; Set_Next_Non_Deleted_Msg (T); Flag_Num := Flag_Num + 1; end loop; Write_Eol; -- Now output the error messages T := S; while T /= No_Error_Msg and then Errors.Table (T).Line = Errors.Table (E).Line and then Errors.Table (T).Sfile = Errors.Table (E).Sfile loop Write_Str (" >>> "); Output_Msg_Text (T); Write_Eol; Set_Next_Non_Deleted_Msg (T); end loop; E := T; end Output_Error_Msgs; ------------------------ -- Output_Line_Number -- ------------------------ procedure Output_Line_Number (L : Line_Number) is D : Int; -- next digit C : Character; -- next character Z : Boolean; -- flag for zero suppress N, M : Int; -- temporaries begin if L = No_Line_Number then Write_Str (" "); else Z := False; N := Int (L); M := 100_000; while M /= 0 loop D := Int (N / M); N := N rem M; M := M / 10; if D = 0 then if Z then C := '0'; else C := ' '; end if; else Z := True; C := Character'Val (D + 48); end if; Write_Char (C); end loop; Write_Str (". "); end if; end Output_Line_Number; --------------------- -- Output_Msg_Text -- --------------------- procedure Output_Msg_Text (E : Error_Msg_Id) is Offs : constant Nat := Column - 1; -- Offset to start of message, used for continuations Txt : constant String := Errors.Table (E).Text.all; procedure Write_Text (Txt : String); -- Write the message, splitting it up into multiple lines ---------------- -- Write_Text -- ---------------- procedure Write_Text (Txt : String) is begin for J in 1 .. Txt'Length loop if Txt (J) = ASCII.LF then Write_Eol; Write_Spaces (Offs); else Write_Char (Txt (J)); end if; end loop; end Write_Text; begin -- Deal with warning case if Errors.Table (E).Warn then -- For info messages, prefix message with "info: " if Errors.Table (E).Info then Write_Text ("info: " & Txt); -- Warning treated as error elsif Errors.Table (E).Warn_Err then -- We prefix with "error:" rather than warning: and postfix -- [warning-as-error] at the end. Warnings_Treated_As_Errors := Warnings_Treated_As_Errors + 1; Write_Text ("error: " & Txt & " [warning-as-error]"); -- Normal case, prefix with "warning: " else Write_Text ("warning: " & Txt); end if; else Write_Text (Txt); end if; end Output_Msg_Text; ---------------- -- Same_Error -- ---------------- function Same_Error (M1, M2 : Error_Msg_Id) return Boolean is Msg1 : constant String_Access := Errors.Table (M1).Text; Msg2 : constant String_Access := Errors.Table (M2).Text; Msg2_Len : constant Integer := Msg2'Length; Msg1_Len : constant Integer := Msg1'Length; begin return Msg1.all = Msg2.all or else (Msg1_Len - 10 > Msg2_Len and then Msg2.all = Msg1.all (1 .. Msg2_Len) and then Msg1 (Msg2_Len + 1 .. Msg2_Len + 10) = ", instance") or else (Msg2_Len - 10 > Msg1_Len and then Msg1.all = Msg2.all (1 .. Msg1_Len) and then Msg2 (Msg1_Len + 1 .. Msg1_Len + 10) = ", instance"); end Same_Error; ------------------- -- Set_Msg_Blank -- ------------------- procedure Set_Msg_Blank is begin if Msglen > 0 and then Msg_Buffer (Msglen) /= ' ' and then Msg_Buffer (Msglen) /= '(' and then Msg_Buffer (Msglen) /= '-' and then not Manual_Quote_Mode then Set_Msg_Char (' '); end if; end Set_Msg_Blank; ------------------------------- -- Set_Msg_Blank_Conditional -- ------------------------------- procedure Set_Msg_Blank_Conditional is begin if Msglen > 0 and then Msg_Buffer (Msglen) /= ' ' and then Msg_Buffer (Msglen) /= '(' and then Msg_Buffer (Msglen) /= '"' and then not Manual_Quote_Mode then Set_Msg_Char (' '); end if; end Set_Msg_Blank_Conditional; ------------------ -- Set_Msg_Char -- ------------------ procedure Set_Msg_Char (C : Character) is begin -- The check for message buffer overflow is needed to deal with cases -- where insertions get too long (in particular a child unit name can -- be very long). if Msglen < Max_Msg_Length then Msglen := Msglen + 1; Msg_Buffer (Msglen) := C; end if; end Set_Msg_Char; --------------------------------- -- Set_Msg_Insertion_File_Name -- --------------------------------- procedure Set_Msg_Insertion_File_Name is begin if Error_Msg_File_1 = No_File then null; elsif Error_Msg_File_1 = Error_File_Name then Set_Msg_Blank; Set_Msg_Str (""); else Set_Msg_Blank; Get_Name_String (Error_Msg_File_1); Set_Msg_Quote; Set_Msg_Name_Buffer; Set_Msg_Quote; end if; -- The following assignments ensure that the second { insertion -- characters will correspond to the Error_Msg_File_2. Error_Msg_File_1 := Error_Msg_File_2; end Set_Msg_Insertion_File_Name; ---------------------------- -- Set_Msg_Insertion_Name -- ---------------------------- procedure Set_Msg_Insertion_Name is begin if Error_Msg_Name_1 = No_Name then null; elsif Error_Msg_Name_1 = Error_Name then Set_Msg_Blank; Set_Msg_Str (""); else Set_Msg_Blank_Conditional; Get_Name_String (Error_Msg_Name_1); -- Remove upper case letter at end, again, we should not be getting -- such names, and what we hope is that the remainder makes sense. if Name_Len > 1 and then Name_Buffer (Name_Len) in 'A' .. 'Z' then Name_Len := Name_Len - 1; end if; -- If operator name or character literal name, just print it as is -- Also print as is if it ends in a right paren (case of x'val(nnn)) if Name_Buffer (1) = '"' or else Name_Buffer (1) = ''' or else Name_Buffer (Name_Len) = ')' then Set_Msg_Name_Buffer; -- Else output with surrounding quotes in proper casing mode else Set_Casing (Mixed_Case); Set_Msg_Quote; Set_Msg_Name_Buffer; Set_Msg_Quote; end if; end if; Error_Msg_Name_1 := Error_Msg_Name_2; end Set_Msg_Insertion_Name; ------------------------------------ -- Set_Msg_Insertion_Name_Literal -- ------------------------------------ procedure Set_Msg_Insertion_Name_Literal is begin if Error_Msg_Name_1 = No_Name then null; elsif Error_Msg_Name_1 = Error_Name then Set_Msg_Blank; Set_Msg_Str (""); else Set_Msg_Blank; Get_Name_String (Error_Msg_Name_1); Set_Msg_Quote; Set_Msg_Name_Buffer; Set_Msg_Quote; end if; Error_Msg_Name_1 := Error_Msg_Name_2; end Set_Msg_Insertion_Name_Literal; ------------------------------------- -- Set_Msg_Insertion_Reserved_Name -- ------------------------------------- procedure Set_Msg_Insertion_Reserved_Name is begin Set_Msg_Blank_Conditional; Get_Name_String (Error_Msg_Name_1); Set_Msg_Quote; Set_Casing (All_Lower_Case); Set_Msg_Name_Buffer; Set_Msg_Quote; end Set_Msg_Insertion_Reserved_Name; ------------------------------------- -- Set_Msg_Insertion_Reserved_Word -- ------------------------------------- procedure Set_Msg_Insertion_Reserved_Word (Text : String; J : in out Integer) is begin Set_Msg_Blank_Conditional; Name_Len := 0; while J <= Text'Last and then Text (J) in 'A' .. 'Z' loop Add_Char_To_Name_Buffer (Text (J)); J := J + 1; end loop; -- Here is where we make the special exception for RM if Name_Len = 2 and then Name_Buffer (1 .. 2) = "RM" then Set_Msg_Name_Buffer; -- We make a similar exception for SPARK elsif Name_Len = 5 and then Name_Buffer (1 .. 5) = "SPARK" then Set_Msg_Name_Buffer; -- Neither RM nor SPARK: case appropriately and add surrounding quotes else Set_Casing (All_Lower_Case); Set_Msg_Quote; Set_Msg_Name_Buffer; Set_Msg_Quote; end if; end Set_Msg_Insertion_Reserved_Word; ------------------------- -- Set_Msg_Name_Buffer -- ------------------------- procedure Set_Msg_Name_Buffer is begin Set_Msg_Str (Name_Buffer (1 .. Name_Len)); end Set_Msg_Name_Buffer; ------------------- -- Set_Msg_Quote -- ------------------- procedure Set_Msg_Quote is begin if not Manual_Quote_Mode then Set_Msg_Char ('"'); end if; end Set_Msg_Quote; ----------------- -- Set_Msg_Str -- ----------------- procedure Set_Msg_Str (Text : String) is begin for J in Text'Range loop Set_Msg_Char (Text (J)); end loop; end Set_Msg_Str; ------------------------------ -- Set_Next_Non_Deleted_Msg -- ------------------------------ procedure Set_Next_Non_Deleted_Msg (E : in out Error_Msg_Id) is begin if E = No_Error_Msg then return; else loop E := Errors.Table (E).Next; exit when E = No_Error_Msg or else not Errors.Table (E).Deleted; end loop; end if; end Set_Next_Non_Deleted_Msg; --------------- -- Skip_Wide -- --------------- procedure Skip_Wide (S : Source_Buffer_Ptr; P : in out Source_Ptr) is B1 : Unsigned_32; C1 : Character; U : Unsigned_32; W : Unsigned_32; procedure Get_Hex (N : Character); -- If N is a hex character, then set B1 to 16 * B1 + character N. -- Raise Constraint_Error if character N is not a hex character. procedure Get_UTF_Byte; pragma Inline (Get_UTF_Byte); -- Used to interpret a 2#10xxxxxx# continuation byte in UTF-8 mode. -- Reads a byte, and raises CE if the first two bits are not 10. -- Otherwise shifts W 6 bits left and or's in the 6 xxxxxx bits. function Skip_Char return Character; -- Function to skip one character of wide character escape sequence ------------- -- Get_Hex -- ------------- procedure Get_Hex (N : Character) is B2 : constant Unsigned_32 := Character'Pos (N); begin if B2 in Character'Pos ('0') .. Character'Pos ('9') then B1 := B1 * 16 + B2 - Character'Pos ('0'); elsif B2 in Character'Pos ('A') .. Character'Pos ('F') then B1 := B1 * 16 + B2 - (Character'Pos ('A') - 10); elsif B2 in Character'Pos ('a') .. Character'Pos ('f') then B1 := B1 * 16 + B2 - (Character'Pos ('a') - 10); else raise Constraint_Error; end if; end Get_Hex; ------------------ -- Get_UTF_Byte -- ------------------ procedure Get_UTF_Byte is begin U := Unsigned_32 (Character'Pos (Skip_Char)); if (U and 2#11000000#) /= 2#10_000000# then raise Constraint_Error; end if; W := Shift_Left (W, 6) or (U and 2#00111111#); end Get_UTF_Byte; --------------- -- Skip_Char -- --------------- function Skip_Char return Character is begin P := P + 1; return S (P - 1); end Skip_Char; -- Start of processing for Skip_Wide C : constant Character := Skip_Char; begin case Wide_Character_Encoding_Method is when WCEM_Hex => if C /= ASCII.ESC then null; else B1 := 0; Get_Hex (Skip_Char); Get_Hex (Skip_Char); Get_Hex (Skip_Char); Get_Hex (Skip_Char); end if; when WCEM_Upper | WCEM_Shift_JIS | WCEM_EUC => null; when WCEM_UTF8 => -- Note: for details of UTF8 encoding see RFC 3629 U := Unsigned_32 (Character'Pos (C)); -- 16#00_0000#-16#00_007F#: 0xxxxxxx if (U and 2#10000000#) = 2#00000000# then null; -- 16#00_0080#-16#00_07FF#: 110xxxxx 10xxxxxx elsif (U and 2#11100000#) = 2#110_00000# then Get_UTF_Byte; -- 16#00_0800#-16#00_ffff#: 1110xxxx 10xxxxxx 10xxxxxx elsif (U and 2#11110000#) = 2#1110_0000# then Get_UTF_Byte; Get_UTF_Byte; -- 16#01_0000#-16#10_FFFF#: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx elsif (U and 2#11111000#) = 2#11110_000# then for K in 1 .. 3 loop Get_UTF_Byte; end loop; -- 16#0020_0000#-16#03FF_FFFF#: 111110xx 10xxxxxx 10xxxxxx -- 10xxxxxx 10xxxxxx elsif (U and 2#11111100#) = 2#111110_00# then for K in 1 .. 4 loop Get_UTF_Byte; end loop; -- 16#0400_0000#-16#7FFF_FFFF#: 1111110x 10xxxxxx 10xxxxxx -- 10xxxxxx 10xxxxxx 10xxxxxx elsif (U and 2#11111110#) = 2#1111110_0# then for K in 1 .. 5 loop Get_UTF_Byte; end loop; else raise Constraint_Error; end if; when WCEM_Brackets => if C = '[' then if Skip_Char /= '"' then raise Constraint_Error; end if; B1 := 0; Get_Hex (Skip_Char); Get_Hex (Skip_Char); C1 := Skip_Char; if C1 /= '"' then Get_Hex (C1); Get_Hex (Skip_Char); C1 := Skip_Char; if C1 /= '"' then Get_Hex (C1); Get_Hex (Skip_Char); C1 := Skip_Char; if C1 /= '"' then Get_Hex (C1); Get_Hex (Skip_Char); if B1 > Unsigned_32 (UTF_32_Code'Last) then raise Constraint_Error; end if; if Skip_Char /= '"' then raise Constraint_Error; end if; end if; end if; end if; if Skip_Char /= ']' then raise Constraint_Error; end if; end if; end case; end Skip_Wide; ------------------ -- Write_Spaces -- ------------------ procedure Write_Spaces (N : Nat) is begin for J in 1 .. N loop Write_Char (' '); end loop; end Write_Spaces; end GPR.Erroutc; gprbuild-25.0.0/gpr/src/gpr-erroutc.ads000066400000000000000000000402731470075373400177470ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- This packages contains global variables and routines common to error -- reporting packages, including Errout and Prj.Err. with GNAT.Table; with GPR.Osint; use GPR.Osint; package GPR.Erroutc is Continuation : Boolean := False; -- Indicates if current message is a continuation. Initialized from the -- Msg_Cont parameter in Error_Msg_Internal and then set True if a \ -- insertion character is encountered. Has_Double_Exclam : Boolean := False; -- Set true to indicate that the current message contains the insertion -- sequence !! (force warnings even in non-main unit source files). Is_Serious_Error : Boolean := False; -- Set True for a serious error (i.e. any message that is not a warning -- or style message, and that does not contain a | insertion character). Is_Unconditional_Msg : Boolean := False; -- Set True to indicate that the current message contains the insertion -- character ! and is thus to be treated as an unconditional message. Is_Warning_Msg : Boolean := False; -- Set True to indicate if current message is warning message (contains ? -- or contains < and Error_Msg_Warn is True. Is_Info_Msg : Boolean := False; -- Set True to indicate that the current message starts with the characters -- "info: " and is to be treated as an information message. This string -- will be prepended to the message and all its continuations. Warning_Msg_Char : Character; -- Warning character, valid only if Is_Warning_Msg is True -- ' ' -- ? or < appeared on its own in message -- '?' -- ?? or << appeared in message -- 'x' -- ?x? or Error_Msg_Object, Table_Index_Type => Error_Msg_Id, Table_Low_Bound => 1, Table_Initial => 200, Table_Increment => 200); First_Error_Msg : Error_Msg_Id; -- The list of error messages, i.e. the first entry on the list of error -- messages. This is not the same as the physically first entry in the -- error message table, since messages are not always inserted in sequence. Last_Error_Msg : Error_Msg_Id; -- The last entry on the list of error messages. Note: this is not the same -- as the physically last entry in the error message table, since messages -- are not always inserted in sequence. Error_Msg_Name_1 : Name_Id := No_Name; Error_Msg_Name_2 : Name_Id := No_Name; -- Name_Id values for % insertion characters in message Error_Msg_File_1 : File_Name_Type := No_File; Error_Msg_File_2 : File_Name_Type := No_File; -- File_Name_Type values for { insertion characters in message Error_Msg_Warn : Boolean := False; Error_Msg_String : String (1 .. 4096); Error_Msg_Strlen : Natural; -- Used if current message contains a ~ insertion character to indicate -- insertion of the string Error_Msg_String (1 .. Error_Msg_Strlen). -------------------------- -- Warning Mode Control -- -------------------------- -- Pragma Warnings allows warnings to be turned off for a specified region -- of code, and the following tables are the data structures used to keep -- track of these regions. -- The first table is used for the basic command line control, and for the -- forms of Warning with a single ON or OFF parameter. -- It contains pairs of source locations, the first being the start -- location for a warnings off region, and the second being the end -- location. When a pragma Warnings (Off) is encountered, a new entry is -- established extending from the location of the pragma to the end of the -- current source file. A subsequent pragma Warnings (On) adjusts the end -- point of this entry appropriately. -- If all warnings are suppressed by command switch, then there is a dummy -- entry (put there by Errout.Initialize) at the start of the table which -- covers all possible Source_Ptr values. Note that the source pointer -- values in this table always reference the original template, not an -- instantiation copy, in the generic case. -- Reason is the reason from the pragma Warnings (Off,..) or the null -- string if no reason parameter is given. type Warnings_Entry is record Start : Source_Ptr; Stop : Source_Ptr; Reason : Name_Id; end record; package Warnings is new GNAT.Table ( Table_Component_Type => Warnings_Entry, Table_Index_Type => Natural, Table_Low_Bound => 1, Table_Initial => 100, Table_Increment => 200); ----------------- -- Subprograms -- ----------------- function Compilation_Errors return Boolean; -- Returns true if errors have been detected, or warnings in -gnatwe -- (treat warnings as errors) mode. procedure Check_Duplicate_Message (M1, M2 : Error_Msg_Id); -- This function is passed the Id values of two error messages. If either -- M1 or M2 is a continuation message, or is already deleted, the call is -- ignored. Otherwise a check is made to see if M1 and M2 are duplicated or -- redundant. If so, the message to be deleted and all its continuations -- are marked with the Deleted flag set to True. function Is_Start_Of_Wide_Char (S : Source_Buffer_Ptr; P : Source_Ptr) return Boolean; -- Determines if S (P) is the start of a wide character sequence procedure Output_Error_Msgs (E : in out Error_Msg_Id); -- Output source line, error flag, and text of stored error message and all -- subsequent messages for the same line and unit. On return E is set to be -- one higher than the last message output. procedure Output_Line_Number (L : Line_Number); -- Output a line number as six digits (with leading zeroes suppressed), -- followed by a period and a blank (note that this is 8 characters which -- means that tabs in the source line will not get messed up). Line numbers -- that match or are less than the last Source_Reference pragma are listed -- as all blanks, avoiding output of junk line numbers. procedure Output_Msg_Text (E : Error_Msg_Id); -- Outputs characters of text in the text of the error message E. Note that -- no end of line is output, the caller is responsible for adding the end -- of line. If Error_Msg_Line_Length is non-zero, this is the routine that -- splits the line generating multiple lines of output, and in this case -- the last line has no terminating end of line character. procedure Set_Msg_Char (C : Character); -- Add a single character to the current message. This routine does not -- check for special insertion characters (they are just treated as text -- characters if they occur). procedure Set_Msg_Insertion_File_Name; -- Handle file name insertion (left brace insertion character) procedure Set_Msg_Insertion_Name_Literal; procedure Set_Msg_Insertion_Name; -- Handle name insertion (% insertion character) procedure Set_Msg_Insertion_Reserved_Name; -- Handle insertion of reserved word name (* insertion character) procedure Set_Msg_Insertion_Reserved_Word (Text : String; J : in out Integer); -- Handle reserved word insertion (upper case letters). The Text argument -- is the current error message input text, and J is an index which on -- entry points to the first character of the reserved word, and on exit -- points past the last character of the reserved word. Note that RM and -- SPARK are treated specially and not considered to be keywords. procedure Set_Msg_Str (Text : String); -- Add a sequence of characters to the current message. This routine does -- not check for special insertion characters (they are just treated as -- text characters if they occur). It does perform the transformation of -- the special strings _xxx (xxx = Pre/Post/Type_Invariant) to xxx'Class. end GPR.Erroutc; gprbuild-25.0.0/gpr/src/gpr-ext.adb000066400000000000000000000260601470075373400170410ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2000-2022, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with GPR.Names; use GPR.Names; with GPR.Osint; use GPR.Osint; package body GPR.Ext is ---------------- -- Initialize -- ---------------- procedure Initialize (Self : out External_References; Copy_From : External_References := No_External_Refs) is N : Name_To_Name_Ptr; N2 : Name_To_Name_Ptr; begin if Self.Refs = null then Self.Refs := new Name_To_Name_HTable.Instance; if Copy_From.Refs /= null then N := Name_To_Name_HTable.Get_First (Copy_From.Refs.all); while N /= null loop N2 := new Name_To_Name' (Key => N.Key, Value => N.Value, Source => N.Source, Next => null); Name_To_Name_HTable.Set (Self.Refs.all, N2); N := Name_To_Name_HTable.Get_Next (Copy_From.Refs.all); end loop; end if; end if; if Self.Context = null then Self.Context := new Context; end if; end Initialize; --------- -- Add -- --------- procedure Add (Self : External_References; External_Name : String; Value : String; Source : External_Source := External_Source'First; Silent : Boolean := False) is Key : Name_Id; N : Name_To_Name_Ptr; begin -- For external attribute, set the environment variable if Source = From_External_Attribute and then External_Name /= "" then declare Env_Var : String_Access := Getenv (External_Name); begin if Env_Var = null or else Env_Var.all = "" then Setenv (Name => External_Name, Value => Value); if not Silent then Debug_Output ("Environment variable """ & External_Name & """ = """ & Value & '"'); end if; elsif not Silent then Debug_Output ("Not overriding existing environment variable """ & External_Name & """, value is """ & Env_Var.all & '"'); end if; Free (Env_Var); end; end if; Name_Len := External_Name'Length; Name_Buffer (1 .. Name_Len) := External_Name; Canonical_Case_Env_Var_Name (Name_Buffer (1 .. Name_Len)); Key := Name_Find; -- Check whether the value is already defined, to properly respect the -- overriding order. if Source /= External_Source'First then N := Name_To_Name_HTable.Get (Self.Refs.all, Key); if N /= null then if External_Source'Pos (N.Source) < External_Source'Pos (Source) then if not Silent then Debug_Output ("Not overriding existing external reference '" & External_Name & "', value was defined in " & N.Source'Img); end if; return; end if; end if; end if; Name_Len := Value'Length; Name_Buffer (1 .. Name_Len) := Value; N := new Name_To_Name' (Key => Key, Source => Source, Value => Name_Find, Next => null); if not Silent then Debug_Output ("Add external (" & External_Name & ") is", N.Value); end if; Name_To_Name_HTable.Remove (Self.Refs.all, Key); Name_To_Name_HTable.Set (Self.Refs.all, N); end Add; ----------- -- Check -- ----------- function Check (Self : External_References; Declaration : String) return Boolean is begin for Equal_Pos in Declaration'Range loop if Declaration (Equal_Pos) = '=' then exit when Equal_Pos = Declaration'First; Add (Self => Self, External_Name => Declaration (Declaration'First .. Equal_Pos - 1), Value => Declaration (Equal_Pos + 1 .. Declaration'Last), Source => From_Command_Line); return True; end if; end loop; return False; end Check; ----------- -- Reset -- ----------- procedure Reset (Self : External_References) is begin if Self.Refs /= null then Debug_Output ("Reset external references"); Name_To_Name_HTable.Reset (Self.Refs.all); end if; if Self.Context /= null then Self.Context.Clear; end if; end Reset; -------------- -- Value_Of -- -------------- function Value_Of (Self : External_References; External_Name : Name_Id; With_Default : Name_Id := No_Name) return Name_Id is Value : Name_To_Name_Ptr; Val : Name_Id; Name : String := Get_Name_String (External_Name); begin Canonical_Case_Env_Var_Name (Name); if Self.Refs /= null then Value := Name_To_Name_HTable.Get (Self.Refs.all, Get_Name_Id (Name)); if Value /= null and then Value.Source <= From_Environment then Debug_Output ("Value_Of (" & Name & ") is in cache", Value.Value); return Value.Value; end if; end if; -- Find if it is an environment, if it is, put value in the hash table declare Env_Value : String_Access := Getenv (Name); begin if Env_Value /= null and then Env_Value'Length > 0 then Val := Get_Name_Id (Env_Value.all); if Current_Verbosity = High then Debug_Output ("Value_Of (" & Name & ") is", Val); end if; if Self.Refs /= null then Add (Self, Name, Env_Value.all, From_Environment, Silent => True); end if; Free (Env_Value); return Val; else if Current_Verbosity = High then Debug_Output ("Value_Of (" & Name & ") is default", With_Default); end if; Free (Env_Value); return With_Default; end if; end; end Value_Of; ---------- -- Free -- ---------- procedure Free (Self : in out External_References) is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Name_To_Name_HTable.Instance, Instance_Access); procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Name_To_Name, Name_To_Name_Ptr); procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Context, Context_Access); Ptr : Name_To_Name_Ptr; Size : Natural := 0; begin if Self.Refs /= null then Ptr := Name_To_Name_HTable.Get_First (Self.Refs.all); while Ptr /= null loop Size := Size + 1; Ptr := Name_To_Name_HTable.Get_Next (Self.Refs.all); end loop; declare Ptr_Array : array (1 .. Size) of Name_To_Name_Ptr; Idx : Positive := 1; begin Ptr := Name_To_Name_HTable.Get_First (Self.Refs.all); while Ptr /= null loop Ptr_Array (Idx) := Ptr; Ptr := Name_To_Name_HTable.Get_Next (Self.Refs.all); Idx := Idx + 1; end loop; for J in Ptr_Array'Range loop Unchecked_Free (Ptr_Array (J)); end loop; end; Reset (Self); Unchecked_Free (Self.Refs); Unchecked_Free (Self.Context); end if; end Free; -------------- -- Set_Next -- -------------- procedure Set_Next (E : Name_To_Name_Ptr; Next : Name_To_Name_Ptr) is begin E.Next := Next; end Set_Next; ---------- -- Next -- ---------- function Next (E : Name_To_Name_Ptr) return Name_To_Name_Ptr is begin return E.Next; end Next; ------------- -- Get_Key -- ------------- function Get_Key (E : Name_To_Name_Ptr) return Name_Id is begin return E.Key; end Get_Key; ----------------- -- Get_Context -- ----------------- function Get_Context (Self : External_References) return Context is Result : Context; Cur : Context_Map.Cursor; use Context_Map; begin if Self.Context /= null then Cur := Self.Context.First; while Cur /= No_Element loop Result.Include (Key (Cur), Value_Of (Self, Key (Cur), Element (Cur))); Next (Cur); end loop; end if; return Result; end Get_Context; ------------------------- -- Add_Name_To_Context -- ------------------------- procedure Add_Name_To_Context (Self : External_References; External_Name : Name_Id; Default : Name_Id) is Name : String := Get_Name_String (External_Name); begin if Self.Context /= null then Canonical_Case_Env_Var_Name (Name); Self.Context.Include (Get_Name_Id (Name), Default); end if; end Add_Name_To_Context; ------------------- -- Reset_Context -- ------------------- procedure Reset_Context (Self : External_References) is begin if Self.Context /= null then Self.Context.Clear; end if; end Reset_Context; end GPR.Ext; gprbuild-25.0.0/gpr/src/gpr-ext.ads000066400000000000000000000156501470075373400170650ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2000-2022, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- Subprograms to set, get and cache external references, to be used as -- External functions in project files. with Ada.Containers.Ordered_Maps; with GNAT.Dynamic_HTables; package GPR.Ext is ------------------------- -- External References -- ------------------------- -- External references influence the way a project tree is processed (in -- particular they provide the values for the typed string variables that -- are then used in case constructions). -- External references are project-tree specific, so that when multiple -- trees are loaded in parallel we can have different scenarios (or even -- load the same tree twice and see different views of it). type External_References is private; No_External_Refs : constant External_References; procedure Initialize (Self : out External_References; Copy_From : External_References := No_External_Refs); -- Initialize Self, and copy all values from Copy_From if needed. -- This has no effect if Self was already initialized. procedure Free (Self : in out External_References); -- Free memory used by Self type External_Source is (From_Command_Line, From_Environment, From_External_Attribute); -- Indicates where was the value of an external reference defined. They are -- prioritized in that order, so that a user can always use the command -- line to override a value coming from his environment, or an environment -- variable to override a value defined in an aggregate project through the -- "for External()..." attribute. procedure Add (Self : External_References; External_Name : String; Value : String; Source : External_Source := External_Source'First; Silent : Boolean := False); -- Add an external reference (or modify an existing one). No overriding is -- done if the Source's priority is less than the one used to previously -- set the value of the variable. The default for Source is such that -- overriding always occurs. When Silent is True, nothing is output even -- with non default verbosity. function Value_Of (Self : External_References; External_Name : Name_Id; With_Default : Name_Id := No_Name) return Name_Id; -- Get the value of an external reference, and cache it for future uses function Check (Self : External_References; Declaration : String) return Boolean; -- Check that an external declaration = is correct. -- If it is correct, the external reference is Added. procedure Reset (Self : External_References); -- Clear the internal data structure that stores the external references -- and free any allocated memory. package Context_Map is new Ada.Containers.Ordered_Maps (Name_Id, Name_Id); subtype Context is Context_Map.Map; procedure Add_Name_To_Context (Self : External_References; External_Name : Name_Id; Default : Name_Id); -- Adds given external name to the context function Get_Context (Self : External_References) return Context; -- Returns all external references currently stored and their values procedure Reset_Context (Self : External_References); -- Resets Context to empty (but initialized) state. private -- Use a Static_HTable, rather than a Simple_HTable -- The issue is that we need to be able to copy the contents of the table -- (in Initialize), but this isn't doable for Simple_HTable for which -- iterators do not return the key. type Name_To_Name; type Name_To_Name_Ptr is access all Name_To_Name; type Name_To_Name is record Key : Name_Id; Value : Name_Id; Source : External_Source; Next : Name_To_Name_Ptr; end record; procedure Set_Next (E : Name_To_Name_Ptr; Next : Name_To_Name_Ptr); function Next (E : Name_To_Name_Ptr) return Name_To_Name_Ptr; function Get_Key (E : Name_To_Name_Ptr) return Name_Id; package Name_To_Name_HTable is new GNAT.Dynamic_HTables.Static_HTable (Header_Num => Header_Num, Element => Name_To_Name, Elmt_Ptr => Name_To_Name_Ptr, Null_Ptr => null, Set_Next => Set_Next, Next => Next, Key => Name_Id, Get_Key => Get_Key, Hash => Hash, Equal => "="); -- General type for htables associating name_id to name_id. This is in -- particular used to store the values of external references. type Instance_Access is access all Name_To_Name_HTable.Instance; type Context_Access is access all Context; type External_References is record Refs : Instance_Access; -- External references are stored in this hash table (and manipulated -- through subprogrames in prj-ext.ads). External references are -- project-tree specific so that one can load the same tree twice but -- have two views of it, for instance. Context : Context_Access; -- Names of all external references used in project tree end record; No_External_Refs : constant External_References := (Refs => null, Context => null); end GPR.Ext; gprbuild-25.0.0/gpr/src/gpr-jobserver.adb000066400000000000000000000407171470075373400202470ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2023, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with Ada.Directories; with Ada.Environment_Variables; use Ada.Environment_Variables; with Ada.Strings.Fixed; use Ada.Strings.Fixed; with GPR.Debug; with Interfaces.C_Streams; with GPR.Opt; package body GPR.Jobserver is package IC_STR renames Interfaces.C_Streams; HR, HW : File_Descriptor; HRW : File_Descriptor; Current_Implemented_Connection : constant Implemented_Connection_Type := (Named_Pipe => True, Simple_Pipe => True, others => False); procedure Release (Token : Character); -- Release the token to the pipe of the jobserver protected body Task_State_Object is procedure Set (State : Task_State) is begin S := State; end Set; function Get return Task_State is (S); end Task_State_Object; protected body Task_Token_Status_Object is procedure Set (Status : Task_Token_Status) is begin S := Status; end Set; function Get return Task_Token_Status is (S); end Task_Token_Status_Object; protected body Token_Process_State_Object is procedure Set (State : Token_Process_State) is begin S := State; end Set; function Get return Token_Process_State is (S); end Token_Process_State_Object; protected body Sync_Proc_Task_Object is procedure Set (Value : Boolean) is begin V := Value; end Set; function Synced return Boolean is (V); end Sync_Proc_Task_Object; protected body Preorder_Auth_Object is procedure Set (Auth : Boolean) is begin Value := Auth; Is_Set := True; end Set; entry Get (Auth : out Boolean) when Is_Set is begin Auth := Value; Is_Set := False; end Get; end Preorder_Auth_Object; task body Jobserver_Task is Job_Done : Boolean := False; begin loop exit when Job_Done; declare Auth : Boolean; begin Preorder_Auth_Object.Get (Auth); Task_State_Object.Set (Busy); Task_Token_Status_Object.Set (Unknown); Sync_Proc_Task_Object.Set (True); if GPR.Debug.Debug_Flag_J then Ada.Text_IO.Put_Line ("[ Jobserver ] Jobserver_Task unlocked ; Auth = " & Auth'Img); end if; if Auth then if Current_Connection_Method = Simple_Pipe then if not (IC_STR.is_regular_file (IC_STR.int (HR)) = 0) or else not (IC_STR.is_regular_file (IC_STR.int (HW)) = 0) then Task_State_Object.Set (Error); Task_Token_Status_Object.Set (Unknown); Job_Done := True; end if; end if; if not Job_Done then case Current_Connection_Method is when Named_Pipe => if Read (HRW, Char'Address, 1) /= 1 then Task_Token_Status_Object.Set (Unavailable); else Task_Token_Status_Object.Set (Available); end if; when Simple_Pipe => if Read (HR, Char'Address, 1) /= 1 then Task_Token_Status_Object.Set (Unavailable); else Task_Token_Status_Object.Set (Available); end if; when Undefined | Windows_Semaphore => null; end case; end if; if GPR.Debug.Debug_Flag_J then Ada.Text_IO.Put_Line ("[ Jobserver ] Jobserver_Task ended ; Token_Status = " & Task_Token_Status_Object.Get'Img); end if; else Job_Done := True; end if; end; Task_State_Object.Set (Idle); end loop; end Jobserver_Task; -------------- -- Finalize -- -------------- procedure Finalize is begin Preorder_Auth_Object.Set (Auth => False); end Finalize; ---------------- -- Initialize -- ---------------- procedure Initialize is Makeflags : constant String := Value ("MAKEFLAGS", ""); JS_Auth : constant String := "--jobserver-auth="; Simple_Pipe_Delimiter : constant String := ","; Named_Pipe_Delimiter : constant String := "fifo:"; Dry_Run : constant String := "n"; Idx : Natural := 0; procedure Initialize_Connection (Method : Connection_Type); -- Try all known ways to connect to a jobserver --------------------------- -- Initialize_Connection -- --------------------------- procedure Initialize_Connection (Method : Connection_Type) is Idx_Tmp : Natural := Idx; Idx0_Tmp : Natural := 0; begin case Method is when Named_Pipe => Idx_Tmp := Idx_Tmp + JS_Auth'Length; Idx0_Tmp := Index (Makeflags, Named_Pipe_Delimiter, From => Idx_Tmp); if Idx0_Tmp = 0 then return; end if; Idx_Tmp := Idx0_Tmp + Named_Pipe_Delimiter'Length; Idx0_Tmp := Index (Makeflags, " ", From => Idx_Tmp); if Idx0_Tmp = 0 then Idx0_Tmp := Makeflags'Last; else Idx0_Tmp := Idx0_Tmp - 1; end if; if not Ada.Directories.Exists (Makeflags (Idx_Tmp .. Idx0_Tmp)) then return; end if; HRW := Open_Read_Write (Name => Makeflags (Idx_Tmp .. Idx0_Tmp), Fmode => Text); when Simple_Pipe => Idx_Tmp := Idx_Tmp + JS_Auth'Length; Idx0_Tmp := Index (Makeflags, Simple_Pipe_Delimiter, From => Idx_Tmp); if Idx0_Tmp = 0 then return; end if; HR := File_Descriptor'Value (Makeflags (Idx_Tmp .. Idx0_Tmp - 1)); Idx_Tmp := Idx0_Tmp + Simple_Pipe_Delimiter'Length; Idx0_Tmp := Index (Makeflags, " ", From => Idx_Tmp); if Idx0_Tmp = 0 then HW := File_Descriptor'Value (Makeflags (Idx_Tmp .. Makeflags'Last)); else HW := File_Descriptor'Value (Makeflags (Idx_Tmp .. Idx0_Tmp - 1)); end if; if HR < 0 or else HW < 0 then raise JS_Initialize_Error with "Invalid file descriptor to" & " perform a connection to the jobserver. Make sure you" & " prefixed your gprbuild command with a """ & '+' & """ in your makefile."; end if; if not (IC_STR.is_regular_file (IC_STR.int (HR)) = 0) or else not (IC_STR.is_regular_file (IC_STR.int (HW)) = 0) then raise JS_Initialize_Error with "Unable to connect to the" & " jobserver. Make sure you prefixed your gprbuild" & " command with a """ & '+' & """ in your makefile."; end if; when Undefined | Windows_Semaphore => null; end case; Current_Connection_Method := Method; end Initialize_Connection; begin if Makeflags = "" then return; end if; Idx := Index (Makeflags, " "); Idx := Index (Makeflags (Makeflags'First .. Idx - 1), Dry_Run); if Idx /= 0 then raise JS_Makeflags_Parsing_Detects_Dry_Run; end if; Idx := Index (Makeflags, JS_Auth, Going => Ada.Strings.Backward); if Idx = 0 then return; end if; for Connection_Method in Connection_Type loop if Current_Implemented_Connection (Connection_Method) then Initialize_Connection (Method => Connection_Method); end if; exit when Current_Connection_Method /= Undefined; end loop; if GPR.Debug.Debug_Flag_J then Ada.Text_IO.Put_Line ("[ Jobserver ] Makeflags : " & '"' & Makeflags & '"'); Ada.Text_IO.Put_Line ("[ Jobserver ] Connection method : " & Current_Connection_Method'Img); end if; if Current_Connection_Method = Undefined then return; end if; if Opt.Maximum_Compilers > 1 then Ada.Text_IO.Put_Line ("warning: -j is ignored when using GNU make jobserver"); end if; Opt.Use_GNU_Make_Jobserver := True; JS_Task := new Jobserver_Task; end Initialize; -------------------- -- Preorder_Token -- -------------------- procedure Preorder_Token is Preorder_Condition : constant Boolean := (Token_Process_State_Object.Get = Idle or else (Sync_Proc_Task_Object.Synced and then Task_State_Object.Get = Idle and then Task_Token_Status_Object.Get = Unavailable)); begin if GPR.Debug.Debug_Flag_J then Ada.Text_IO.Put_Line ("[ Jobserver ] Preorder_Token"); Ada.Text_IO.Put_Line (" [ Proc ] " & Token_Process_State_Object.Get'Img & " ; Auth = " & Boolean'Image (Preorder_Condition)); Ada.Text_IO.Put_Line (" [ Task ] " & Task_State_Object.Get'Img & " - " & Task_Token_Status_Object.Get'Img); end if; if Preorder_Condition then Sync_Proc_Task_Object.Set (False); Preorder_Auth_Object.Set (Auth => True); Token_Process_State_Object.Set (Pending); if GPR.Debug.Debug_Flag_J then Ada.Text_IO.Put_Line (" [ Proc ] New process state : " & Token_Process_State_Object.Get'Img); end if; end if; end Preorder_Token; ----------------------- -- Register_Token_Id -- ----------------------- procedure Register_Token_Id (Id : GPR.Compilation.Id) is Key : constant String := (if Id.Kind = Local then Pid_To_Integer (Id.Pid)'Img & "-Local" else Id.R_Pid'Img & "-Remote"); begin if GPR.Debug.Debug_Flag_J then Ada.Text_IO.Put_Line ("[ Jobserver ] Register_Token_Id"); Ada.Text_IO.Put_Line (" [ Proc ] " & Token_Process_State_Object.Get'Img); Ada.Text_IO.Put_Line (" [ Task ] " & Task_State_Object.Get'Img & " - " & Task_Token_Status_Object.Get'Img); end if; if Task_Token_Status_Object.Get = Available then Source_Id_Token_Map.Insert (Key, Char); Token_Process_State_Object.Set (Idle); if GPR.Debug.Debug_Flag_J then Ada.Text_IO.Put_Line (" [ Proc ] New process state : " & Token_Process_State_Object.Get'Img); end if; else raise JS_Process_Error with "Tried to register a token when no" & " token was available"; end if; end Register_Token_Id; ------------- -- Release -- ------------- procedure Release (Token : Character) is begin case Current_Connection_Method is when Named_Pipe => if Write (HRW, Token'Address, 1) /= 1 then raise JS_Access_Error with Errno_Message; end if; when Simple_Pipe => if Write (HW, Token'Address, 1) /= 1 then raise JS_Access_Error with Errno_Message; end if; when Undefined | Windows_Semaphore => null; end case; end Release; -------------------------- -- Registered_Processes -- -------------------------- function Registered_Processes return Boolean is (not Source_Id_Token_Map.Is_Empty); ------------------------------ -- Synchronize_Token_Status -- ------------------------------ procedure Monitor is Tmp_Task_State : Task_State; begin Tmp_Task_State := Task_State_Object.Get; if Task_State_Object.Get = Error then raise JS_Access_Error with "Connection to the jobserver have been" & " lost. Make sure you prefixed your gprbuild command with a """ & '+' & """ in your makefile."; end if; if GPR.Debug.Debug_Flag_J then Ada.Text_IO.Put_Line ("[ Jobserver ] Monitor"); Ada.Text_IO.Put_Line (" [ Proc ] " & Token_Process_State_Object.Get'Img); Ada.Text_IO.Put_Line (" [ Task ] " & Tmp_Task_State'Img & " - " & Task_Token_Status_Object.Get'Img); end if; if Task_State_Object.Get = Busy and then Last_Task_State = Busy then Busy_State_Count := Busy_State_Count + 1; if GPR.Debug.Debug_Flag_J then Ada.Text_IO.Put_Line (" [ Info ] Busy_State_Count = " & Busy_State_Count'Img); end if; else Busy_State_Count := 0; end if; Last_Task_State := Tmp_Task_State; end Monitor; ----------------------------- -- Unregister_All_Token_Id -- ----------------------------- procedure Unregister_All_Token_Id is Cursor : Token_Process_Id.Cursor; begin while not Source_Id_Token_Map.Is_Empty loop Cursor := Source_Id_Token_Map.First; Release (Token => Token_Process_Id.Element (Position => Cursor)); Source_Id_Token_Map.Delete (Position => Cursor); end loop; end Unregister_All_Token_Id; ------------------------- -- Unregister_Token_Id -- ------------------------- procedure Unregister_Token_Id (Id : GPR.Compilation.Id) is Key : constant String := (if Id.Kind = Local then Pid_To_Integer (Id.Pid)'Img & "-Local" else Id.R_Pid'Img & "-Remote"); begin if GPR.Debug.Debug_Flag_J then Ada.Text_IO.Put_Line ("[ Jobserver ] Unregister_Token_Id"); end if; Release (Token => Source_Id_Token_Map.Element (Key)); Source_Id_Token_Map.Delete (Key); Busy_State_Count := 0; end Unregister_Token_Id; end GPR.Jobserver; gprbuild-25.0.0/gpr/src/gpr-jobserver.ads000066400000000000000000000143001470075373400202550ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2023, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package manages the communication with GNU make jobserver with Ada.Strings.Hash; with GPR.Compilation; use GPR.Compilation; with Ada.Containers.Indefinite_Hashed_Maps; package GPR.Jobserver is JS_Initialize_Error : exception; -- Error exception raised when jobserver's initialization fails JS_Makeflags_Parsing_Detects_Dry_Run : exception; -- Exception raised when make was invoked with "-n" JS_Access_Error : exception; -- Error exception raised when jobserver's read or write fails JS_Process_Error : exception; -- Error exception raised when jobserver's process fails function Awaiting_Job_Slot return Boolean; -- Returns whether or not we are waiting for a job slot : -- Cached_Token_Status = Pending or Unavailable. function Unavailable_Job_Slot return Boolean; -- Returns whether or not there is no job slot available -- When Current_Connection_Method = Named_Pipe : -- Cached_Token_Status = Pending -- This is because the token retrivial is blocking -- When Current_Connection_Method = Simple_Pipe | Windows_Semaphore : -- Cached_Token_Status = Unavailable procedure Initialize; -- Initialize Jobserver communication procedure Preorder_Token; -- Preorder a token from GNU make Jobserver procedure Register_Token_Id (Id : GPR.Compilation.Id); -- Affiliates the last preordered token to the process Id procedure Unregister_All_Token_Id; -- Free all registered tokens procedure Unregister_Token_Id (Id : GPR.Compilation.Id); -- Release the token affiliated to the process Id function Registered_Processes return Boolean; -- Returns True if there are ongoing processes affiliated with a token, -- returns False if there are not. function Pending_Process return Boolean; -- Returns True if a token have been ordered, -- returns False if not. procedure Monitor; -- Monitor the process status and state. procedure Finalize; -- Finalize Jobserver processes private package Token_Process_Id is new Ada.Containers.Indefinite_Hashed_Maps (String, Character, Ada.Strings.Hash, "="); Source_Id_Token_Map : Token_Process_Id.Map; type Connection_Type is (Undefined, Named_Pipe, Simple_Pipe, Windows_Semaphore); Current_Connection_Method : Connection_Type := Undefined; type Implemented_Connection_Type is array (Connection_Type) of Boolean; type Task_Token_Status is (Unknown, Available, Unavailable); type Task_State is (Idle, Busy, Error); type Token_Process_State is (Idle, Pending); Last_Task_State : Task_State := Idle; Busy_State_Count : Integer := 0; Max_Busy_State_Count : constant := 10; protected Task_State_Object is procedure Set (State : Task_State); function Get return Task_State; private S : Task_State := Idle; end Task_State_Object; protected Task_Token_Status_Object is procedure Set (Status : Task_Token_Status); function Get return Task_Token_Status; private S : Task_Token_Status := Unknown; end Task_Token_Status_Object; protected Token_Process_State_Object is procedure Set (State : Token_Process_State); function Get return Token_Process_State; private S : Token_Process_State := Idle; end Token_Process_State_Object; protected Sync_Proc_Task_Object is procedure Set (Value : Boolean); function Synced return Boolean; private V : Boolean := True; end Sync_Proc_Task_Object; protected Preorder_Auth_Object is procedure Set (Auth : Boolean); entry Get (Auth : out Boolean); private Value : Boolean := False; Is_Set : Boolean := False; end Preorder_Auth_Object; Char : aliased Character := ASCII.NUL; task type Jobserver_Task is end Jobserver_Task; JS_Task : access Jobserver_Task; function Awaiting_Job_Slot return Boolean is (Task_State_Object.Get = Busy or else not Sync_Proc_Task_Object.Synced or else not (Task_Token_Status_Object.Get = Available)); function Unavailable_Job_Slot return Boolean is ((if Current_Connection_Method = Named_Pipe then (Task_State_Object.Get = Busy and then Busy_State_Count >= Max_Busy_State_Count) else (Task_Token_Status_Object.Get = Unavailable))); function Pending_Process return Boolean is (Token_Process_State_Object.Get = Pending); end GPR.Jobserver; gprbuild-25.0.0/gpr/src/gpr-jobserver__win.adb000066400000000000000000000452561470075373400212660ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2023, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with Ada.Directories; with Ada.Environment_Variables; use Ada.Environment_Variables; with Ada.Strings.Fixed; use Ada.Strings.Fixed; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with GPR.Debug; with Interfaces; with Interfaces.C; use Interfaces.C; with Interfaces.C_Streams; with System.Win32; with GPR.Opt; package body GPR.Jobserver is package IC_STR renames Interfaces.C_Streams; type Handle is new Integer; subtype DWord is Interfaces.Unsigned_32; HR, HW : File_Descriptor; HRW : File_Descriptor; Semaphore : Handle; Current_Implemented_Connection : constant Implemented_Connection_Type := (Named_Pipe => True, Simple_Pipe => True, Windows_Semaphore => True, others => False); procedure Release (Token : Character); -- Release the token to the pipe of the jobserver protected body Task_State_Object is procedure Set (State : Task_State) is begin S := State; end Set; function Get return Task_State is (S); end Task_State_Object; protected body Task_Token_Status_Object is procedure Set (Status : Task_Token_Status) is begin S := Status; end Set; function Get return Task_Token_Status is (S); end Task_Token_Status_Object; protected body Token_Process_State_Object is procedure Set (State : Token_Process_State) is begin S := State; end Set; function Get return Token_Process_State is (S); end Token_Process_State_Object; protected body Sync_Proc_Task_Object is procedure Set (Value : Boolean) is begin V := Value; end Set; function Synced return Boolean is (V); end Sync_Proc_Task_Object; protected body Preorder_Auth_Object is procedure Set (Auth : Boolean) is begin Value := Auth; Is_Set := True; end Set; entry Get (Auth : out Boolean) when Is_Set is begin Auth := Value; Is_Set := False; end Get; end Preorder_Auth_Object; task body Jobserver_Task is Job_Done : Boolean := False; use type Interfaces.Unsigned_32; function Wait_For_Object (Semaphore : Handle; Milliseconds : DWord) return DWord with Import, Convention => Stdcall, External_Name => "WaitForSingleObject"; begin loop exit when Job_Done; declare Auth : Boolean; begin Preorder_Auth_Object.Get (Auth); Task_State_Object.Set (Busy); Task_Token_Status_Object.Set (Unknown); Sync_Proc_Task_Object.Set (True); if GPR.Debug.Debug_Flag_J then Ada.Text_IO.Put_Line ("[ Jobserver ] Jobserver_Task unlocked ; Auth = " & Auth'Img); end if; if Auth then if Current_Connection_Method = Simple_Pipe then if not (IC_STR.is_regular_file (IC_STR.int (HR)) = 0) or else not (IC_STR.is_regular_file (IC_STR.int (HW)) = 0) then Task_State_Object.Set (Error); Task_Token_Status_Object.Set (Unknown); Job_Done := True; end if; end if; if not Job_Done then case Current_Connection_Method is when Named_Pipe => if Read (HRW, Char'Address, 1) /= 1 then Task_Token_Status_Object.Set (Unavailable); else Task_Token_Status_Object.Set (Available); end if; when Simple_Pipe => if Read (HR, Char'Address, 1) /= 1 then Task_Token_Status_Object.Set (Unavailable); else Task_Token_Status_Object.Set (Available); end if; when Windows_Semaphore => if Wait_For_Object (Semaphore, 0) /= 0 then Task_Token_Status_Object.Set (Unavailable); else Task_Token_Status_Object.Set (Available); end if; Char := '+'; when Undefined => null; end case; end if; if GPR.Debug.Debug_Flag_J then Ada.Text_IO.Put_Line ("[ Jobserver ] Jobserver_Task ended ; Token_Status = " & Task_Token_Status_Object.Get'Img); end if; else Job_Done := True; end if; end; Task_State_Object.Set (Idle); end loop; end Jobserver_Task; -------------- -- Finalize -- -------------- procedure Finalize is begin Preorder_Auth_Object.Set (Auth => False); end Finalize; ---------------- -- Initialize -- ---------------- procedure Initialize is use type Interfaces.Unsigned_32; Makeflags : constant String := Value ("MAKEFLAGS", ""); JS_Auth : constant String := "--jobserver-auth="; Simple_Pipe_Delimiter : constant String := ","; Named_Pipe_Delimiter : constant String := "fifo:"; Dry_Run : constant String := "n"; function Open_Semaphore (Desired_Access : DWord; Inherit_Handle : Boolean; Name : System.Address) return Handle with Import, Convention => Stdcall, External_Name => "OpenSemaphoreA"; Idx, Idx0 : Natural := 0; procedure Initialize_Connection (Method : Connection_Type); -- Try all known ways to connect to a jobserver --------------------------- -- Initialize_Connection -- --------------------------- procedure Initialize_Connection (Method : Connection_Type) is Idx_Tmp : Natural := Idx; Idx0_Tmp : Natural := Idx0; begin case Method is when Named_Pipe => Idx_Tmp := Idx_Tmp + JS_Auth'Length; Idx0_Tmp := Index (Makeflags, Named_Pipe_Delimiter, From => Idx_Tmp); if Idx0_Tmp = 0 then return; end if; Idx_Tmp := Idx0_Tmp + Named_Pipe_Delimiter'Length; Idx0_Tmp := Index (Makeflags, " ", From => Idx_Tmp); if Idx0_Tmp = 0 then Idx0_Tmp := Makeflags'Last; else Idx0_Tmp := Idx0_Tmp - 1; end if; if not Ada.Directories.Exists (Makeflags (Idx_Tmp .. Idx0_Tmp)) then return; end if; HRW := Open_Read_Write (Name => Makeflags (Idx_Tmp .. Idx0_Tmp), Fmode => Text); when Simple_Pipe => Idx_Tmp := Idx_Tmp + JS_Auth'Length; Idx0_Tmp := Index (Makeflags, Simple_Pipe_Delimiter, From => Idx_Tmp); if Idx0_Tmp = 0 then return; end if; HR := File_Descriptor'Value (Makeflags (Idx_Tmp .. Idx0_Tmp - 1)); Idx_Tmp := Idx0_Tmp + Simple_Pipe_Delimiter'Length; Idx0_Tmp := Index (Makeflags, " ", From => Idx_Tmp); if Idx0_Tmp = 0 then HW := File_Descriptor'Value (Makeflags (Idx_Tmp .. Makeflags'Last)); else HW := File_Descriptor'Value (Makeflags (Idx_Tmp .. Idx0_Tmp - 1)); end if; if HR < 0 or else HW < 0 then raise JS_Initialize_Error with "Invalid file descriptor to" & " perform a connection to the jobserver. Make sure you" & " prefixed your gprbuild command with a """ & '+' & """ in your makefile."; end if; if not (IC_STR.is_regular_file (IC_STR.int (HR)) = 0) or else not (IC_STR.is_regular_file (IC_STR.int (HW)) = 0) then raise JS_Initialize_Error with "Unable to connect to the" & " jobserver. Make sure you prefixed your gprbuild" & " command with a """ & '+' & """ in your makefile."; end if; when Windows_Semaphore => Idx_Tmp := Idx_Tmp + JS_Auth'Length; Idx0_Tmp := Index (Makeflags, " ", From => Idx_Tmp); if Idx0 = 0 then Idx0_Tmp := Makeflags'Last; else Idx0_Tmp := Idx0_Tmp + 1; end if; declare Sem_Name : constant String := Makeflags (Idx_Tmp .. Idx0_Tmp) & ASCII.NUL; begin Semaphore := Open_Semaphore (16#1F0003#, False, Sem_Name'Address); if Semaphore = 0 then return; end if; end; when Undefined => null; end case; Current_Connection_Method := Method; end Initialize_Connection; begin if Makeflags = "" then return; end if; Idx := Index (Makeflags, " "); Idx := Index (Makeflags (Makeflags'First .. Idx - 1), Dry_Run); if Idx /= 0 then raise JS_Makeflags_Parsing_Detects_Dry_Run; end if; Idx := Index (Makeflags, JS_Auth, Going => Ada.Strings.Backward); if Idx = 0 then return; end if; for Connection_Method in Connection_Type loop if Current_Implemented_Connection (Connection_Method) then Initialize_Connection (Method => Connection_Method); end if; exit when Current_Connection_Method /= Undefined; end loop; if GPR.Debug.Debug_Flag_J then Ada.Text_IO.Put_Line ("[ Jobserver ] Makeflags : " & '"' & Makeflags & '"'); Ada.Text_IO.Put_Line ("[ Jobserver ] Connection method : " & Current_Connection_Method'Img); end if; if Current_Connection_Method = Undefined then return; end if; if Opt.Maximum_Compilers > 1 then Ada.Text_IO.Put_Line ("warning: -j is ignored when using GNU make jobserver"); end if; Opt.Use_GNU_Make_Jobserver := True; JS_Task := new Jobserver_Task; end Initialize; -------------------- -- Preorder_Token -- -------------------- procedure Preorder_Token is Preorder_Condition : constant Boolean := (Token_Process_State_Object.Get = Idle or else (Sync_Proc_Task_Object.Synced and then Task_State_Object.Get = Idle and then Task_Token_Status_Object.Get = Unavailable)); begin if GPR.Debug.Debug_Flag_J then Ada.Text_IO.Put_Line ("[ Jobserver ] Preorder_Token"); Ada.Text_IO.Put_Line (" [ Proc ] " & Token_Process_State_Object.Get'Img & " ; Auth = " & Boolean'Image (Preorder_Condition)); Ada.Text_IO.Put_Line (" [ Task ] " & Task_State_Object.Get'Img & " - " & Task_Token_Status_Object.Get'Img); end if; if Preorder_Condition then Sync_Proc_Task_Object.Set (False); Preorder_Auth_Object.Set (Auth => True); Token_Process_State_Object.Set (Pending); if GPR.Debug.Debug_Flag_J then Ada.Text_IO.Put_Line (" [ Proc ] New process state : " & Token_Process_State_Object.Get'Img); end if; end if; end Preorder_Token; ----------------------- -- Register_Token_Id -- ----------------------- procedure Register_Token_Id (Id : GPR.Compilation.Id) is Key : constant String := (if Id.Kind = Local then Pid_To_Integer (Id.Pid)'Img & "-Local" else Id.R_Pid'Img & "-Remote"); begin if GPR.Debug.Debug_Flag_J then Ada.Text_IO.Put_Line ("[ Jobserver ] Register_Token_Id"); Ada.Text_IO.Put_Line (" [ Proc ] " & Token_Process_State_Object.Get'Img); Ada.Text_IO.Put_Line (" [ Task ] " & Task_State_Object.Get'Img & " - " & Task_Token_Status_Object.Get'Img); end if; if Task_Token_Status_Object.Get = Available then Source_Id_Token_Map.Insert (Key, Char); Token_Process_State_Object.Set (Idle); if GPR.Debug.Debug_Flag_J then Ada.Text_IO.Put_Line (" [ Proc ] New process state : " & Token_Process_State_Object.Get'Img); end if; else raise JS_Process_Error with "Tried to register a token when no" & " token was available"; end if; end Register_Token_Id; ------------- -- Release -- ------------- procedure Release (Token : Character) is function Release_Semaphore (Semaphore : Handle; Release_Count : Long_Integer; Previous_Count : access Long_Integer) return Boolean with Import, Convention => Stdcall, External_Name => "ReleaseSemaphore"; begin case Current_Connection_Method is when Named_Pipe => if Write (HRW, Token'Address, 1) /= 1 then raise JS_Access_Error with Errno_Message; end if; when Simple_Pipe => if Write (HW, Token'Address, 1) /= 1 then raise JS_Access_Error with Errno_Message; end if; when Windows_Semaphore => if not Release_Semaphore (Semaphore, 1, null) then raise JS_Access_Error with Errno_Message; end if; when Undefined => null; end case; end Release; -------------------------- -- Registered_Processes -- -------------------------- function Registered_Processes return Boolean is (not Source_Id_Token_Map.Is_Empty); ------------------------------ -- Synchronize_Token_Status -- ------------------------------ procedure Monitor is Tmp_Task_State : Task_State; begin Tmp_Task_State := Task_State_Object.Get; if Task_State_Object.Get = Error then raise JS_Access_Error with "Connection to the jobserver have been" & " lost. Make sure you prefixed your gprbuild command with a """ & '+' & """ in your makefile."; end if; if GPR.Debug.Debug_Flag_J then Ada.Text_IO.Put_Line ("[ Jobserver ] Monitor"); Ada.Text_IO.Put_Line (" [ Proc ] " & Token_Process_State_Object.Get'Img); Ada.Text_IO.Put_Line (" [ Task ] " & Tmp_Task_State'Img & " - " & Task_Token_Status_Object.Get'Img); end if; if Task_State_Object.Get = Busy and then Last_Task_State = Busy then Busy_State_Count := Busy_State_Count + 1; if GPR.Debug.Debug_Flag_J then Ada.Text_IO.Put_Line (" [ Info ] Busy_State_Count = " & Busy_State_Count'Img); end if; else Busy_State_Count := 0; end if; Last_Task_State := Tmp_Task_State; end Monitor; ----------------------------- -- Unregister_All_Token_Id -- ----------------------------- procedure Unregister_All_Token_Id is Cursor : Token_Process_Id.Cursor; begin while not Source_Id_Token_Map.Is_Empty loop Cursor := Source_Id_Token_Map.First; Release (Token => Token_Process_Id.Element (Position => Cursor)); Source_Id_Token_Map.Delete (Position => Cursor); end loop; end Unregister_All_Token_Id; ------------------------- -- Unregister_Token_Id -- ------------------------- procedure Unregister_Token_Id (Id : GPR.Compilation.Id) is Key : constant String := (if Id.Kind = Local then Pid_To_Integer (Id.Pid)'Img & "-Local" else Id.R_Pid'Img & "-Remote"); begin if GPR.Debug.Debug_Flag_J then Ada.Text_IO.Put_Line ("[ Jobserver ] Unregister_Token_Id"); end if; Release (Token => Source_Id_Token_Map.Element (Key)); Source_Id_Token_Map.Delete (Key); Busy_State_Count := 0; end Unregister_Token_Id; end GPR.Jobserver; gprbuild-25.0.0/gpr/src/gpr-knowledge.adb000066400000000000000000005310721470075373400202240ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2006-2022, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Command_Line; use Ada.Command_Line; with Ada.Containers.Indefinite_Hashed_Maps; use Ada.Containers; with Ada.Strings.Hash; with Ada.Directories; use Ada.Directories; with Ada.Environment_Variables; use Ada.Environment_Variables; with Ada.Exceptions; use Ada.Exceptions; with Ada.IO_Exceptions; with Ada.Strings.Fixed; use Ada.Strings.Fixed; with Ada.Strings.Hash_Case_Insensitive; with Ada.Text_IO; use Ada.Text_IO; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.Expect; use GNAT.Expect; with GNAT.Regpat; use GNAT.Regpat; with GNAT.Strings; use GNAT.Strings; with DOM.Core.Documents; use DOM.Core; with DOM.Core.Nodes; use DOM.Core.Nodes; with Input_Sources.File; use Input_Sources.File; with Sax.Readers; use Sax.Readers; with Schema.Dom_Readers; use Schema.Dom_Readers; with Schema.Schema_Readers; use Schema.Schema_Readers; with Schema.Validators; use Schema.Validators; with GPR.Sdefault; use GPR.Sdefault; with GPR.Names; use GPR.Names; with GPR.Opt; with GPR.Util; use GPR.Util; package body GPR.Knowledge is package Known_Languages renames Variables_Maps; Languages_Known : Known_Languages.Map; -- Contains all the languages that are described in the database with a -- real compiler. package String_Maps is new Ada.Containers.Indefinite_Hashed_Maps (String, Unbounded_String, Ada.Strings.Hash_Case_Insensitive, "="); procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Pattern_Matcher, Pattern_Matcher_Access); type External_Value_Item is record Value : Name_Id; Alternate : Name_Id := No_Name; Extracted_From : Name_Id; end record; -- Value is the actual value of the node. -- Extracted_From will either be set to Value itself, or when the node is -- a to the full directory, before the regexp match. -- When the value comes from a node, Extracted_From is set to the -- full output of the shell command. package External_Value_Lists is new Ada.Containers.Doubly_Linked_Lists (External_Value_Item); package String_To_External_Value is new Ada.Containers.Indefinite_Hashed_Maps (Key_Type => String, Element_Type => External_Value_Lists.Cursor, Hash => Ada.Strings.Hash, Equivalent_Keys => "=", "=" => External_Value_Lists."="); External_Calls_Cache : String_Maps.Map := String_Maps.Empty_Map; package CDM renames Compiler_Description_Maps; package CFL renames Compiler_Filter_Lists; use Compiler_Lists, CFL, Compilers_Filter_Lists; use Configuration_Lists, String_Maps; use External_Value_Lists, String_Lists; use External_Value_Nodes; Case_Sensitive_Files : constant Boolean := Directory_Separator = '\'; On_Windows : constant Boolean := Directory_Separator = '\'; Ignore_Compiler : exception; -- Raised when the compiler should be ignored Indentation_Level : Integer := 0; -- Current indentation level for traces function Get_Variable_Value (Comp : Compiler; Name : String) return String; -- Return the value of a predefined or user-defined variable. -- If the variable is not defined a warning is emitted and an empty -- string is returned. procedure Put_Verbose (Config : Configuration); -- Debug put for Config function Get_Attribute (N : Node; Attribute : String; Default : String) return String; -- Return the value of an attribute, or Default if the attribute does not -- exist function Is_Supported_Config (Base : Knowledge_Base; Compilers : Compiler_Lists.List) return Boolean; -- Whether we know how to link code compiled with all the selected -- compilers. function Is_Language_With_No_Compiler (Base : Knowledge_Base; Language_LC : String) return Boolean; -- Given a language name (lower case), returns True if that language is -- known to require no compiler function Node_Value_As_String (N : Node) return String; -- Return the value of the node, concatenating all Text children procedure Foreach_Compiler_In_Dir (Iterator : in out Compiler_Iterator'Class; Base : in out Knowledge_Base; Directory : String; From_Extra_Dir : Boolean; On_Target : Targets_Set_Id; Path_Order : Integer; Continue : out Boolean); -- Find all known compilers in Directory, and call Iterator.Callback as -- appropriate. procedure Get_Words (Words : String; Filter : Name_Id; Separator1 : Character; Separator2 : Character; Map : out String_Lists.List; Allow_Empty_Elements : Boolean); -- Return the list of words in Words. Splitting is done on special -- characters, so as to be compatible with a list of languages or a list of -- runtimes -- If Allow_Empty_Elements is false, then empty strings are not stored in -- the list. function Name_As_Directory (Dir : String) return String; -- Ensure that Dir ends with a directory separator function Get_String_No_Adalib (Str : String) return Name_Id; -- Return the name without "adalib" at the end function Get_String (Str : String) return Name_Id; function Get_String_Or_No_Name (Str : String) return Name_Id; -- Same as Name_Find, but does not require the user to modify -- Name_Buffer manually. -- The second version returns No_Name is the string is empty procedure Get_External_Value (Attribute : String; Value : External_Value; Comp : Compiler; Split_Into_Words : Boolean := True; Merge_Same_Dirs : Boolean := False; Processed_Value : out External_Value_Lists.List); -- Computes the value of Value, depending on its type. When an external -- command needs to be executed, Path is put first on the PATH environment -- variable. -- Raises Ignore_Compiler if the value doesn't match its -- regexp. -- The node is also taken into account. -- If Split_Into_Words is true, then the value read from or as a -- constant string is further assumed to be a comma-separated or space- -- separated string, and split. -- Comparisong with Matching is case-insensitive (this is needed for -- languages, does not matter for versions, is not used for targets) -- -- If Merge_Same_Dirs is True, then the values that come from a -- node will be merged (the last one is kept, other removed) if -- they point to the same physical directory (after normalizing names). -- -- This is only for use within a context. procedure Foreach_Language_Runtime (Iterator : in out Compiler_Iterator'Class; Base : in out Knowledge_Base; Name : Name_Id; Executable : Name_Id; Directory : String; Prefix : Name_Id; From_Extra_Dir : Boolean; On_Target : Targets_Set_Id; Descr : Compiler_Description; Path_Order : Integer; Continue : out Boolean); -- For each language/runtime parsed in Languages/Runtimes, create a new -- compiler in the list, if it matches Matching. -- If Stop_At_First_Match is true, then only the first matching compiler is -- returned, which provides a significant speedup in some cases function Is_Windows_Executable (Filename : String) return Boolean; -- Verify that a given filename is indeed an executable procedure Parse_All_Dirs (Processed_Value : out External_Value_Lists.List; Visited : in out String_To_External_Value.Map; Current_Dir : String; Path_To_Check : String; Regexp : Pattern_Matcher; Regexp_Str : String; Value_If_Match : Name_Id; Group : Integer; Group_Match : String := ""; Group_Count : Natural := 0; Contents : Pattern_Matcher_Access := null; Merge_Same_Dirs : Boolean); -- Parse all subdirectories of Current_Dir for those that match -- Path_To_Check (see description of ). When a match is found, -- the regexp is evaluated against the current directory, and the matching -- parenthesis group is appended to Append_To (comma-separated). -- If Group is -1, then Value_If_Match is used instead of the parenthesis -- group. -- Group_Match is the substring that matched Group (if it has been matched -- already). Group_Count is the number of parenthesis groups that have been -- processed so far. The idea is to compute the matching substring as we -- go, since the regexp might no longer match in the end, if for instance -- it includes ".." directories. -- -- If Merge_Same_Dirs is True, then the values that come from a -- node will be merged (the last one is kept, other removed) if -- they point to the same physical directory (after normalizing names). In -- this case, Visited contains the list of normalized directory names. -- -- Contents, if specified, is a regular expression. It indicates that any -- file matching the pattern should be parsed, and the first line matching -- that regexp should be used as the name of the file instead. This is a -- way to simulate symbolic links on platforms that do not use them. generic with function Callback (Var_Name, Index : String) return String; function Substitute_Variables (Str : String) return String; -- Substitute variables in Str (their value is computed through Callback) function Substitute_Variables_In_Compiler_Description (Str : String; Comp : Compiler) return String; function Substitute_Variables_In_Configuration (Base : Knowledge_Base; Str : String; Comps : Compiler_Lists.List) return String; -- Substitute the special "$..." names. -- Depending on the XML nodes we are in (specified by the context) the list -- of variables might be different. procedure Match (Filter : Compilers_Filter_Lists.List; Compilers : Compiler_Lists.List; Matching_Compiler : out Compiler_Access; Matched : out Boolean); procedure Match (Filter : Compilers_Filter; Compilers : Compiler_Lists.List; Matching_Compiler : out Compiler_Access; Matched : out Boolean); procedure Match (Filter : Compiler_Filter; Compilers : Compiler_Lists.List; Matching_Compiler : out Compiler_Access; Matched : out Boolean); -- Check whether Filter matches (and set Matched to the result). -- Matching_Compiler is set if there was a single node, and is -- to set the first compiler that matched in that node function Match (Target_Filter : Double_String_Lists.List; Negate : Boolean; Compilers : Compiler_Lists.List) return Boolean; -- Return True if Filter matches the list of selected configurations procedure Merge_Config (Base : Knowledge_Base; Packages : in out String_Maps.Map; Compilers : Compiler_Lists.List; Config : String); -- Merge the contents of Config into Packages, so that each attributes ends -- up in the right package, and the packages are not duplicated. -- Selected_Compiler is the compiler that made the chunk match the filters. -- If there were several filter, No_Compiler should be passed -- in argument. procedure Skip_Spaces (Str : String; Index : in out Integer); -- Move Index from its current position to the next non-whitespace -- character in Str procedure Skip_Spaces_Backward (Str : String; Index : in out Integer); -- Same as Skip_Spaces, but goes backward function Is_Regexp (Str : String) return Boolean; -- Whether Str is a regular expression Exec_Suffix : constant GNAT.Strings.String_Access := Get_Executable_Suffix; function Unquote (Str : String; Remove_Quoted : Boolean := False) return String; -- Remove special '\' quoting characters from Str. -- As a special case, if Remove_Quoted is true, then '\' and the following -- char are simply omitted in the output. -- For instance: -- Str="A\." Remove_Quoted=False => output is "A." -- Str="A\." Remove_Quoted=False => output is "A" procedure Free (Descr : in out Compiler_Description); procedure Free (Config : in out Configuration); procedure Free (TSD : in out Target_Set_Description); procedure Free (Ext_Val : in out External_Value_Node); ------------------- -- Get_Attribute -- ------------------- function Get_Attribute (N : Node; Attribute : String; Default : String) return String is Attr : constant Node := Get_Named_Item (Attributes (N), Attribute); begin if Attr = null then return Default; else return Node_Value (Attr); end if; end Get_Attribute; -------------------------- -- Node_Value_As_String -- -------------------------- function Node_Value_As_String (N : Node) return String is Result : Unbounded_String; Child : Node := First_Child (N); begin while Child /= null loop exit when Node_Type (Child) = Element_Node; Append (Result, Node_Value (Child)); Child := Next_Sibling (Child); end loop; return To_String (Result); end Node_Value_As_String; ------------- -- Unquote -- ------------- function Unquote (Str : String; Remove_Quoted : Boolean := False) return String is Str2 : String (Str'Range); S : Integer := Str'First; Index : Integer := Str2'First; begin while S <= Str'Last loop if Str (S) = '\' then S := S + 1; if not Remove_Quoted then Str2 (Index) := Str (S); Index := Index + 1; end if; else Str2 (Index) := Str (S); Index := Index + 1; end if; S := S + 1; end loop; return Str2 (Str2'First .. Index - 1); end Unquote; --------------------------- -- Is_Windows_Executable -- --------------------------- function Is_Windows_Executable (Filename : String) return Boolean is type Byte is mod 256; for Byte'Size use 8; for Byte'Alignment use 1; type Bytes is array (Positive range <>) of Byte; Windows_Pattern : constant Bytes := (77, 90, 144, 0); Fd : constant File_Descriptor := Open_Read (Filename, Binary); B : Bytes (1 .. 4); N_Read : Integer; begin N_Read := Read (Fd, B'Address, 4); Close (Fd); if N_Read < 4 then return False; else if B = Windows_Pattern then return True; else return False; end if; end if; end Is_Windows_Executable; --------------- -- Is_Regexp -- --------------- function Is_Regexp (Str : String) return Boolean is -- Take into account characters quoted by '\'. We just remove them for -- now, so that when we quote the regexp it won't see these potentially -- special characters. -- The goal is that for instance "\.\." is not considered as a regexp, -- but "\.." is. Str2 : constant String := Unquote (Str, Remove_Quoted => True); begin return GNAT.Regpat.Quote (Str2) /= Str2; end Is_Regexp; ----------------- -- Put_Verbose -- ----------------- procedure Put_Verbose (Str : String; Indent_Delta : Integer := 0) is begin if Current_Verbosity /= Default then if Indent_Delta < 0 then Indentation_Level := Indentation_Level - 2; end if; if Str /= "" then Put_Line (Standard_Error, (1 .. Indentation_Level => ' ') & Str); end if; if Indent_Delta > 0 then Indentation_Level := Indentation_Level + 2; end if; end if; end Put_Verbose; ----------------------- -- Name_As_Directory -- ----------------------- function Name_As_Directory (Dir : String) return String is begin if Dir = "" or else Dir (Dir'Last) = Directory_Separator or else Dir (Dir'Last) = '/' then return Dir; else return Dir & Directory_Separator; end if; end Name_As_Directory; ---------------------------------- -- Is_Language_With_No_Compiler -- ---------------------------------- function Is_Language_With_No_Compiler (Base : Knowledge_Base; Language_LC : String) return Boolean is C : String_Lists.Cursor := First (Base.No_Compilers); begin while Has_Element (C) loop if String_Lists.Element (C) = Language_LC then return True; end if; Next (C); end loop; return False; end Is_Language_With_No_Compiler; RTS_List : GNAT.OS_Lib.String_List_Access := new GNAT.OS_Lib.String_List (1 .. 4); -- List of the knowledge base directories that have already been parsed RTS_Last : Natural := 0; -- Index of the last directory in RTS_List -------------------------- -- Parse_Knowledge_Base -- -------------------------- procedure Parse_Knowledge_Base (Base : in out Knowledge_Base; Directory : String; Parse_Compiler_Info : Boolean := True; Validate : Boolean := False) is procedure Parse_Compiler_Description (Base : in out Knowledge_Base; File : String; Description : Node); -- Parse a compiler description described by N. Appends the result to -- Base.Compilers or Base.No_Compilers procedure Parse_Configuration (Append_To : in out Configuration_Lists.List; File : String; Description : Node); -- Parse a configuration node procedure Parse_Targets_Set (Append_To : in out Targets_Set_Vectors.Vector; File : String; Description : Node); -- Parse a targets set node procedure Parse_Fallback_Targets_Set (Append_To : in out Fallback_Targets_Set_Vectors.Vector; File : String; Description : Node); -- Parse a fallback_targets set node -------------------------------- -- Parse_Compiler_Description -- -------------------------------- procedure Parse_Compiler_Description (Base : in out Knowledge_Base; File : String; Description : Node) is procedure Parse_External_Value (Value : out External_Value; File : String; External : Node); -- Parse an XML node that describes an external value -------------------------- -- Parse_External_Value -- -------------------------- procedure Parse_External_Value (Value : out External_Value; File : String; External : Node) is Tmp : Node := First_Child (External); External_Node : External_Value_Node; Is_Done : Boolean := True; Static_Value : constant String := Node_Value_As_String (External); Has_Static : Boolean := False; begin for S in Static_Value'Range loop if Static_Value (S) /= ' ' and then Static_Value (S) /= ASCII.LF then Has_Static := True; exit; end if; end loop; -- Constant value is not within a nested node if Has_Static then External_Node := (Typ => Value_Constant, Value => Get_String (Static_Value)); Append (Value, External_Node); Is_Done := False; end if; while Tmp /= null loop if Node_Type (Tmp) /= Element_Node then null; elsif Node_Name (Tmp) = "external" then if not Is_Done then Append (Value, (Typ => Value_Done)); end if; External_Node := (Typ => Value_Shell, Command => Get_String (Node_Value_As_String (Tmp))); Append (Value, External_Node); Is_Done := False; elsif Node_Name (Tmp) = "directory" then declare C : constant String := Get_Attribute (Tmp, "contents", ""); Contents : Pattern_Matcher_Access; begin if C /= "" then Contents := new Pattern_Matcher'(Compile (C)); end if; External_Node := (Typ => Value_Directory, Directory => Get_String (Node_Value_As_String (Tmp)), Contents => Contents, Dir_If_Match => No_Name, Directory_Group => 0); end; begin External_Node.Directory_Group := Integer'Value (Get_Attribute (Tmp, "group", "0")); exception when Constraint_Error => External_Node.Directory_Group := -1; External_Node.Dir_If_Match := Get_String (Get_Attribute (Tmp, "group", "0")); end; Append (Value, External_Node); Is_Done := True; elsif Node_Name (Tmp) = "getenv" then if not Is_Done then Append (Value, (Typ => Value_Done)); end if; declare Name : constant String := Get_Attribute (Tmp, "name", ""); begin if Ada.Environment_Variables.Exists (Name) then External_Node := (Typ => Value_Constant, Value => Get_String (Ada.Environment_Variables.Value (Name))); else Put_Verbose ("warning: environment variable '" & Name & "' is not defined"); External_Node := (Typ => Value_Constant, Value => No_Name); end if; end; Append (Value, External_Node); Is_Done := False; elsif Node_Name (Tmp) = "filter" then External_Node := (Typ => Value_Filter, Filter => Get_String (Node_Value_As_String (Tmp))); Append (Value, External_Node); Is_Done := True; elsif Node_Name (Tmp) = "must_match" then External_Node := (Typ => Value_Must_Match, Must_Match => Get_String (Node_Value_As_String (Tmp))); Append (Value, External_Node); Is_Done := True; elsif Node_Name (Tmp) = "grep" then External_Node := (Typ => Value_Grep, Regexp_Re => new Pattern_Matcher' (Compile (Get_Attribute (Tmp, "regexp", ".*"), Multiple_Lines)), Group => Integer'Value (Get_Attribute (Tmp, "group", "0"))); Append (Value, External_Node); elsif Node_Name (Tmp) = "nogrep" then External_Node := (Typ => Value_Nogrep, Regexp_No => new Pattern_Matcher' (Compile (Get_Attribute (Tmp, "regexp", ".*"), Multiple_Lines))); Append (Value, External_Node); else Put_Line (Standard_Error, "Invalid XML description for " & Node_Name (External) & " in file " & File); Put_Line (Standard_Error, " Invalid tag: " & Node_Name (Tmp)); Value := Null_External_Value; end if; Tmp := Next_Sibling (Tmp); end loop; if not Is_Done then Append (Value, (Typ => Value_Done)); end if; exception when Constraint_Error => Put_Line (Standard_Error, "Invalid group number for " & Node_Name (External) & " in file " & File); Value := Null_External_Value; end Parse_External_Value; Compiler : Compiler_Description; N : Node := First_Child (Description); Lang : External_Value_Lists.List; C : External_Value_Lists.Cursor; begin while N /= null loop if Node_Type (N) /= Element_Node then null; elsif Node_Name (N) = "executable" then declare Prefix : constant String := Get_Attribute (N, "prefix", "@@"); Val : constant String := Node_Value_As_String (N); begin if Val = "" then -- A special language that requires no executable. We do -- not store it in the list of compilers, since these -- should not be detected on the PATH anyway. Compiler.Executable := No_Name; else Compiler.Executable := Get_String (Val); begin Compiler.Prefix_Index := Integer'Value (Prefix); exception when Constraint_Error => Compiler.Prefix_Index := -1; end; if not Ends_With (Val, Exec_Suffix.all) then Compiler.Executable_Re := new Pattern_Matcher' (Compile ("^" & Val & Exec_Suffix.all & "$")); else Compiler.Executable_Re := new Pattern_Matcher' (Compile ("^" & Val & "$")); end if; Base.Check_Executable_Regexp := True; end if; exception when Expression_Error => Put_Line (Standard_Error, "Invalid regular expression found in the configuration" & " files: " & Val & " while parsing " & File); Unchecked_Free (Compiler.Executable_Re); end; elsif Node_Name (N) = "name" then Compiler.Name := Get_String (Node_Value_As_String (N)); elsif Node_Name (N) = "version" then Parse_External_Value (Value => Compiler.Version, File => File, External => N); elsif Node_Name (N) = "variable" then declare Name : constant String := Get_Attribute (N, "name", "@@"); begin Append (Compiler.Variables, (Typ => Value_Variable, Var_Name => Get_String (Name))); Parse_External_Value (Value => Compiler.Variables, File => File, External => N); end; elsif Node_Name (N) = "languages" then Parse_External_Value (Value => Compiler.Languages, File => File, External => N); elsif Node_Name (N) = "runtimes" then declare Defaults : constant String := Get_Attribute (N, "default", ""); begin if Defaults /= "" then Get_Words (Defaults, No_Name, ' ', ',', Compiler.Default_Runtimes, False); end if; Parse_External_Value (Value => Compiler.Runtimes, File => File, External => N); end; elsif Node_Name (N) = "target" then Parse_External_Value (Value => Compiler.Target, File => File, External => N); else Put_Line (Standard_Error, "Unknown XML tag in " & File & ": " & Node_Name (N)); raise Invalid_Knowledge_Base; end if; N := Next_Sibling (N); end loop; if Compiler.Executable = No_Name then Get_External_Value (Attribute => "languages", Value => Compiler.Languages, Comp => No_Compiler, Split_Into_Words => True, Processed_Value => Lang); C := First (Lang); while Has_Element (C) loop String_Lists.Append (Base.No_Compilers, To_Lower (Get_Name_String (External_Value_Lists.Element (C).Value))); Next (C); end loop; elsif Compiler.Name /= No_Name then CDM.Include (Base.Compilers, Compiler.Name, Compiler); -- Include the language name in the Languages_Known hashed map, -- if it is not already there. Get_External_Value (Attribute => "languages", Value => Compiler.Languages, Comp => No_Compiler, Split_Into_Words => True, Processed_Value => Lang); C := First (Lang); while Has_Element (C) loop declare Lang_Name : constant Name_Id := Get_Lower_Name_Id (Get_Name_String (External_Value_Lists.Element (C).Value)); Position : Known_Languages.Cursor; Inserted : Boolean; begin Languages_Known.Insert (Key => Lang_Name, New_Item => Lang_Name, Position => Position, Inserted => Inserted); end; Next (C); end loop; end if; end Parse_Compiler_Description; ------------------------- -- Parse_Configuration -- ------------------------- procedure Parse_Configuration (Append_To : in out Configuration_Lists.List; File : String; Description : Node) is Config : Configuration; Chunk : Unbounded_String; N : Node := First_Child (Description); N2 : Node; Compilers : Compilers_Filter; Ignore_Config : Boolean := False; Negate : Boolean; Filter : Compiler_Filter; function Compile_And_Check (Name : String) return Pattern_Matcher; -- Compile pattern and report illegal regexp if needed. function Compile_And_Check (Name : String) return Pattern_Matcher is begin return Compile (Name, GNAT.Regpat.Case_Insensitive); exception when Expression_Error => Put_Line (Standard_Error, "gprconfig: invalid regexp '" & Name & "' in " & File & "; corresponding configuration " & "node skipped"); raise; end Compile_And_Check; begin Config.Supported := True; while N /= null loop if Node_Type (N) /= Element_Node then null; elsif Node_Name (N) = "compilers" then Compilers := No_Compilers_Filter; N2 := First_Child (N); while N2 /= null loop if Node_Type (N2) /= Element_Node then null; elsif Node_Name (N2) = "compiler" then declare Name : constant String := Get_Attribute (N2, "name", ""); Version : constant String := Get_Attribute (N2, "version", ""); Runtime : constant String := Get_Attribute (N2, "runtime", ""); begin Filter := Compiler_Filter' (Name => Get_String_Or_No_Name (Name), Name_Re => null, Version => Get_String_Or_No_Name (Version), Version_Re => null, Runtime => Get_String_Or_No_Name (Runtime), Runtime_Re => null, Language_LC => Get_String_Or_No_Name (To_Lower (Get_Attribute (N2, "language", "")))); -- We do not want to invalidate the whole Knowledge -- Base because of a wrong regexp. Istead, report it -- and skip corresponding node. if Name /= "" then Filter.Name_Re := new Pattern_Matcher' (Compile_And_Check (Name)); end if; if Version /= "" then Filter.Version_Re := new Pattern_Matcher' (Compile_And_Check (Version)); end if; if Runtime /= "" then Filter.Runtime_Re := new Pattern_Matcher' (Compile_And_Check (Runtime)); end if; end; Append (Compilers.Compiler, Filter); else Put_Line (Standard_Error, "Unknown XML tag in " & File & ": " & Node_Name (N2)); raise Invalid_Knowledge_Base; end if; N2 := Next_Sibling (N2); end loop; Compilers.Negate := Boolean'Value (Get_Attribute (N, "negate", "False")); Append (Config.Compilers_Filters, Compilers); elsif Node_Name (N) = "targets" then if not Is_Empty (Config.Targets_Filters) then Put_Line (Standard_Error, "Can have a single filter in " & File); else N2 := First_Child (N); while N2 /= null loop if Node_Type (N2) /= Element_Node then null; elsif Node_Name (N2) = "target" then declare Double_Regexp : Double_String; begin Double_Regexp.Positive_Regexp := To_Unbounded_String (Get_Attribute (N2, "name", "")); Double_Regexp.Negative_Regexp := To_Unbounded_String (Get_Attribute (N2, "except", "")); Append (Config.Targets_Filters, Double_Regexp); end; else Put_Line (Standard_Error, "Unknown XML tag in " & File & ": " & Node_Name (N2)); raise Invalid_Knowledge_Base; end if; N2 := Next_Sibling (N2); end loop; Config.Negate_Targets := Boolean'Value (Get_Attribute (N, "negate", "False")); end if; elsif Node_Name (N) = "hosts" then -- Resolve this filter immediately. This saves memory, since we -- don't need to store it in memory if we know it won't apply. N2 := First_Child (N); Negate := Boolean'Value (Get_Attribute (N, "negate", "False")); Ignore_Config := not Negate; while N2 /= null loop if Node_Type (N2) /= Element_Node then null; elsif Node_Name (N2) = "host" then if Match (Get_Attribute (N2, "name", ""), Sdefault.Hostname) and then (Get_Attribute (N2, "except", "") = "" or else not Match (Get_Attribute (N2, "except", ""), Sdefault.Hostname)) then Ignore_Config := Negate; exit; end if; else Put_Line (Standard_Error, "Unknown XML tag in " & File & ": " & Node_Name (N2)); raise Invalid_Knowledge_Base; end if; N2 := Next_Sibling (N2); end loop; exit when Ignore_Config; elsif Node_Name (N) = "config" then if Node_Value_As_String (N) = "" then Config.Supported := False; else Append (Chunk, Node_Value_As_String (N)); end if; else Put_Line (Standard_Error, "Unknown XML tag in " & File & ": " & Node_Name (N)); raise Invalid_Knowledge_Base; end if; N := Next_Sibling (N); end loop; if not Ignore_Config then Config.Config := Get_String (To_String (Chunk)); Append (Append_To, Config); end if; exception when Expression_Error => null; -- Proper warning message has been already emitted, so we just -- skip corresponding configuration node. end Parse_Configuration; -------------------------------- -- Parse_Fallback_Targets_Set -- -------------------------------- procedure Parse_Fallback_Targets_Set (Append_To : in out Fallback_Targets_Set_Vectors.Vector; File : String; Description : Node) is Set : String_Lists.List; N : Node := First_Child (Description); begin while N /= null loop if Node_Type (N) /= Element_Node then null; elsif Node_Name (N) = "target" then String_Lists.Append (Set, Node_Value_As_String (N)); else Put_Line (Standard_Error, "Unknown XML tag in " & File & ": " & Node_Name (N)); raise Invalid_Knowledge_Base; end if; N := Next_Sibling (N); end loop; if not String_Lists.Is_Empty (Set) then Fallback_Targets_Set_Vectors.Append (Append_To, Set); end if; end Parse_Fallback_Targets_Set; ----------------------- -- Parse_Targets_Set -- ----------------------- procedure Parse_Targets_Set (Append_To : in out Targets_Set_Vectors.Vector; File : String; Description : Node) is Name : Name_Id := No_Name; Set : Target_Lists.List; Pattern : Pattern_Matcher_Access; N : Node := First_Child (Description); Canon : constant String := Get_Attribute (Description, "canonical", ""); begin if Canon = "" then if Pedantic_KB then Put_Line ("No canonical target specified for target-set in " & Node_Name (N) & " in " & File); raise Invalid_Knowledge_Base; end if; else Name := Get_String (Canon); end if; while N /= null loop if Node_Type (N) /= Element_Node then null; elsif Node_Name (N) = "target" then declare Val : constant String := Node_Value_As_String (N); begin Pattern := new Pattern_Matcher'(Compile ("^" & Val & "$")); Target_Lists.Append (Set, Pattern); if Name = No_Name then -- When not in pedantic mode and working with -- an old KB the first target in the target set -- is taken as canonical target. Name := Get_String (Val); end if; exception when Expression_Error => Put_Line ("Invalid regular expression " & Val & " found in the target-set while parsing " & File); raise Invalid_Knowledge_Base; end; else Put_Line (Standard_Error, "Unknown XML tag in " & File & ": " & Node_Name (N)); raise Invalid_Knowledge_Base; end if; N := Next_Sibling (N); end loop; if not Target_Lists.Is_Empty (Set) then Targets_Set_Vectors.Append (Append_To, (Name, Set), 1); end if; end Parse_Targets_Set; Search : Search_Type; File : Directory_Entry_Type; File_Node : Node; N : Node; Reader : Schema.Dom_Readers.Tree_Reader; Input : File_Input; Schema : Schema_Reader; In_Files : String_Sets.Set; Cur : String_Sets.Cursor; Shortname : GNAT.Strings.String_Access; Dir : constant String := Normalize_Pathname (Directory, Case_Sensitive => False); use String_Sets; begin -- Do not parse several times the same database directory for J in 1 .. RTS_Last loop if RTS_List (J).all = Dir then return; end if; end loop; -- Extend RTS_List if it is full if RTS_Last = RTS_List'Last then declare New_List : constant GNAT.OS_Lib.String_List_Access := new GNAT.OS_Lib.String_List (1 .. RTS_List'Length * 2); begin New_List (1 .. RTS_Last) := RTS_List (1 .. RTS_Last); RTS_List := New_List; end; end if; RTS_Last := RTS_Last + 1; RTS_List (RTS_Last) := new String'(Dir); Reader.Set_Feature (Schema_Validation_Feature, Validate); Reader.Set_Feature (Validation_Feature, False); -- Do not use DTD if Validate then -- Load the XSD file used to validate the knowledge base declare Filename : constant String := Format_Pathname (Default_Knowledge_Base_Directory & "/gprconfig.xsd"); XSD : File_Input; begin Put_Verbose ("Parsing " & Filename); Open (Filename, XSD); Parse (Schema, XSD); Close (XSD); Reader.Set_Grammar (Get_Grammar (Schema)); Free (Schema); exception when Ada.Directories.Name_Error => Put_Line (Standard_Error, "Installation error: could not find the file " & Filename); raise Knowledge_Base_Validation_Error; when XML_Validation_Error => Put_Line (Standard_Error, Get_Error_Message (Schema)); raise Knowledge_Base_Validation_Error; end; end if; Put_Verbose ("Parsing knowledge base at " & Dir); Start_Search (Search, Directory => Dir, Pattern => "*.xml", Filter => (Ordinary_File => True, others => False)); while More_Entries (Search) loop Get_Next_Entry (Search, File); In_Files.Include (Full_Name (File)); end loop; End_Search (Search); Cur := In_Files.First; while Cur /= String_Sets.No_Element loop Shortname := new String' (GNAT.Directory_Operations.Base_Name (String_Sets.Element (Cur))); Put_Verbose ("Parsing file " & String_Sets.Element (Cur)); Open (String_Sets.Element (Cur), Input); Parse (Reader, Input); Close (Input); File_Node := DOM.Core.Documents.Get_Element (Get_Tree (Reader)); if Node_Name (File_Node) = "gprconfig" then N := First_Child (File_Node); while N /= null loop if Node_Type (N) /= Element_Node then null; elsif Node_Name (N) = "compiler_description" then if Parse_Compiler_Info then Parse_Compiler_Description (Base => Base, File => Shortname.all, Description => N); end if; elsif Node_Name (N) = "configuration" then if Parse_Compiler_Info then Parse_Configuration (Append_To => Base.Configurations, File => Shortname.all, Description => N); end if; elsif Node_Name (N) = "targetset" then Parse_Targets_Set (Append_To => Base.Targets_Sets, File => Shortname.all, Description => N); elsif Node_Name (N) = "fallback_targets" then Parse_Fallback_Targets_Set (Append_To => Base.Fallback_Targets_Sets, File => Shortname.all, Description => N); else Put_Line (Standard_Error, "Unknown XML tag in " & Shortname.all & ": " & Node_Name (N)); raise Invalid_Knowledge_Base; end if; N := Next_Sibling (N); end loop; else Put_Line (Standard_Error, "Invalid toplevel XML tag in " & Shortname.all); end if; declare Doc : Document := Get_Tree (Reader); begin Free (Doc); end; Free (Reader); GNAT.Strings.Free (Shortname); Next (Cur); end loop; In_Files.Clear; exception when Ada.Directories.Name_Error => Put_Verbose ("Directory not found: " & Directory); when Ada.Directories.Use_Error => Put_Verbose ("Directory not readable: " & Directory); when Invalid_Knowledge_Base | Knowledge_Base_Validation_Error => raise; when E : XML_Fatal_Error => Put_Line (Standard_Error, Exception_Message (E)); raise Invalid_Knowledge_Base; when XML_Validation_Error => Put_Line (Standard_Error, Get_Error_Message (Reader)); raise Knowledge_Base_Validation_Error; when E : others => Put_Line (Standard_Error, "Unexpected exception while parsing knowledge base: " & Exception_Information (E)); raise Invalid_Knowledge_Base; end Parse_Knowledge_Base; ------------------------- -- Free_Knowledge_Base -- ------------------------- procedure Free_Knowledge_Base (Base : in out Knowledge_Base) is begin for El of Base.Compilers loop Free (El); end loop; Base.Compilers.Clear; Base.No_Compilers.Clear; for El of Base.Configurations loop Free (El); end loop; Base.Configurations.Clear; for El of Base.Targets_Sets loop Free (El); end loop; Base.Targets_Sets.Clear; for El of Base.Fallback_Targets_Sets loop El.Clear; end loop; Base.Fallback_Targets_Sets.Clear; end Free_Knowledge_Base; ------------------------ -- Get_Variable_Value -- ------------------------ function Get_Variable_Value (Comp : Compiler; Name : String) return String is N : constant Name_Id := Get_String (Name); begin if Variables_Maps.Contains (Comp.Variables, N) then return Get_Name_String (Variables_Maps.Element (Comp.Variables, N)); elsif Name = "HOST" then return Sdefault.Hostname; elsif Name = "TARGET" then return Get_Name_String (Comp.Target); elsif Name = "RUNTIME_DIR" then return Name_As_Directory (Get_Name_String (Comp.Runtime_Dir)); elsif Name = "EXEC" then return Get_Name_String_Or_Null (Comp.Executable); elsif Name = "VERSION" then return Get_Name_String_Or_Null (Comp.Version); elsif Name = "LANGUAGE" then return Get_Name_String_Or_Null (Comp.Language_LC); elsif Name = "RUNTIME" then return Get_Name_String_Or_Null (Comp.Runtime); elsif Name = "PREFIX" then return Get_Name_String_Or_Null (Comp.Prefix); elsif Name = "PATH" then return Get_Name_String (Comp.Path); elsif Name = "GPRCONFIG_PREFIX" then return Executable_Prefix_Path; end if; raise Invalid_Knowledge_Base with "variable '" & Name & "' is not defined"; end Get_Variable_Value; -------------------------- -- Substitute_Variables -- -------------------------- function Substitute_Variables (Str : String) return String is Str_Len : constant Natural := Str'Last; Pos : Natural := Str'First; Last : Natural := Pos; Result : Unbounded_String; Word_Start, Word_End, Tmp : Natural; Has_Index : Boolean; begin while Pos < Str_Len loop if Str (Pos) = '$' and then Str (Pos + 1) = '$' then Append (Result, Str (Last .. Pos - 1)); Append (Result, "$"); Last := Pos + 2; Pos := Last; elsif Str (Pos) = '$' then if Str (Pos + 1) = '{' then Word_Start := Pos + 2; Tmp := Pos + 2; while Tmp <= Str_Len and then Str (Tmp) /= '}' loop Tmp := Tmp + 1; end loop; Tmp := Tmp + 1; Word_End := Tmp - 2; else Word_Start := Pos + 1; Tmp := Pos + 1; while Tmp <= Str_Len and then (Is_Alphanumeric (Str (Tmp)) or else Str (Tmp) = '_') loop Tmp := Tmp + 1; end loop; Word_End := Tmp - 1; end if; Append (Result, Str (Last .. Pos - 1)); Has_Index := False; for W in Word_Start .. Word_End loop if Str (W) = '(' then Has_Index := True; if Str (Word_End) /= ')' then Put_Line (Standard_Error, "Missing closing parenthesis in variable name: " & Str (Word_Start .. Word_End)); raise Invalid_Knowledge_Base; else Append (Result, Callback (Var_Name => Str (Word_Start .. W - 1), Index => Str (W + 1 .. Word_End - 1))); end if; exit; end if; end loop; if not Has_Index then Append (Result, Callback (Str (Word_Start .. Word_End), "")); end if; Last := Tmp; Pos := Last; else Pos := Pos + 1; end if; end loop; Append (Result, Str (Last .. Str_Len)); return To_String (Result); end Substitute_Variables; -------------------------------------------------- -- Substitute_Variables_In_Compiler_Description -- -------------------------------------------------- function Substitute_Variables_In_Compiler_Description (Str : String; Comp : Compiler) return String is function Callback (Var_Name, Index : String) return String; -------------- -- Callback -- -------------- function Callback (Var_Name, Index : String) return String is begin if Index /= "" then Put_Line (Standard_Error, "Indexed variables only allowed in (in " & Var_Name & "(" & Index & ")"); raise Invalid_Knowledge_Base; end if; return Get_Variable_Value (Comp, Var_Name); end Callback; function Do_Substitute is new Substitute_Variables (Callback); begin return Do_Substitute (Str); end Substitute_Variables_In_Compiler_Description; ------------------------------------------- -- Substitute_Variables_In_Configuration -- ------------------------------------------- function Substitute_Variables_In_Configuration (Base : Knowledge_Base; Str : String; Comps : Compiler_Lists.List) return String is function Callback (Var_Name, Index : String) return String; -------------- -- Callback -- -------------- function Callback (Var_Name, Index : String) return String is C : Compiler_Lists.Cursor; Comp : Compiler_Access; Idx : constant Name_Id := Get_String_Or_No_Name (To_Lower (Index)); begin if Var_Name = "GPRCONFIG_PREFIX" then return Executable_Prefix_Path; elsif Index = "" then if Var_Name = "TARGET" and then not Is_Empty (Comps) then -- Can have an optional language index. -- If there is no index, all compilers share the same target, -- so just take that of the first compiler in the list return Normalized_Target (Base, Compiler_Lists.Element (First (Comps)).Targets_Set); else Put_Line (Standard_Error, "Ambiguous variable substitution, need to specify the" & " language (in " & Var_Name & ")"); raise Invalid_Knowledge_Base; end if; else C := First (Comps); while Has_Element (C) loop Comp := Compiler_Lists.Element (C); if Comp.Selected and then Comp.Language_LC = Idx then return Get_Variable_Value (Comp.all, Var_Name); end if; Next (C); end loop; end if; return ""; end Callback; function Do_Substitute is new Substitute_Variables (Callback); begin return Do_Substitute (Str); end Substitute_Variables_In_Configuration; -------------------- -- Parse_All_Dirs -- -------------------- procedure Parse_All_Dirs (Processed_Value : out External_Value_Lists.List; Visited : in out String_To_External_Value.Map; Current_Dir : String; Path_To_Check : String; Regexp : Pattern_Matcher; Regexp_Str : String; Value_If_Match : Name_Id; Group : Integer; Group_Match : String := ""; Group_Count : Natural := 0; Contents : Pattern_Matcher_Access := null; Merge_Same_Dirs : Boolean) is procedure Save_File (Current_Dir : String; Val : Name_Id); -- Mark the given directory as valid for the configuration. -- This takes care of removing duplicates if needed. --------------- -- Save_File -- --------------- procedure Save_File (Current_Dir : String; Val : Name_Id) is begin if not Merge_Same_Dirs then Put_Verbose (": SAVE " & Current_Dir); Append (Processed_Value, (Value => Val, Alternate => No_Name, Extracted_From => Get_String_No_Adalib (Current_Dir))); else declare use String_To_External_Value; Normalized : constant String := Normalize_Pathname (Name => Current_Dir, Directory => "", Resolve_Links => True, Case_Sensitive => True); Prev : External_Value_Lists.Cursor; Rec : External_Value_Item; begin if Visited.Contains (Normalized) then Put_Verbose (": ALREADY FOUND (" & Get_Name_String_Safe (Val) & ") " & Current_Dir); Prev := Visited.Element (Normalized); Rec := External_Value_Lists.Element (Prev); Rec.Alternate := Val; External_Value_Lists.Replace_Element (Container => Processed_Value, Position => Prev, New_Item => Rec); else Put_Verbose (": SAVE (" & Get_Name_String_Safe (Val) & ") " & Current_Dir); Append (Processed_Value, (Value => Val, Alternate => No_Name, Extracted_From => Get_String_No_Adalib (Current_Dir))); Visited.Include (Normalized, External_Value_Lists.Last (Processed_Value)); end if; end; end if; end Save_File; First : constant Integer := Path_To_Check'First; Last : Integer; Val : Name_Id; begin if Path_To_Check'Length = 0 or else Path_To_Check = "/" or else Path_To_Check = "" & Directory_Separator then if Group = -1 then Val := Value_If_Match; else Val := Get_String (Group_Match); end if; if Contents /= null and then Is_Regular_File (Current_Dir) then Put_Verbose (": Checking inside file " & Current_Dir); declare F : File_Type; begin Open (F, In_File, Current_Dir); while not End_Of_File (F) loop declare Line : constant String := Get_Line (F); begin Put_Verbose (": read line " & Line); if Match (Contents.all, Line) then Save_File (Normalize_Pathname (Name => Line, Directory => Dir_Name (Current_Dir), Resolve_Links => True), Val); exit; end if; end; end loop; Close (F); end; else Save_File (Current_Dir, Val); end if; else -- Do not split on '\', since we document we only accept UNIX paths -- anyway. This leaves \ for regexp quotes Last := First + 1; while Last <= Path_To_Check'Last and then Path_To_Check (Last) /= '/' loop Last := Last + 1; end loop; -- If we do not have a regexp. if not Is_Regexp (Path_To_Check (First .. Last - 1)) then declare Dir : constant String := Normalize_Pathname (Current_Dir, Resolve_Links => False) & Directory_Separator & Unquote (Path_To_Check (First .. Last - 1)); Remains : constant String := Path_To_Check (Last + 1 .. Path_To_Check'Last); begin if (Remains'Length = 0 or else Remains = "/" or else Remains = "" & Directory_Separator) and then Is_Regular_File (Dir) then Put_Verbose (": Found file " & Dir); -- If there is such a subdir, keep checking Parse_All_Dirs (Processed_Value => Processed_Value, Visited => Visited, Current_Dir => Dir, Path_To_Check => Remains, Regexp => Regexp, Regexp_Str => Regexp_Str, Value_If_Match => Value_If_Match, Group => Group, Group_Match => Group_Match, Group_Count => Group_Count, Contents => Contents, Merge_Same_Dirs => Merge_Same_Dirs); elsif Is_Directory (Dir) then Put_Verbose (": Recurse into " & Dir); -- If there is such a subdir, keep checking Parse_All_Dirs (Processed_Value => Processed_Value, Visited => Visited, Current_Dir => Dir & Directory_Separator, Path_To_Check => Remains, Regexp => Regexp, Regexp_Str => Regexp_Str, Value_If_Match => Value_If_Match, Group => Group, Group_Match => Group_Match, Group_Count => Group_Count, Contents => Contents, Merge_Same_Dirs => Merge_Same_Dirs); else Put_Verbose (": No such directory: " & Dir); end if; end; -- Else we have a regexp, check all files else declare File_Re : constant String := Path_To_Check (First .. Last - 1); File_Regexp : constant Pattern_Matcher := Compile (File_Re); Search : Search_Type; File : Directory_Entry_Type; Filter : Ada.Directories.Filter_Type; Continue_Search : Boolean := True; begin if Current_Verbosity /= Default and then File_Re = ".." then Put_Verbose ("Potential error: .. is generally not meant as a regexp," & " and should be quoted in this case, as in \.\."); end if; if Path_To_Check (Last) = '/' then Put_Verbose (": Check directories in " & Current_Dir & " that match " & File_Re); Filter := (Directory => True, others => False); else Put_Verbose (": Check files in " & Current_Dir & " that match " & File_Re); Filter := (others => True); end if; Start_Search (Search => Search, Directory => Current_Dir, Filter => Filter, Pattern => ""); while Continue_Search loop begin while More_Entries (Search) loop Get_Next_Entry (Search, File); if Simple_Name (File) /= "." and then Simple_Name (File) /= ".." then declare Matched : Match_Array (0 .. Integer'Max (Group, 0)); Simple : constant String := Simple_Name (File); Count : constant Natural := Paren_Count (File_Regexp); begin Match (File_Regexp, Simple, Matched); if Matched (0) /= No_Match then Put_Verbose (": Matched " & Simple_Name (File)); if Group_Count < Group and then Group_Count + Count >= Group then Put_Verbose (": Found matched group: " & Simple (Matched (Group - Group_Count).First .. Matched (Group - Group_Count).Last)); Parse_All_Dirs (Processed_Value => Processed_Value, Visited => Visited, Current_Dir => Full_Name (File) & Directory_Separator, Path_To_Check => Path_To_Check (Last + 1 .. Path_To_Check'Last), Regexp => Regexp, Regexp_Str => Regexp_Str, Value_If_Match => Value_If_Match, Group => Group, Group_Match => Simple (Matched (Group - Group_Count).First .. Matched (Group - Group_Count).Last), Group_Count => Group_Count + Count, Contents => Contents, Merge_Same_Dirs => Merge_Same_Dirs); else Parse_All_Dirs (Processed_Value => Processed_Value, Visited => Visited, Current_Dir => Full_Name (File) & Directory_Separator, Path_To_Check => Path_To_Check (Last + 1 .. Path_To_Check'Last), Regexp => Regexp, Regexp_Str => Regexp_Str, Value_If_Match => Value_If_Match, Group => Group, Group_Match => Group_Match, Group_Count => Group_Count + Count, Contents => Contents, Merge_Same_Dirs => Merge_Same_Dirs); end if; end if; end; end if; end loop; Continue_Search := False; exception when Ada.Directories.Name_Error => null; when Ada.Directories.Use_Error => null; end; end loop; End_Search (Search); end; end if; end if; end Parse_All_Dirs; ------------------------ -- Get_External_Value -- ------------------------ procedure Get_External_Value (Attribute : String; Value : External_Value; Comp : Compiler; Split_Into_Words : Boolean := True; Merge_Same_Dirs : Boolean := False; Processed_Value : out External_Value_Lists.List) is Saved_Path : constant String := Ada.Environment_Variables.Value ("PATH"); Status : aliased Integer; Extracted_From : Name_Id := No_Name; Tmp_Result : Unbounded_String; Node_Cursor : External_Value_Nodes.Cursor := First (Value); Node : External_Value_Node; From_Static : Boolean := False; Visited : String_To_External_Value.Map; function Get_Command_Output_Cache (Path : String; Command : String) return Unbounded_String; -- Spawns given command and caches results. When the same command -- (same full path and arguments) should be spawned again, -- returns output from cache instead. function Get_Command_Output_Cache (Path : String; Command : String) return Unbounded_String is Key : constant String := Path & Command; Cur : constant String_Maps.Cursor := External_Calls_Cache.Find (Key); Tmp_Result : Unbounded_String; begin if Cur = String_Maps.No_Element then declare Args : Argument_List_Access := Argument_String_To_List (Command); Output : constant String := Get_Command_Output (Command => Args (Args'First).all, Arguments => Args (Args'First + 1 .. Args'Last), Input => "", Status => Status'Unchecked_Access, Err_To_Out => True); begin GNAT.Strings.Free (Args); Tmp_Result := To_Unbounded_String (Output); External_Calls_Cache.Include (Key, Tmp_Result); return Tmp_Result; end; else return External_Calls_Cache.Element (Key); end if; end Get_Command_Output_Cache; begin Clear (Processed_Value); while Has_Element (Node_Cursor) loop while Has_Element (Node_Cursor) loop Node := External_Value_Nodes.Element (Node_Cursor); case Node.Typ is when Value_Variable => Extracted_From := Node.Var_Name; when Value_Constant => if Node.Value = No_Name then Tmp_Result := Null_Unbounded_String; else Tmp_Result := To_Unbounded_String (Substitute_Variables_In_Compiler_Description (Get_Name_String (Node.Value), Comp)); end if; From_Static := True; Put_Verbose (Attribute & ": constant := " & To_String (Tmp_Result)); when Value_Shell => Ada.Environment_Variables.Set ("PATH", Get_Name_String (Comp.Path) & Path_Separator & Saved_Path); declare Command : constant String := Substitute_Variables_In_Compiler_Description (Get_Name_String (Node.Command), Comp); begin Tmp_Result := Null_Unbounded_String; Tmp_Result := Get_Command_Output_Cache (Get_Name_String (Comp.Path), Command); Ada.Environment_Variables.Set ("PATH", Saved_Path); if Current_Verbosity = High then Put_Verbose (Attribute & ": executing """ & Command & """ output=""" & To_String (Tmp_Result) & """"); elsif Current_Verbosity = Medium then Put_Verbose (Attribute & ": executing """ & Command & """ output= no match"); end if; exception when Invalid_Process => Put_Verbose ("Spawn failed for " & Command); end; when Value_Directory => declare Search : constant String := Substitute_Variables_In_Compiler_Description (Get_Name_String (Node.Directory), Comp); begin if Search (Search'First) = '/' then Put_Verbose (Attribute & ": search directories matching " & Search & ", starting from /", 1); Parse_All_Dirs (Processed_Value => Processed_Value, Visited => Visited, Current_Dir => "", Path_To_Check => Search, Contents => Node.Contents, Regexp => Compile (Search (Search'First + 1 .. Search'Last)), Regexp_Str => Search, Value_If_Match => Node.Dir_If_Match, Merge_Same_Dirs => Merge_Same_Dirs, Group => Node.Directory_Group); else if Current_Verbosity /= Default then Put_Verbose (Attribute & ": search directories matching " & Search & ", starting from " & Get_Name_String_Safe (Comp.Path), 1); end if; Parse_All_Dirs (Processed_Value => Processed_Value, Visited => Visited, Current_Dir => Get_Name_String (Comp.Path), Path_To_Check => Search, Contents => Node.Contents, Regexp => Compile (Search), Regexp_Str => Search, Value_If_Match => Node.Dir_If_Match, Merge_Same_Dirs => Merge_Same_Dirs, Group => Node.Directory_Group); end if; Put_Verbose ("Done search directories", -1); end; when Value_Grep => declare Matched : Match_Array (0 .. Node.Group); Tmp_Str : constant String := To_String (Tmp_Result); begin Match (Node.Regexp_Re.all, Tmp_Str, Matched); if Matched (0) /= No_Match then Tmp_Result := To_Unbounded_String (Tmp_Str (Matched (Node.Group).First .. Matched (Node.Group).Last)); Put_Verbose (Attribute & ": grep matched=""" & To_String (Tmp_Result) & """"); else Tmp_Result := Null_Unbounded_String; Put_Verbose (Attribute & ": grep no match"); end if; end; when Value_Nogrep => declare Matched : Match_Array (0 .. 0); Tmp_Str : constant String := To_String (Tmp_Result); begin Match (Node.Regexp_No.all, Tmp_Str, Matched); if Matched (0) /= No_Match then Put_Verbose (Attribute & ": nogrep matched=""" & Tmp_Str & """"); raise Ignore_Compiler; else Put_Verbose (Attribute & ": nogrep no match"); end if; end; when Value_Must_Match => if not Match (Expression => Get_Name_String (Node.Must_Match), Data => To_String (Tmp_Result)) then if Current_Verbosity /= Default then Put_Verbose ("Ignore compiler since external value """ & To_String (Tmp_Result) & """ must match " & Get_Name_String_Safe (Node.Must_Match)); end if; Tmp_Result := Null_Unbounded_String; raise Ignore_Compiler; end if; exit; when Value_Done | Value_Filter => exit; end case; Next (Node_Cursor); end loop; case Node.Typ is when Value_Done | Value_Filter | Value_Must_Match => if Tmp_Result = Null_Unbounded_String then -- Value could not be computed if Extracted_From /= No_Name then Append (Processed_Value, External_Value_Item' (Value => No_Name, Alternate => No_Name, Extracted_From => Extracted_From)); end if; elsif Split_Into_Words then declare Split : String_Lists.List; C : String_Lists.Cursor; Filter : Name_Id; begin if Node.Typ = Value_Filter then Filter := Node.Filter; else Filter := No_Name; end if; -- When an external value is defined as a static string, -- the only valid separator is ','. When computed -- however, we also allow space as a separator if From_Static then Get_Words (Words => To_String (Tmp_Result), Filter => Filter, Separator1 => ',', Separator2 => ',', Map => Split, Allow_Empty_Elements => False); else Get_Words (Words => To_String (Tmp_Result), Filter => Filter, Separator1 => ' ', Separator2 => ',', Map => Split, Allow_Empty_Elements => False); end if; C := First (Split); while Has_Element (C) loop Append (Processed_Value, External_Value_Item' (Value => Get_String (String_Lists.Element (C)), Alternate => No_Name, Extracted_From => Extracted_From)); Next (C); end loop; end; else Append (Processed_Value, External_Value_Item' (Value => Get_String (To_String (Tmp_Result)), Alternate => No_Name, Extracted_From => Extracted_From)); end if; when others => null; end case; Extracted_From := No_Name; Next (Node_Cursor); end loop; end Get_External_Value; ----------------------- -- Get_Fallback_List -- ----------------------- function Get_Fallback_List (Base : Knowledge_Base; On_Target : Targets_Set_Id) return String_Lists.List is Target : constant String := Get_Name_String_Or_Null (Base.Targets_Sets.Element (On_Target).Name); Fallback_List : String_Lists.List; Cur : String_Lists.Cursor; begin for I in Base.Fallback_Targets_Sets.First_Index .. Base.Fallback_Targets_Sets.Last_Index loop Fallback_List := Base.Fallback_Targets_Sets.Element (I); Cur := Fallback_List.First; while Cur /= String_Lists.No_Element loop if String_Lists.Element (Cur) = Target then -- No point to store original target, it has already been -- processed. Fallback_List.Delete (Cur); return Fallback_List; end if; Next (Cur); end loop; end loop; return String_Lists.Empty_List; end Get_Fallback_List; --------------- -- Get_Words -- --------------- procedure Get_Words (Words : String; Filter : Name_Id; Separator1 : Character; Separator2 : Character; Map : out String_Lists.List; Allow_Empty_Elements : Boolean) is First : Integer := Words'First; Last : Integer; Filter_Set : String_Lists.List; begin if Filter /= No_Name then Get_Words (Get_Name_String (Filter), No_Name, Separator1, Separator2, Filter_Set, Allow_Empty_Elements => True); end if; if not Allow_Empty_Elements then while First <= Words'Last and then (Words (First) = Separator1 or else Words (First) = Separator2) loop First := First + 1; end loop; end if; while First <= Words'Last loop if Words (First) /= Separator1 and then Words (First) /= Separator2 then Last := First + 1; while Last <= Words'Last and then Words (Last) /= Separator1 and then Words (Last) /= Separator2 loop Last := Last + 1; end loop; else Last := First; end if; if (Allow_Empty_Elements or else First <= Last - 1) and then (Is_Empty (Filter_Set) or else Contains (Filter_Set, Words (First .. Last - 1))) then Append (Map, Words (First .. Last - 1)); end if; First := Last + 1; end loop; end Get_Words; ------------------------------ -- Foreach_Language_Runtime -- ------------------------------ procedure Foreach_Language_Runtime (Iterator : in out Compiler_Iterator'Class; Base : in out Knowledge_Base; Name : Name_Id; Executable : Name_Id; Directory : String; Prefix : Name_Id; From_Extra_Dir : Boolean; On_Target : Targets_Set_Id; Descr : Compiler_Description; Path_Order : Integer; Continue : out Boolean) is Target : External_Value_Lists.List; Version : External_Value_Lists.List; Languages : External_Value_Lists.List; Runtimes : External_Value_Lists.List; Variables : External_Value_Lists.List; Comp : Compiler; C, C2 : External_Value_Lists.Cursor; CS : String_Lists.Cursor; begin Continue := True; -- verify that the compiler is indeed a real executable -- on Windows and not a cygwin symbolic link if On_Windows and then not Is_Windows_Executable (Directory & Directory_Separator & Get_Name_String (Executable)) then Continue := True; return; end if; Comp.Name := Name; Comp.Path := Get_String (Name_As_Directory (Normalize_Pathname (Directory, Case_Sensitive => False))); Comp.Base_Name := Get_String (GNAT.Directory_Operations.Base_Name (Get_Name_String (Executable), Suffix => Exec_Suffix.all)); Comp.Path_Order := Path_Order; Comp.Prefix := Prefix; Comp.Executable := Executable; -- Check the target first, for efficiency. If it doesn't match, no need -- to compute other attributes. if Executable /= No_Name then if not Is_Empty (Descr.Target) then Get_External_Value ("target", Value => Descr.Target, Comp => Comp, Split_Into_Words => False, Processed_Value => Target); if not Is_Empty (Target) then Comp.Target := External_Value_Lists.Element (First (Target)).Value; Get_Targets_Set (Base, Get_Name_String (Comp.Target), Comp.Targets_Set); else Put_Verbose ("Target unknown for this compiler"); Comp.Targets_Set := Unknown_Targets_Set; end if; if On_Target /= All_Target_Sets and then Comp.Targets_Set /= On_Target then Put_Verbose ("Target for this compiler does not match --target"); Continue := True; return; end if; else Put_Verbose ("Target unspecified, always match"); Comp.Targets_Set := All_Target_Sets; end if; -- Then get the value of the remaining attributes. For most of them, -- we must be able to find a valid value, or the compiler is simply -- ignored Get_External_Value ("version", Value => Descr.Version, Comp => Comp, Split_Into_Words => False, Processed_Value => Version); if Is_Empty (Version) then Put_Verbose ("Ignore compiler, since couldn't guess its version"); Continue := True; return; end if; Comp.Version := External_Value_Lists.Element (First (Version)).Value; Get_External_Value ("variables", Value => Descr.Variables, Comp => Comp, Split_Into_Words => False, Processed_Value => Variables); C := First (Variables); while Has_Element (C) loop declare Ext : constant External_Value_Item := External_Value_Lists.Element (C); begin if Ext.Value = No_Name then if Current_Verbosity /= Default then Put_Verbose ("Ignore compiler since variable '" & Get_Name_String_Safe (Ext.Extracted_From) & "' is empty"); end if; Continue := True; return; end if; if Variables_Maps.Contains (Comp.Variables, Ext.Extracted_From) then Put_Line (Standard_Error, "Variable '" & Get_Name_String_Safe (Ext.Extracted_From) & "' is already defined"); else Variables_Maps.Insert (Comp.Variables, Ext.Extracted_From, Ext.Value); end if; end; Next (C); end loop; end if; Get_External_Value ("languages", Value => Descr.Languages, Comp => Comp, Split_Into_Words => True, Processed_Value => Languages); if Is_Empty (Languages) then Put_Verbose ("Ignore compiler, since no language could be computed"); Continue := True; return; end if; if Executable /= No_Name then Get_External_Value ("runtimes", Value => Descr.Runtimes, Comp => Comp, Split_Into_Words => True, Merge_Same_Dirs => True, Processed_Value => Runtimes); Comp.Default_Runtime := True; Comp.Any_Runtime := False; if not Is_Empty (Runtimes) then -- This loop makes sure that the default runtime appears first in -- the list (and thus is selected automatically when using -- --batch). This doesn't impact the interactive display, where -- the runtimes will be sorted alphabetically anyway (see -- Display_Before) Comp.Default_Runtime := False; Comp.Any_Runtime := True; CS := First (Descr.Default_Runtimes); Defaults_Loop : while Has_Element (CS) loop C2 := First (Runtimes); while Has_Element (C2) loop if Get_Name_String (External_Value_Lists.Element (C2).Value) = String_Lists.Element (CS) then Prepend (Runtimes, External_Value_Lists.Element (C2)); Delete (Runtimes, C2); Comp.Default_Runtime := True; exit Defaults_Loop; end if; Next (C2); end loop; Next (CS); end loop Defaults_Loop; end if; end if; C := First (Languages); while Has_Element (C) loop declare L : constant Name_Id := External_Value_Lists.Element (C).Value; begin Comp.Language_Case := L; Comp.Language_LC := Get_String (To_Lower (Get_Name_String (L))); -- First check if a runtime specified with option --config= will -- match. Callback (Iterator => Iterator, Base => Base, Comp => Comp, Runtime_Specified => True, From_Extra_Dir => From_Extra_Dir, Continue => Continue); if not Continue then return; end if; if Is_Empty (Runtimes) then if Descr.Runtimes /= Null_External_Value then Put_Verbose ("No runtime found where one is required for: " & Get_Name_String_Safe (Comp.Path)); else Callback (Iterator => Iterator, Base => Base, Comp => Comp, Runtime_Specified => False, From_Extra_Dir => From_Extra_Dir, Continue => Continue); if not Continue then return; end if; end if; else C2 := First (Runtimes); while Has_Element (C2) loop Comp.Runtime := External_Value_Lists.Element (C2).Value; Comp.Alt_Runtime := External_Value_Lists.Element (C2).Alternate; Comp.Runtime_Dir := External_Value_Lists.Element (C2).Extracted_From; Callback (Iterator => Iterator, Base => Base, Comp => Comp, Runtime_Specified => False, From_Extra_Dir => From_Extra_Dir, Continue => Continue); if not Continue then return; end if; Next (C2); end loop; end if; end; Next (C); end loop; exception when Ignore_Compiler => null; end Foreach_Language_Runtime; --------------- -- To_String -- --------------- function To_String (Base : Knowledge_Base; Comp : Compiler; As_Config_Arg : Boolean; Show_Target : Boolean := False; Rank_In_List : Integer := -1; Parser_Friendly : Boolean := False) return String is function Runtime_Or_Alternate return String; function Runtime_Or_Empty return String; function Rank return String; function Target return String; -- Return various aspects of the compiler; -------------------------- -- Runtime_Or_Alternate -- -------------------------- function Runtime_Or_Alternate return String is begin if Comp.Alt_Runtime /= No_Name then return Get_Name_String (Comp.Alt_Runtime); elsif Comp.Runtime /= No_Name then return Get_Name_String (Comp.Runtime); else return ""; end if; end Runtime_Or_Alternate; ---------------------- -- Runtime_Or_Empty -- ---------------------- function Runtime_Or_Empty return String is begin if Comp.Runtime /= No_Name then if Comp.Alt_Runtime = No_Name then return " (" & Get_Name_String_Safe (Comp.Runtime) & " runtime)"; else return " (" & Get_Name_String_Safe (Comp.Runtime) & " [" & Get_Name_String_Safe (Comp.Alt_Runtime) & "] runtime)"; end if; else return ""; end if; end Runtime_Or_Empty; ---------- -- Rank -- ---------- function Rank return String is Result : String (1 .. 4) := " "; Img : constant String := Rank_In_List'Img; begin if Rank_In_List > 0 then Result (4 - Img'Length + 1 .. 4) := Img; end if; if Comp.Selected then Result (1) := '*'; end if; return Result; end Rank; ------------ -- Target -- ------------ function Target return String is begin if Show_Target then return " on " & Get_Name_String_Safe (Comp.Target); else return ""; end if; end Target; begin if As_Config_Arg then return Get_Name_String_Or_Null (Comp.Language_Case) & ',' & Get_Name_String_Or_Null (Comp.Version) & ',' & Get_Name_String_Or_Null (Comp.Runtime) & ',' & Get_Name_String_Or_Null (Comp.Path) & ',' & Get_Name_String_Or_Null (Comp.Name); elsif Parser_Friendly then return Rank & " target:" & Get_Name_String_Or_Null (Comp.Target) & ASCII.LF & Rank & " normalized_target:" & Normalized_Target (Base, Comp.Targets_Set) & ASCII.LF & Rank & " executable:" & Get_Name_String_Or_Null (Comp.Executable) & ASCII.LF & Rank & " path:" & Get_Name_String_Or_Null (Comp.Path) & ASCII.LF & Rank & " lang:" & Get_Name_String_Or_Null (Comp.Language_Case) & ASCII.LF & Rank & " name:" & Get_Name_String_Or_Null (Comp.Name) & ASCII.LF & Rank & " version:" & Get_Name_String_Or_Null (Comp.Version) & ASCII.LF & Rank & " runtime:" & Runtime_Or_Alternate & ASCII.LF & Rank & " native:" & Boolean'Image (Query_Targets_Set (Base, Hostname) = Comp.Targets_Set); elsif Comp.Executable = No_Name then -- A language that requires no compiler return Rank & ". " & Get_Name_String_Or_Null (Comp.Language_Case) & " (no compiler required)"; else return Rank & ". " & Get_Name_String_Or_Null (Comp.Name) & " for " & Get_Name_String_Or_Null (Comp.Language_Case) & " in " & Get_Name_String_Or_Null (Comp.Path) & Target & " version " & Get_Name_String_Or_Null (Comp.Version) & Runtime_Or_Empty; end if; end To_String; --------------- -- To_String -- --------------- function To_String (Base : Knowledge_Base; Compilers : Compiler_Lists.List; Selected_Only : Boolean; Show_Target : Boolean := False; Parser_Friendly : Boolean := False) return String is Comp : Compiler_Lists.Cursor := First (Compilers); Result : Unbounded_String; Rank : Natural := 1; begin while Has_Element (Comp) loop if Compiler_Lists.Element (Comp).Selected or else (not Selected_Only and then Compiler_Lists.Element (Comp).Selectable) then Append (Result, To_String (Base, Compiler_Lists.Element (Comp).all, False, Show_Target => Show_Target, Rank_In_List => Rank, Parser_Friendly => Parser_Friendly)); Append (Result, ASCII.LF); end if; Rank := Rank + 1; Next (Comp); end loop; return To_String (Result); end To_String; ----------------------------- -- Foreach_Compiler_In_Dir -- ----------------------------- procedure Foreach_Compiler_In_Dir (Iterator : in out Compiler_Iterator'Class; Base : in out Knowledge_Base; Directory : String; From_Extra_Dir : Boolean; On_Target : Targets_Set_Id; Path_Order : Integer; Continue : out Boolean) is use CDM; function Executable_Pattern return String; pragma Inline (Executable_Pattern); -- Returns a pattern which matchs executable ------------------------ -- Executable_Pattern -- ------------------------ function Executable_Pattern return String is begin if On_Windows then return "*.{exe,bat,cmd}"; else return ""; end if; end Executable_Pattern; C : CDM.Cursor; Search : Search_Type; Dir : Directory_Entry_Type; begin -- Since the name of an executable can be a regular expression, we need -- to look at all files in the directory to see if they match. This -- requires more system calls than if the name was always a simple -- string. So we first check which of the two algorithms should be used. Continue := True; if Current_Verbosity /= Default then Put_Verbose ("Foreach compiler in " & Directory & " regexp=" & Boolean'Image (Base.Check_Executable_Regexp) & " extra_dir=" & From_Extra_Dir'Img, 1); end if; if Base.Check_Executable_Regexp then begin Start_Search (Search => Search, Directory => Directory, Pattern => Executable_Pattern); exception when Ada.Directories.Name_Error => Put_Verbose ("No such directory:" & Directory, -1); Continue := True; return; when Ada.Directories.Use_Error => Put_Verbose ("Directory not readable:" & Directory, -1); Continue := True; return; end; For_All_Files_In_Dir : loop begin exit For_All_Files_In_Dir when not More_Entries (Search); Get_Next_Entry (Search, Dir); C := First (Base.Compilers); while Has_Element (C) loop declare Config : constant Compiler_Description := CDM.Element (C); Simple : constant String := Simple_Name (Dir); Matches : Match_Array (0 .. Integer'Max (0, Config.Prefix_Index)); Matched : Boolean; Prefix : Name_Id := No_Name; begin -- A language with no expected compiler => always match if Config.Executable = No_Name then Put_Verbose (Get_Name_String (Key (C)) & " requires no compiler", 1); Continue := True; Foreach_Language_Runtime (Iterator => Iterator, Base => Base, Name => Key (C), Executable => No_Name, Directory => "", On_Target => Unknown_Targets_Set, Prefix => No_Name, From_Extra_Dir => From_Extra_Dir, Descr => Config, Path_Order => Path_Order, Continue => Continue); Put_Verbose ("", -1); exit For_All_Files_In_Dir when not Continue; Matched := False; elsif Config.Executable_Re /= null then Match (Config.Executable_Re.all, Data => Simple, Matches => Matches); Matched := Matches (0) /= No_Match; else Matched := (Get_Name_String (Config.Executable) & Exec_Suffix.all) = Simple_Name (Dir); end if; if Matched then Put_Verbose (Get_Name_String (Key (C)) & " is candidate: filename=" & Simple, 1); if Config.Executable_Re /= null and then Config.Prefix_Index >= 0 and then Matches (Config.Prefix_Index) /= No_Match then Prefix := Get_String (Simple (Matches (Config.Prefix_Index).First .. Matches (Config.Prefix_Index).Last)); end if; Continue := True; Foreach_Language_Runtime (Iterator => Iterator, Base => Base, Name => Key (C), Executable => Get_String (Simple), Directory => Directory, On_Target => On_Target, Prefix => Prefix, From_Extra_Dir => From_Extra_Dir, Descr => Config, Path_Order => Path_Order, Continue => Continue); Put_Verbose ("", -1); exit For_All_Files_In_Dir when not Continue; end if; end; Next (C); end loop; exception when Ada.Directories.Name_Error | Ada.Directories.Use_Error => null; end; end loop For_All_Files_In_Dir; else -- Do not search all entries in the directory, but check explictly -- for the compilers. This results in a lot less system calls, and -- thus is faster. C := First (Base.Compilers); while Has_Element (C) loop declare Config : constant Compiler_Description := CDM.Element (C); F : constant String := Normalize_Pathname (Name => Get_Name_String (Config.Executable), Directory => Directory, Resolve_Links => False, Case_Sensitive => Case_Sensitive_Files) & Exec_Suffix.all; begin if Ada.Directories.Exists (F) then Put_Verbose ("--------------------------------------"); Put_Verbose ("Processing " & Get_Name_String_Safe (Config.Name) & " in " & Directory); Foreach_Language_Runtime (Iterator => Iterator, Base => Base, Name => Key (C), Executable => Config.Executable, Prefix => No_Name, From_Extra_Dir => From_Extra_Dir, On_Target => On_Target, Directory => Directory, Descr => Config, Path_Order => Path_Order, Continue => Continue); exit when not Continue; end if; exception when Ada.Directories.Name_Error | Ada.Directories.Use_Error => null; when Ignore_Compiler => -- Nothing to do, the compiler has not been inserted null; end; Next (C); end loop; end if; Put_Verbose ("", -1); end Foreach_Compiler_In_Dir; ------------------------------ -- Foreach_Compiler_In_Path -- ------------------------------ procedure Foreach_Compiler_In_Path (Iterator : in out Compiler_Iterator; Base : in out Knowledge_Base; On_Target : Targets_Set_Id; Extra_Dirs : String := "") is Dirs : String_Lists.List; Map : String_Lists.List; procedure Process_Path (Path : String; Prefix : Character; Prepend_To_List : Boolean); -- Add a directory to the list of directories to examine ------------------ -- Process_Path -- ------------------ procedure Process_Path (Path : String; Prefix : Character; Prepend_To_List : Boolean) is First, Last : Natural; begin First := Path'First; while First <= Path'Last loop -- Skip null entries on PATH if Path (First) = GNAT.OS_Lib.Path_Separator then First := First + 1; else Last := First + 1; while Last <= Path'Last and then Path (Last) /= GNAT.OS_Lib.Path_Separator loop Last := Last + 1; end loop; declare -- Use a hash to make sure we do not parse the same -- directory twice. This is both more efficient and avoids -- duplicates in the final result list. To handle the case -- of links (on linux for instance /usr/bin/X11 points to -- ".", ie /usr/bin, and compilers would appear duplicated), -- we resolve symbolic links. This call is also set to fold -- to lower-case when appropriate Normalized : constant String := Name_As_Directory (Normalize_Pathname (Path (First .. Last - 1), Resolve_Links => True, Case_Sensitive => False)); begin if not Contains (Map, Normalized) then Append (Map, Normalized); -- Rerun normalize_pathname without resolve_links so that -- the displayed path looks familiar to the user (no .., -- ./ or quotes, but still using the path as shown in -- $PATH) declare Final_Path : constant String := Normalize_Pathname (Path (First .. Last - 1), Resolve_Links => False, Case_Sensitive => False); begin -- Windows is somewhat slow at parsing directories, do -- not look into any directory under C:\windows as -- there is no compiler to be found there anyway. if not On_Windows or else (Final_Path'Length > 10 and then To_Lower (Final_Path (Final_Path'First .. Final_Path'First + 9)) /= "c:\windows") then Put_Verbose ("Will examine " & Prefix & " " & Final_Path); if Prepend_To_List then Prepend (Dirs, Prefix & Final_Path); else Append (Dirs, Prefix & Final_Path); end if; end if; end; end if; end; First := Last + 1; end if; end loop; end Process_Path; Dir : String_Lists.Cursor; Path_Order : Positive := 1; Continue : Boolean; begin -- Preprocess the list of directories that will be searched. When a -- directory appears both in Extra_Dirs and in Path, we prepend it to -- the PATH for optimization purposes: no need to look in all the PATH -- if the compiler(s) will match in that directory. However, this has -- the result that a command line with --config that specifies a path -- and one that doesn't might find the second compiler in the same -- path even if it is not the first one on the PATH. That's minor, and -- a workaround is for the user to specify path for all --config args. -- -- We will also need to know later whether the directory comes from -- PATH or extra_dirs. If a directory appears in both, it is said to -- come from PATH, so that all its compilers are taken into account. -- As a special convention, the first character of the directory name is -- set to 'E' if the dir comes from extra_dirs, or 'P' if it comes from -- PATH. if Ada.Environment_Variables.Exists ("PATH") then Process_Path (Ada.Environment_Variables.Value ("PATH"), 'P', False); end if; if Extra_Dirs /= "" then Process_Path (Extra_Dirs, 'E', Prepend_To_List => True); end if; Dir := First (Dirs); while Has_Element (Dir) loop declare P : constant String := String_Lists.Element (Dir); begin Foreach_Compiler_In_Dir (Iterator => Iterator, Base => Base, Directory => P (P'First + 1 .. P'Last), From_Extra_Dir => P (P'First) = 'E', Path_Order => Path_Order, On_Target => On_Target, Continue => Continue); exit when not Continue; end; Path_Order := Path_Order + 1; Next (Dir); end loop; end Foreach_Compiler_In_Path; -------------------------- -- Known_Compiler_Names -- -------------------------- procedure Known_Compiler_Names (Base : Knowledge_Base; List : out Ada.Strings.Unbounded.Unbounded_String) is use CDM; C : CDM.Cursor := First (Base.Compilers); begin List := Null_Unbounded_String; while Has_Element (C) loop if List /= Null_Unbounded_String then Append (List, ","); end if; Append (List, Get_Name_String (Key (C))); Next (C); end loop; end Known_Compiler_Names; ----------- -- Match -- ----------- procedure Match (Filter : Compilers_Filter; Compilers : Compiler_Lists.List; Matching_Compiler : out Compiler_Access; Matched : out Boolean) is C : CFL.Cursor := First (Filter.Compiler); M : Boolean; begin while Has_Element (C) loop Match (CFL.Element (C), Compilers, Matching_Compiler, M); if M then Matched := not Filter.Negate; return; end if; Next (C); end loop; Matched := Filter.Negate; end Match; ------------------ -- Filter_Match -- ------------------ function Filter_Match (Base : Knowledge_Base; Comp : Compiler; Filter : Compiler) return Boolean is begin if Filter.Name /= No_Name and then Comp.Name /= Filter.Name and then Comp.Base_Name /= Filter.Name then if Current_Verbosity /= Default then Put_Verbose ("Filter=" & To_String (Base, Filter, True) & ": name does not match"); end if; return False; end if; if Filter.Path /= No_Name and then Filter.Path /= Comp.Path then if Current_Verbosity /= Default then Put_Verbose ("Filter=" & To_String (Base, Filter, True) & ": path does not match"); end if; return False; end if; if Filter.Version /= No_Name and then Filter.Version /= Comp.Version then if Current_Verbosity /= Default then Put_Verbose ("Filter=" & To_String (Base, Filter, True) & ": version does not match"); end if; return False; end if; if Comp.Any_Runtime then -- If compiler has no runtime node all runtimes should be accepted, -- no need to apply filter. if Filter.Runtime /= No_Name then if not Is_Absolute_Path (Get_Name_String (Filter.Runtime)) and then Filter.Runtime /= Comp.Runtime and then Filter.Runtime /= Comp.Alt_Runtime then if Current_Verbosity /= Default then Put_Verbose ("Filter=" & To_String (Base, Filter, True) & ": runtime does not match"); end if; return False; end if; elsif not Comp.Default_Runtime then if Current_Verbosity /= Default then Put_Verbose ("Filter=" & To_String (Base, Filter, True) & ": no default runtime"); end if; return False; end if; end if; if Filter.Language_LC /= No_Name and then Filter.Language_LC /= Comp.Language_LC then if Current_Verbosity /= Default then Put_Verbose ("Filter=" & To_String (Base, Filter, True) & ": language does not match"); end if; return False; end if; return True; end Filter_Match; ----------- -- Match -- ----------- procedure Match (Filter : Compiler_Filter; Compilers : Compiler_Lists.List; Matching_Compiler : out Compiler_Access; Matched : out Boolean) is C : Compiler_Lists.Cursor := First (Compilers); Comp : Compiler_Access; function Runtime_Base_Name (Rt : Name_Id) return String is (GNAT.Directory_Operations.Base_Name (Get_Name_String (Rt))); -- Runtime filters should only apply to the base name of runtime when -- full path is given, otherwise we can potentially match some unrelated -- patterns from enclosing directory names. begin while Has_Element (C) loop Comp := Compiler_Lists.Element (C); if Comp.Selected and then (Filter.Name = No_Name or else (Comp.Name /= No_Name and then Match (Filter.Name_Re.all, Get_Name_String (Comp.Name))) or else Comp.Base_Name = Filter.Name) and then (Filter.Version_Re = null or else (Comp.Version /= No_Name and then Match (Filter.Version_Re.all, Get_Name_String (Comp.Version)))) and then (Filter.Runtime_Re = null or else (Comp.Runtime /= No_Name and then Match (Filter.Runtime_Re.all, Runtime_Base_Name (Comp.Runtime)))) and then (Filter.Language_LC = No_Name or else Filter.Language_LC = Comp.Language_LC) then Matching_Compiler := Comp; Matched := True; return; end if; Next (C); end loop; Matched := False; end Match; ----------- -- Match -- ----------- procedure Match (Filter : Compilers_Filter_Lists.List; Compilers : Compiler_Lists.List; Matching_Compiler : out Compiler_Access; Matched : out Boolean) is C : Compilers_Filter_Lists.Cursor := First (Filter); M : Boolean; begin while Has_Element (C) loop Match (Compilers_Filter_Lists.Element (C), Compilers, Matching_Compiler, M); if not M then Matched := False; return; end if; Next (C); end loop; if Length (Filter) /= 1 then Matching_Compiler := null; end if; Matched := True; end Match; ----------- -- Match -- ----------- function Match (Target_Filter : Double_String_Lists.List; Negate : Boolean; Compilers : Compiler_Lists.List) return Boolean is Target : Double_String_Lists.Cursor := First (Target_Filter); Comp : Compiler_Lists.Cursor; begin if Is_Empty (Target_Filter) then return True; else while Has_Element (Target) loop declare Positive_Pattern : constant Pattern_Matcher := Compile (To_String (Double_String_Lists.Element (Target).Positive_Regexp), GNAT.Regpat.Case_Insensitive); Negative_Pattern : constant Pattern_Matcher := Compile (To_String (Double_String_Lists.Element (Target).Negative_Regexp), GNAT.Regpat.Case_Insensitive); Ignore_Negative : constant Boolean := Double_String_Lists.Element (Target).Negative_Regexp = ""; begin Comp := First (Compilers); while Has_Element (Comp) loop if Compiler_Lists.Element (Comp).Selected then if Compiler_Lists.Element (Comp).Target = No_Name then if Match (Positive_Pattern, "") then return not Negate; end if; elsif Match (Positive_Pattern, Get_Name_String (Compiler_Lists.Element (Comp).Target)) and then (Ignore_Negative or else not Match (Negative_Pattern, Get_Name_String (Compiler_Lists.Element (Comp).Target))) then return not Negate; end if; end if; Next (Comp); end loop; end; Next (Target); end loop; return Negate; end if; end Match; ----------------- -- Skip_Spaces -- ----------------- procedure Skip_Spaces (Str : String; Index : in out Integer) is begin while Index <= Str'Last and then (Str (Index) = ' ' or else Str (Index) = ASCII.LF) loop Index := Index + 1; end loop; end Skip_Spaces; procedure Skip_Spaces_Backward (Str : String; Index : in out Integer) is begin while Index >= Str'First and then (Str (Index) = ' ' or else Str (Index) = ASCII.LF) loop Index := Index - 1; end loop; end Skip_Spaces_Backward; ------------------ -- Merge_Config -- ------------------ procedure Merge_Config (Base : Knowledge_Base; Packages : in out String_Maps.Map; Compilers : Compiler_Lists.List; Config : String) is procedure Add_Package (Name : String; Chunk : String; Prefix : String := " "); -- Add the chunk in the appropriate package ----------------- -- Add_Package -- ----------------- procedure Add_Package (Name : String; Chunk : String; Prefix : String := " ") is C : constant String_Maps.Cursor := Find (Packages, Name); Replaced : constant String := Substitute_Variables_In_Configuration (Base, Chunk, Compilers); begin if Replaced /= "" then if Has_Element (C) then Replace_Element (Packages, C, String_Maps.Element (C) & ASCII.LF & Prefix & Replaced); else Insert (Packages, Name, Prefix & To_Unbounded_String (Replaced)); end if; end if; end Add_Package; First : Integer := Config'First; Pkg_Name_First, Pkg_Name_Last : Integer; Pkg_Content_First : Integer; Last : Integer; begin while First /= 0 and then First <= Config'Last loop -- Do we have a toplevel attribute ? Skip_Spaces (Config, First); Pkg_Name_First := Index (Config (First .. Config'Last), "package "); if Pkg_Name_First = 0 then Pkg_Name_First := Config'Last + 1; end if; Last := Pkg_Name_First - 1; Skip_Spaces_Backward (Config, Last); Add_Package (Name => "", Chunk => Config (First .. Last), Prefix => " "); exit when Pkg_Name_First > Config'Last; -- Parse the current package Pkg_Name_First := Pkg_Name_First + 8; -- skip "package " Skip_Spaces (Config, Pkg_Name_First); Pkg_Name_Last := Pkg_Name_First + 1; while Pkg_Name_Last <= Config'Last and then Config (Pkg_Name_Last) /= ' ' and then Config (Pkg_Name_Last) /= ASCII.LF loop Pkg_Name_Last := Pkg_Name_Last + 1; end loop; Pkg_Content_First := Pkg_Name_Last + 1; Skip_Spaces (Config, Pkg_Content_First); Pkg_Content_First := Pkg_Content_First + 2; -- skip "is" Skip_Spaces (Config, Pkg_Content_First); Last := Index (Config (Pkg_Content_First .. Config'Last), "end " & Config (Pkg_Name_First .. Pkg_Name_Last - 1)); if Last /= 0 then First := Last - 1; Skip_Spaces_Backward (Config, First); Add_Package (Name => Config (Pkg_Name_First .. Pkg_Name_Last - 1), Chunk => Config (Pkg_Content_First .. First)); while Last <= Config'Last and then Config (Last) /= ';' loop Last := Last + 1; end loop; Last := Last + 1; end if; First := Last; end loop; end Merge_Config; ----------------- -- Put_Verbose -- ----------------- procedure Put_Verbose (Config : Configuration) is C : Compilers_Filter_Lists.Cursor := First (Config.Compilers_Filters); Comp_Filter : Compilers_Filter; Comp : Compiler_Filter_Lists.Cursor; Filter : Compiler_Filter; begin while Has_Element (C) loop Comp_Filter := Compilers_Filter_Lists.Element (C); Put_Verbose ("", 1); Comp := First (Comp_Filter.Compiler); while Has_Element (Comp) loop Filter := Compiler_Filter_Lists.Element (Comp); Put_Verbose (""); Next (Comp); end loop; Put_Verbose ("", -1); Next (C); end loop; Put_Verbose (""); end Put_Verbose; ------------------------- -- Is_Supported_Config -- ------------------------- function Is_Supported_Config (Base : Knowledge_Base; Compilers : Compiler_Lists.List) return Boolean is Config : Configuration_Lists.Cursor := First (Base.Configurations); M : Boolean; Matching_Compiler : Compiler_Access; begin while Has_Element (Config) loop Match (Configuration_Lists.Element (Config).Compilers_Filters, Compilers, Matching_Compiler, M); if M and then Match (Configuration_Lists.Element (Config).Targets_Filters, Configuration_Lists.Element (Config).Negate_Targets, Compilers) then if not Configuration_Lists.Element (Config).Supported then if Current_Verbosity /= Default then Put_Verbose ("Selected compilers are not compatible, because of:"); Put_Verbose (Configuration_Lists.Element (Config)); end if; return False; end if; end if; Next (Config); end loop; return True; end Is_Supported_Config; ---------------------------- -- Generate_Configuration -- ---------------------------- procedure Generate_Configuration (Base : Knowledge_Base; Compilers : Compiler_Lists.List; Output_File : String; Target : String; Selected_Targets_Set : Targets_Set_Id) is Config : Configuration_Lists.Cursor := First (Base.Configurations); Output : File_Type; Packages : String_Maps.Map; Selected_Compiler : Compiler_Access; M : Boolean; Project_Name : constant String := "Default"; procedure Gen (C : String_Maps.Cursor); -- C is a cursor of the map "Packages" -- Generate the chunk of the config file corresponding to the -- given package. procedure Gen_And_Remove (Name : String); -- Generate the chunk of the config file corresponding to the -- package name and remove it from the map. --------- -- Gen -- --------- procedure Gen (C : String_Maps.Cursor) is begin if Key (C) /= "" then New_Line (Output); Put_Line (Output, " package " & Key (C) & " is"); end if; Put_Line (Output, To_String (String_Maps.Element (C))); if Key (C) /= "" then Put_Line (Output, " end " & Key (C) & ";"); end if; end Gen; -------------------- -- Gen_And_Remove -- -------------------- procedure Gen_And_Remove (Name : String) is C : String_Maps.Cursor := Find (Packages, Name); begin if Has_Element (C) then Gen (C); Delete (Packages, C); end if; end Gen_And_Remove; begin while Has_Element (Config) loop Match (Configuration_Lists.Element (Config).Compilers_Filters, Compilers, Selected_Compiler, M); if M and then Match (Configuration_Lists.Element (Config).Targets_Filters, Configuration_Lists.Element (Config).Negate_Targets, Compilers) then if not Configuration_Lists.Element (Config).Supported then Put_Line (Standard_Error, "Code generated by these compilers cannot be linked" & " as far as we know."); return; end if; Merge_Config (Base, Packages, Compilers, Get_Name_String (Configuration_Lists.Element (Config).Config)); end if; Next (Config); end loop; if Is_Empty (Packages) then Put_Line (Standard_Error, "No valid configuration found"); raise Generate_Error; end if; Put_Verbose ("Creating configuration file: " & Output_File); Create (Output, Out_File, Output_File); Put_Line (Output, "-- This gpr configuration file was generated by gprconfig"); Put_Line (Output, "-- using this command line:"); Put (Output, "-- " & Command_Name); for I in 1 .. Argument_Count loop Put (Output, ' '); Put (Output, Argument (I)); end loop; New_Line (Output); Put (Output, "-- from "); Put (Output, Get_Current_Dir); New_Line (Output); Put_Line (Output, "configuration project " & Project_Name & " is"); if Target'Length > 0 and then Target /= "all" then Put_Line (Output, " for Target use """ & Target & """;"); Put_Line (Output, " for Canonical_Target use """ & Normalized_Target (Base, Selected_Targets_Set) & """;"); end if; -- Generate known packages in order. This takes care of possible -- dependencies. Gen_And_Remove (""); Gen_And_Remove ("Builder"); Gen_And_Remove ("Compiler"); Gen_And_Remove ("Naming"); Gen_And_Remove ("Binder"); Gen_And_Remove ("Linker"); -- Generate remaining packages Iterate (Packages, Gen'Access); Put_Line (Output, "end " & Project_Name & ";"); Close (Output); exception when Ada.Directories.Name_Error | Ada.IO_Exceptions.Use_Error => Put_Line (Standard_Error, "Could not create the file " & Output_File); raise Generate_Error; end Generate_Configuration; ----------------------- -- Query_Targets_Set -- ----------------------- function Query_Targets_Set (Base : Knowledge_Base; Target : String) return Targets_Set_Id is use Targets_Set_Vectors; use Target_Lists; begin if Target = "" then return All_Target_Sets; end if; for I in First_Index (Base.Targets_Sets) .. Last_Index (Base.Targets_Sets) loop declare Set : constant Target_Lists.List := Targets_Set_Vectors.Element (Base.Targets_Sets, I).Patterns; C : Target_Lists.Cursor := First (Set); begin while Has_Element (C) loop if GNAT.Regpat.Match (Target_Lists.Element (C).all, Target & "") > Target'First - 1 then return I; end if; Next (C); end loop; end; end loop; return Unknown_Targets_Set; end Query_Targets_Set; ---------------------- -- Get_Targets_Set -- ---------------------- procedure Get_Targets_Set (Base : in out Knowledge_Base; Target : String; Id : out Targets_Set_Id) is begin Id := Query_Targets_Set (Base, Target); if Id /= Unknown_Targets_Set then return; end if; -- Create a new set declare Set : Target_Lists.List; begin Put_Verbose ("create a new target set for " & Target); Set.Append (new Pattern_Matcher'(Compile ("^" & Quote (Target) & "$"))); Base.Targets_Sets.Append ((Get_String (Target), Set), 1); Id := Base.Targets_Sets.Last_Index; end; end Get_Targets_Set; ----------------------- -- Normalized_Target -- ----------------------- function Normalized_Target (Base : Knowledge_Base; Set : Targets_Set_Id) return String is Result : Target_Set_Description; begin Result := Targets_Set_Vectors.Element (Base.Targets_Sets, Set); return Get_Name_String (Result.Name); exception when others => return "unknown"; end Normalized_Target; ---------------- -- Get_String -- ---------------- function Get_String (Str : String) return Name_Id is begin Name_Len := Str'Length; Name_Buffer (1 .. Name_Len) := Str; return Name_Find; end Get_String; -------------------------- -- Get_String_No_Adalib -- -------------------------- function Get_String_No_Adalib (Str : String) return Name_Id is Name : constant String (1 .. Str'Length) := Str; Last : Natural := Name'Last; begin if Last > 7 and then (Name (Last) = Directory_Separator or else Name (Last) = '/') then Last := Last - 1; end if; if Last > 6 and then Name (Last - 5 .. Last) = "adalib" and then (Name (Last - 6) = Directory_Separator or else Name (Last - 6) = '/') then Last := Last - 6; else Last := Name'Last; end if; Name_Len := Last; Name_Buffer (1 .. Last) := Name (1 .. Last); return Name_Find; end Get_String_No_Adalib; --------------------------- -- Get_String_Or_No_Name -- --------------------------- function Get_String_Or_No_Name (Str : String) return Name_Id is begin if Str = "" then return No_Name; else Name_Len := Str'Length; Name_Buffer (1 .. Name_Len) := Str; return Name_Find; end if; end Get_String_Or_No_Name; ------------------- -- Set_Selection -- ------------------- procedure Set_Selection (Compilers : in out Compiler_Lists.List; Cursor : Compiler_Lists.Cursor; Selected : Boolean) is procedure Internal (Comp : in out Compiler_Access); -------------- -- Internal -- -------------- procedure Internal (Comp : in out Compiler_Access) is begin Set_Selection (Comp.all, Selected); end Internal; begin Update_Element (Compilers, Cursor, Internal'Access); end Set_Selection; ------------------- -- Set_Selection -- ------------------- procedure Set_Selection (Comp : in out Compiler; Selected : Boolean) is begin Comp.Selected := Selected; end Set_Selection; ----------------------------- -- Extra_Dirs_From_Filters -- ----------------------------- function Extra_Dirs_From_Filters (Filters : Compiler_Lists.List) return String is C : Compiler_Lists.Cursor := First (Filters); Extra_Dirs : Unbounded_String; Elem : Compiler_Access; begin while Has_Element (C) loop Elem := Compiler_Lists.Element (C); if Elem.Path /= No_Name then Append (Extra_Dirs, Get_Name_String (Elem.Path) & Path_Separator); end if; Next (C); end loop; return To_String (Extra_Dirs); end Extra_Dirs_From_Filters; ------------------------------------- -- Complete_Command_Line_Compilers -- ------------------------------------- procedure Complete_Command_Line_Compilers (Base : in out Knowledge_Base; On_Target : Targets_Set_Id; Filters : Compiler_Lists.List; Compilers : in out Compiler_Lists.List; Target_Specified : Boolean; Selected_Target : in out Unbounded_String) is type Cursor_Array is array (Count_Type range <>) of Compiler_Lists.Cursor; type Boolean_Array is array (Count_Type range <>) of Boolean; type Batch_Iterator (Count : Count_Type) is new Compiler_Iterator with record Found : Count_Type := 0; Compilers : Compiler_Lists.List; Matched : Cursor_Array (1 .. Count) := (others => Compiler_Lists.No_Element); Filters : Compiler_Lists.List; Found_One : Boolean_Array (1 .. Count) := (others => False); -- Whether we found at least one matching compiler for each filter end record; procedure Callback (Iterator : in out Batch_Iterator; Base : in out Knowledge_Base; Comp : Compiler; Runtime_Specified : Boolean; From_Extra_Dir : Boolean; Continue : out Boolean); -- Search the first compiler matching each --config command line -- argument. -------------- -- Callback -- -------------- procedure Callback (Iterator : in out Batch_Iterator; Base : in out Knowledge_Base; Comp : Compiler; Runtime_Specified : Boolean; From_Extra_Dir : Boolean; Continue : out Boolean) is C : Compiler_Lists.Cursor := First (Iterator.Filters); Index : Count_Type := 1; Ncomp : Compiler_Access; El : Compiler_Access; begin while Has_Element (C) loop Ncomp := null; El := Compiler_Lists.Element (C); -- A compiler in an "extra_dir" (ie specified on the command line) -- can only match if that directory was explicitly specified in -- --config. We do not want to find all compilers in /dir if that -- directory is not in $PATH if (not From_Extra_Dir or else El.Path = Comp.Path) and then Filter_Match (Base, Comp => Comp, Filter => El.all) and then (not Runtime_Specified or El.Runtime_Dir /= No_Name) then Ncomp := new Compiler'(Comp); if El.Runtime_Dir /= No_Name then Ncomp.Runtime_Dir := El.Runtime_Dir; Ncomp.Runtime := El.Runtime; end if; if not Ncomp.Any_Runtime and then Ncomp.Runtime = No_Name and then El.Runtime /= No_Name then Ncomp.Runtime := El.Runtime; end if; Append (Iterator.Compilers, Ncomp); if Current_Verbosity /= Default then Put_Verbose ("Saving compiler for possible backtracking: " & To_String (Base, Ncomp.all, As_Config_Arg => True) & " (matches --config " & To_String (Base, El.all, As_Config_Arg => True) & ")"); end if; if Iterator.Matched (Index) = Compiler_Lists.No_Element then Iterator.Found := Iterator.Found + 1; Put_Verbose ("Selecting it since this filter was not matched yet " & Iterator.Found'Img & "/" & Iterator.Count'Img); Iterator.Matched (Index) := Last (Iterator.Compilers); Iterator.Found_One (Index) := True; Set_Selection (Iterator.Compilers, Iterator.Matched (Index), True); -- Only keep those compilers that are not incompatible -- (according to the knowledge base). It might happen that -- none is selected as a result, but appropriate action is -- taken in Complete_Command_Line_Compilers. We ignore -- incompatible sets as early as possible, in the hope to -- limit the number of system calls if another set is found -- before all directories are traversed. if not Is_Supported_Config (Base, Iterator.Compilers) then Set_Selection (Iterator.Compilers, Iterator.Matched (Index), False); Put_Verbose ("Compilers are not compatible, cancelling last" & " compiler found"); Iterator.Matched (Index) := Compiler_Lists.No_Element; Iterator.Found := Iterator.Found - 1; end if; end if; end if; Index := Index + 1; Next (C); end loop; -- Stop at first compiler Continue := Iterator.Found /= Iterator.Count; end Callback; Iter : Batch_Iterator (Length (Filters)); function Foreach_Nth_Compiler (Filter : Compiler_Lists.Cursor) return Boolean; -- For all possible compiler matching the filter, check whether we -- find a compatible set of compilers matching the next filters. -- Return True if one was found (in which case it is the current -- selection on exit). -------------------------- -- Foreach_Nth_Compiler -- -------------------------- function Foreach_Nth_Compiler (Filter : Compiler_Lists.Cursor) return Boolean is C : Compiler_Lists.Cursor := First (Iter.Compilers); Comp_Filter : constant Compiler_Access := Compiler_Lists.Element (Filter); begin while Has_Element (C) loop if Filter_Match (Base, Compiler_Lists.Element (C).all, Filter => Comp_Filter.all) then Set_Selection (Iter.Compilers, C, True); if Next (Filter) = Compiler_Lists.No_Element then if Current_Verbosity /= Default then Put_Verbose ("Testing the following compiler set:", 1); Put_Verbose (To_String (Base, Iter.Compilers, Selected_Only => True)); end if; if Is_Supported_Config (Base, Iter.Compilers) then Put_Verbose ("They are compatible", -1); return True; else Put_Verbose ("", -1); end if; else if Foreach_Nth_Compiler (Next (Filter)) then return True; end if; end if; Set_Selection (Iter.Compilers, C, False); end if; Next (C); end loop; return False; end Foreach_Nth_Compiler; C : Compiler_Lists.Cursor; Extra_Dirs : constant String := Extra_Dirs_From_Filters (Filters); Found_All : Boolean := True; Found_All_Fallback : Boolean := True; begin Iter.Filters := Filters; Put_Verbose ("Completing info for --config parameters, extra_dirs=" & Extra_Dirs, 1); -- Find all the compilers in PATH and Extra_Dirs Foreach_Compiler_In_Path (Iterator => Iter, Base => Base, On_Target => On_Target, Extra_Dirs => Extra_Dirs); Put_Verbose ("", -1); -- Check that we could find at least one of each compiler if Native_Target then -- Check to see if fallback targets are of interest C := First (Filters); for F in Iter.Found_One'Range loop if not Iter.Found_One (F) then if Languages_Known.Contains (Compiler_Lists.Element (C).Language_LC) then -- Fallback should not be triggered for unknown languages Found_All_Fallback := False; end if; Found_All := False; end if; Next (C); end loop; if not Found_All_Fallback then -- Looking for corresponding fallback set declare Fallback_List : constant String_Lists.List := Get_Fallback_List (Base, On_Target); Cur : String_Lists.Cursor := Fallback_List.First; begin while Cur /= String_Lists.No_Element loop Put_Verbose ("Attempting to fall back to target " & String_Lists.Element (Cur)); declare Local_Iter : Batch_Iterator (Length (Filters)); begin Local_Iter := Iter; Foreach_Compiler_In_Path (Iterator => Local_Iter, Base => Base, On_Target => Query_Targets_Set (Base, String_Lists.Element (Cur)), Extra_Dirs => Extra_Dirs); Found_All := True; C := First (Filters); for F in Local_Iter.Found_One'Range loop if not Local_Iter.Found_One (F) and then Languages_Known.Contains (Compiler_Lists.Element (C).Language_LC) then -- Not finding a compiler for an unknown language -- should not invalidate fallback search. Found_All := False; end if; Next (C); end loop; if Found_All then Iter := Local_Iter; Selected_Target := To_Unbounded_String (String_Lists.Element (Cur)); Put_Verbose (String_Lists.Element (Cur) & " fallback target selected"); exit; end if; end; Next (Cur); end loop; end; end if; end if; C := First (Filters); for F in Iter.Found_One'Range loop if not Iter.Found_One (F) then declare Comp : constant Compiler := Compiler_Lists.Element (C).all; Specified_Target : Boolean := Target_Specified; Language_Known : constant Boolean := Known_Languages.Contains (Container => Languages_Known, Key => Comp.Language_LC); begin -- Display an error when not in quiet mode or when the language -- is described in the database. if not Language_Known then if not Opt.Quiet_Output then Put (Standard_Error, "Error: unknown language '"); Put (Standard_Error, Get_Name_String_Or_Null (Comp.Language_Case)); Put (Standard_Error, "'"); New_Line (Standard_Error); end if; else if Specified_Target then declare Selected_Targets_Set : Targets_Set_Id; begin Get_Targets_Set (Base, Sdefault.Hostname, Selected_Targets_Set); declare Default_Target : constant String := Normalized_Target (Base, Selected_Targets_Set); begin Get_Targets_Set (Base, To_String (Selected_Target), Selected_Targets_Set); Specified_Target := Selected_Targets_Set = All_Target_Sets or else Normalized_Target (Base, Selected_Targets_Set) /= Default_Target; end; end; end if; if Specified_Target then Put (Standard_Error, "gprconfig: can't find a toolchain " & "for the following configuration:"); New_Line (Standard_Error); Put (Standard_Error, "gprconfig: language '" & Get_Name_String_Or_Null (Comp.Language_Case)); Put (Standard_Error, "', target '"); declare Tgt : constant String := To_String (Selected_Target); begin if Tgt = "" then Put (Standard_Error, "all'"); else Put (Standard_Error, Tgt & "'"); end if; end; if Comp.Runtime = No_Name then Put (Standard_Error, ", default runtime"); else Put (Standard_Error, ", runtime '" & Get_Name_String_Safe (Comp.Runtime) & "'"); end if; else Put (Standard_Error, "gprconfig: " & "can't find a native toolchain for language '"); Put (Standard_Error, Get_Name_String_Or_Null (Comp.Language_Case)); Put (Standard_Error, "'"); if Comp.Runtime /= No_Name then Put (Standard_Error, ", runtime '" & Get_Name_String_Safe (Comp.Runtime) & "'"); end if; end if; Ada.Command_Line.Set_Exit_Status (1); New_Line (Standard_Error); end if; end; Found_All := False; end if; Next (C); end loop; -- If we could find at least one of each compiler, but that our initial -- attempt returned incompatible sets of compiler, we do a more thorough -- attempt now if Found_All and then Iter.Found /= Iter.Count then -- If no compatible set was found, try all possible combinations, in -- the hope that we can finally find one. In the following algorithm, -- we end up checking again some set that were checked in Callback, -- but that would be hard to avoid since the compilers can be found -- in any order. Put_Verbose ("Attempting to find a supported compiler set", 1); -- Unselect all compilers C := First (Iter.Compilers); while Has_Element (C) loop Set_Selection (Iter.Compilers, C, False); Next (C); end loop; if not Foreach_Nth_Compiler (First (Iter.Filters)) then Put_Line (Standard_Error, "Error: no set of compatible compilers was found"); raise Invalid_Config; end if; Put_Verbose ("", -1); end if; Splice (Target => Compilers, Before => Compiler_Lists.No_Element, Source => Iter.Compilers); end Complete_Command_Line_Compilers; -------------------------------------- -- Default_Knowledge_Base_Directory -- -------------------------------------- function Default_Knowledge_Base_Directory return String is Prog_Dir : constant String := Executable_Prefix_Path; Suffix : constant String := "share" & Directory_Separator & "gprconfig"; begin return Prog_Dir & Suffix; end Default_Knowledge_Base_Directory; -------------------- -- Display_Before -- -------------------- function Display_Before (Comp1, Comp2 : Compiler_Access) return Boolean is type Compare_Type is (Before, Equal, After); function Compare (Name1, Name2 : Name_Id) return Compare_Type; -- Compare alphabetically two strings ------------- -- Compare -- ------------- function Compare (Name1, Name2 : Name_Id) return Compare_Type is begin if Name1 = No_Name then if Name2 = No_Name then return Equal; else return Before; end if; elsif Name2 = No_Name then return After; end if; Get_Name_String (Name1); declare Str1 : constant String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); begin Get_Name_String (Name2); if Str1 < Name_Buffer (1 .. Name_Len) then return Before; elsif Str1 > Name_Buffer (1 .. Name_Len) then return After; else return Equal; end if; end; end Compare; begin case Compare (Comp1.Language_LC, Comp2.Language_LC) is when Before => return True; when After => return False; when Equal => if Comp1.Path_Order < Comp2.Path_Order then return True; elsif Comp2.Path_Order < Comp1.Path_Order then return False; else -- If the "default" attribute was specified for , -- this only impacts the batch mode. We still want to sort -- the runtimes alphabetically in the interactive display. case Compare (Comp1.Runtime, Comp2.Runtime) is when Before => return True; when After => return False; when Equal => return Compare (Comp1.Version, Comp2.Version) = Before; end case; end if; end case; end Display_Before; ---------------------------- -- Parse_Config_Parameter -- ---------------------------- procedure Parse_Config_Parameter (Base : Knowledge_Base; Config : String; Compiler : out Compiler_Access; Requires_Compiler : out Boolean) is Map : String_Lists.List; C : String_Lists.Cursor; Comma_Counter : Natural := 0; function Positional_Parameters return Boolean; -- Returns True if configuration parameters are given in a positional -- form, -- i.e. --config=language:ada,runtime:sjlj -- Also checks that the two modes are not mixed up and raises -- Invalid_Config otherwise. procedure Process_Positional_Parameters; -- Puts named parameters in proper order into Map list, also checks for -- duplicate parameter names. function Positional_Parameters return Boolean is Cur : String_Lists.Cursor; Positional_Present : Boolean := False; Not_Positional_Present : Boolean := False; begin Cur := First (Map); while Cur /= String_Lists.No_Element loop declare S : constant String := To_Lower (String_Lists.Element (Cur)); begin if S /= "" then if Index (S, "language:") = 0 and then Index (S, "version:") = 0 and then Index (S, "runtime:") = 0 and then Index (S, "path:") = 0 and then Index (S, "name:") = 0 then if Positional_Present then Put_Line (Standard_Error, "Mixing positional and not " & "positional parameters in """ & Config & """"); raise Invalid_Config; end if; Not_Positional_Present := True; else if Not_Positional_Present then Put_Line (Standard_Error, "Mixing positional and not " & "positional parameters in """ & Config & """"); raise Invalid_Config; end if; Positional_Present := True; end if; end if; end; Next (Cur); end loop; return Positional_Present; end Positional_Parameters; procedure Process_Positional_Parameters is Cur : String_Lists.Cursor := Map.First; package Parameter_Maps is new Ada.Containers.Indefinite_Hashed_Maps (String, String, Ada.Strings.Hash, "="); Parameter_Map : Parameter_Maps.Map; begin Parameter_Map.Include ("language", ""); Parameter_Map.Include ("version", ""); Parameter_Map.Include ("runtime", ""); Parameter_Map.Include ("path", ""); Parameter_Map.Include ("name", ""); while Cur /= String_Lists.No_Element loop if String_Lists.Element (Cur) = "" then goto Next_Element; end if; declare S : constant String := String_Lists.Element (Cur); Idx : Integer; begin Idx := Index (S, ":"); if Idx = S'First then Put_Line (Standard_Error, "Parameter name not specified in """ & Config & """"); raise Invalid_Config; end if; if Idx = S'Last then Put_Line (Standard_Error, "Parameter value not specified in """ & Config & """"); raise Invalid_Config; end if; declare P_Name : constant String := To_Lower (S (S'First .. Idx - 1)); P_Val : constant String := S (Idx + 1 .. S'Last); begin if not Parameter_Map.Contains (P_Name) then Put_Line (Standard_Error, "Unknown configuration parameter """ & S (S'First .. Idx - 1) & """"); raise Invalid_Config; end if; if Parameter_Map.Element (P_Name) /= "" then Put_Line (Standard_Error, "Configuration parameter """ & P_Name & """ specified twice"); raise Invalid_Config; end if; Parameter_Map.Replace (P_Name, P_Val); end; end; <> Next (Cur); end loop; Map.Clear; Map.Append (Parameter_Map.Element ("language")); Map.Append (Parameter_Map.Element ("version")); Map.Append (Parameter_Map.Element ("runtime")); Map.Append (Parameter_Map.Element ("path")); Map.Append (Parameter_Map.Element ("name")); Parameter_Map.Clear; end Process_Positional_Parameters; begin -- Not more than 4 commas can be in valid configuration. for I in Config'Range loop if Config (I) = ',' then Comma_Counter := Comma_Counter + 1; end if; end loop; if Comma_Counter > 4 then Put_Line (Standard_Error, "Too many arguments in configuration """ & Config & """"); raise Invalid_Config; end if; -- Only valid separator is ',', not spaces Get_Words (Config, Filter => No_Name, Map => Map, Separator1 => ',', Separator2 => ',', Allow_Empty_Elements => True); if Positional_Parameters then Process_Positional_Parameters; end if; Compiler := new Knowledge.Compiler; C := First (Map); declare LC : constant String := To_Lower (String_Lists.Element (C)); begin Compiler.Language_Case := Get_String_Or_No_Name (String_Lists.Element (C)); Compiler.Language_LC := Get_String_Or_No_Name (LC); if Is_Language_With_No_Compiler (Base, LC) then Put_Verbose ("Language " & LC & " requires no compiler"); Compiler.Complete := True; Compiler.Selected := True; Compiler.Targets_Set := All_Target_Sets; Requires_Compiler := False; else Requires_Compiler := True; Next (C); if Has_Element (C) then Compiler.Version := Get_String_Or_No_Name (String_Lists.Element (C)); Next (C); if Has_Element (C) then declare Rts : constant String := String_Lists.Element (C); begin -- If the runtime is a full path, set Runtime and -- Runtime_Dir to the same value. if Rts'Length > 0 and then Is_Absolute_Path (Rts) then Compiler.Runtime := Get_String_No_Adalib (Rts); Compiler.Runtime_Dir := Compiler.Runtime; else Compiler.Runtime := Get_String_Or_No_Name (Rts); end if; end; Next (C); if Has_Element (C) then Compiler.Path := Get_String_Or_No_Name (Name_As_Directory (Normalize_Pathname (String_Lists.Element (C), Case_Sensitive => False))); Next (C); if Has_Element (C) then -- the name could be either a name as defined in the -- knowledge base, or the base name of the executable -- we are looking for. It must not include the exec -- suffix. declare function Name return String; -- Return the name to be used function Name return String is N1 : constant String := String_Lists.Element (C); Idx : constant Natural := Index (N1, "gnatmake"); begin if LC = "ada" and then Idx /= 0 then -- For Ada, gnatmake was previously used -- to detect a GNAT compiler. However, as -- gnatmake may not be present in all the -- GNAT distributions, gnatls is now used. -- For upward compatibility, replace gnatmake -- with gnatls, so that a GNAT compiler may -- be decteted. return Replace_Slice (N1, Idx, Idx + 7, "gnatls"); else return N1; end if; end Name; begin Compiler.Name := Get_String_Or_No_Name (GNAT.Directory_Operations.Base_Name (Name, Suffix => Exec_Suffix.all)); end; end if; end if; end if; end if; Compiler.Complete := False; -- Complete_Command_Line_Compilers will check that this is a valid -- config Put_Verbose ("Language " & LC & " requires a compiler"); end if; end; exception when E : others => Put_Verbose ("Exception raised: " & Exception_Information (E)); raise Invalid_Config; end Parse_Config_Parameter; --------------------------- -- Filter_Compilers_List -- --------------------------- procedure Filter_Compilers_List (Base : Knowledge_Base; Compilers : in out Compiler_Lists.List; For_Target_Set : Targets_Set_Id) is procedure Mark_As_Selectable (Comp : in out Compiler_Access); procedure Mark_As_Unselectable (Comp : in out Compiler_Access); ------------------------ -- Mark_As_Selectable -- ------------------------ procedure Mark_As_Selectable (Comp : in out Compiler_Access) is begin Comp.Selectable := True; end Mark_As_Selectable; -------------------------- -- Mark_As_Unselectable -- -------------------------- procedure Mark_As_Unselectable (Comp : in out Compiler_Access) is begin Comp.Selectable := False; end Mark_As_Unselectable; Comp, Comp2 : Compiler_Lists.Cursor; Selectable : Boolean; begin Put_Verbose ("Filtering the list of compilers", 1); Comp := First (Compilers); while Has_Element (Comp) loop if not Compiler_Lists.Element (Comp).Selected then Selectable := True; if For_Target_Set /= All_Target_Sets and then Compiler_Lists.Element (Comp).Targets_Set /= All_Target_Sets and then Compiler_Lists.Element (Comp).Targets_Set /= For_Target_Set then Selectable := False; if Current_Verbosity /= Default then Put_Verbose ("Incompatible target for: " & To_String (Base, Compiler_Lists.Element (Comp).all, False)); end if; end if; if Selectable then Comp2 := First (Compilers); while Has_Element (Comp2) loop if Compiler_Lists.Element (Comp2).Selected and then Compiler_Lists.Element (Comp2).Language_LC = Compiler_Lists.Element (Comp).Language_LC then Selectable := False; if Current_Verbosity /= Default then Put_Verbose ("Already selected language for " & To_String (Base, Compiler_Lists.Element (Comp).all, False)); end if; exit; end if; Next (Comp2); end loop; end if; if Selectable then -- Would adding this compiler to the current selection end -- up with an unsupported config ? Set_Selection (Compilers, Comp, True); if not Is_Supported_Config (Base, Compilers) then Selectable := False; if Current_Verbosity /= Default then Put_Verbose ("Unsupported config for: " & To_String (Base, Compiler_Lists.Element (Comp).all, False)); end if; end if; Set_Selection (Compilers, Comp, False); end if; if Selectable then Update_Element (Compilers, Comp, Mark_As_Selectable'Access); else Update_Element (Compilers, Comp, Mark_As_Unselectable'Access); end if; end if; Next (Comp); end loop; Put_Verbose ("", -1); end Filter_Compilers_List; ----------------- -- Is_Selected -- ----------------- function Is_Selected (Comp : Compiler) return Boolean is begin return Comp.Selected; end Is_Selected; ------------ -- Target -- ------------ function Target (Comp : Compiler) return Name_Id is begin return Comp.Target; end Target; -------------------- -- Runtime_Dir_Of -- -------------------- function Runtime_Dir_Of (Comp : Compiler_Access) return Name_Id is begin if Comp = null then return No_Name; else return Comp.Runtime_Dir; end if; end Runtime_Dir_Of; ---------- -- Free -- ---------- procedure Free (Descr : in out Compiler_Description) is procedure Free (List : in out External_Value); procedure Free (List : in out External_Value) is begin for El of List loop Free (El); end loop; List.Clear; end Free; begin Unchecked_Free (Descr.Executable_Re); Free (Descr.Target); Free (Descr.Version); Free (Descr.Variables); Free (Descr.Languages); Free (Descr.Runtimes); Descr.Default_Runtimes.Clear; end Free; ---------- -- Free -- ---------- procedure Free (Config : in out Configuration) is procedure Free (Filter : in out Compiler_Filter_Lists.List); procedure Free (Filter : in out Compiler_Filter_Lists.List) is begin for El of Filter loop Unchecked_Free (El.Name_Re); Unchecked_Free (El.Version_Re); Unchecked_Free (El.Runtime_Re); end loop; Filter.Clear; end Free; begin for El of Config.Compilers_Filters loop Free (El.Compiler); end loop; Config.Compilers_Filters.Clear; Config.Targets_Filters.Clear; end Free; ---------- -- Free -- ---------- procedure Free (TSD : in out Target_Set_Description) is begin for El of TSD.Patterns loop Unchecked_Free (El); end loop; TSD.Patterns.Clear; end Free; ---------- -- Free -- ---------- procedure Free (Ext_Val : in out External_Value_Node) is begin case Ext_Val.Typ is when Value_Directory => Unchecked_Free (Ext_Val.Contents); when Value_Grep => Unchecked_Free (Ext_Val.Regexp_Re); when Value_Nogrep => Unchecked_Free (Ext_Val.Regexp_No); when others => null; end case; end Free; end GPR.Knowledge; gprbuild-25.0.0/gpr/src/gpr-knowledge.ads000066400000000000000000000552131470075373400202430ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2006-2021, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- This unit is responsible for parsing the gprconfig knowledge base with Ada.Containers.Doubly_Linked_Lists; with Ada.Containers.Indefinite_Doubly_Linked_Lists; with Ada.Containers.Hashed_Maps; with Ada.Containers.Vectors; with Ada.Strings.Unbounded; with GNAT.Regpat; package GPR.Knowledge is use Ada.Strings.Unbounded; package String_Lists is new Ada.Containers.Indefinite_Doubly_Linked_Lists (String); Generate_Error : exception; -- To be raised when an error occurs during generation of config files -------------------- -- Knowledge base -- -------------------- -- The following types and subprograms manipulate the knowledge base. This -- base is a set of XML files that describe how to find compilers that are -- installed on the system and that match specific criteria. type Knowledge_Base is private; function Default_Knowledge_Base_Directory return String; -- Return the default location of the knowledge database. This is based on -- the installation directory of the executable. procedure Parse_Knowledge_Base (Base : in out Knowledge_Base; Directory : String; Parse_Compiler_Info : Boolean := True; Validate : Boolean := False); -- Parse info from the knowledge base, and store it in memory. -- Only information relevant to the current host is parsed. -- If Parse_Compiler_Info is False, then only the information about -- target sets is parsed. -- This procedure will raise Invalid_Knowledge_Base if the base contains -- incorrect data. -- If Validate is True, the contents of the knowledge base is first -- validated with an XSD schema. procedure Free_Knowledge_Base (Base : in out Knowledge_Base); -- Deallocate all resources occupied by the knowledge base. Invalid_Knowledge_Base : exception; -- To be raised when an error occurred while parsing the knowledge base Knowledge_Base_Validation_Error : exception; -- Some files in the knowledge base are invalid. Pedantic_KB : Boolean := False; -- Expect strict accordance between the expected knowledge base scheme -- and actual files parsed. When parsing an older knowledge base some -- attributes may be missing (i.e. canonical target) and that would lead -- to Invalid_Knowledge_Base raised. ----------------- -- Target sets -- ----------------- -- One of the information pieces contain in the database is a way to -- normalize target names, since various names are used in different -- contexts thus making it harder to write project files depending on the -- target. type Targets_Set_Id is private; -- Identify a target aliases set All_Target_Sets : constant Targets_Set_Id; -- Matches all target sets Unknown_Targets_Set : constant Targets_Set_Id; -- Special target set when a target is not known function Query_Targets_Set (Base : Knowledge_Base; Target : String) return Targets_Set_Id; -- Get the target alias set id for a target, or Unknown_Targets_Set if -- no such target is in the base. procedure Get_Targets_Set (Base : in out Knowledge_Base; Target : String; Id : out Targets_Set_Id); -- Get the target alias set id for a target. If not already in the base, -- add it. function Normalized_Target (Base : Knowledge_Base; Set : Targets_Set_Id) return String; -- Return the normalized name for a target set function Get_Fallback_List (Base : Knowledge_Base; On_Target : Targets_Set_Id) return String_Lists.List; -- Get the list of fallback targets for a given target set. --------------- -- Compilers -- --------------- -- Most of the information in the database relates to compilers. However, -- you do not have direct access to the generic description that explains -- how to find compilers on the PATH and how to compute their attributes -- (version, runtimes,...) Instead, this package gives you access to the -- list of compilers that were found. The package ensures that all -- information is only computed at most once, to save on system calls and -- provide better performance. type Compiler is private; type Compiler_Access is access all Compiler; function Runtime_Dir_Of (Comp : Compiler_Access) return Name_Id; -- Return the name of the runtime directory for the compiler. Returns -- No_Name if Comp is null. package Compiler_Lists is new Ada.Containers.Doubly_Linked_Lists (Compiler_Access); -- A list of compilers function Is_Selected (Comp : Compiler) return Boolean; function Target (Comp : Compiler) return Name_Id; procedure Set_Selection (Compilers : in out Compiler_Lists.List; Cursor : Compiler_Lists.Cursor; Selected : Boolean); procedure Set_Selection (Comp : in out Compiler; Selected : Boolean); -- Toggle the selection status of a compiler in the list. -- This does not check that the selection is consistent though (use -- Is_Supported_Config to do this test) function To_String (Base : Knowledge_Base; Comp : Compiler; As_Config_Arg : Boolean; Show_Target : Boolean := False; Rank_In_List : Integer := -1; Parser_Friendly : Boolean := False) return String; -- Return a string representing the compiler. It is either the --config -- argument (if As_Config_Arg is true) or the string to use in the -- interactive menu otherwise. -- If Rank_In_List is specified, it is written at the beginning of the -- line. -- If Parser_Friendly is set, then the list is displayed in a way that can -- be easily parsed automatically function To_String (Base : Knowledge_Base; Compilers : Compiler_Lists.List; Selected_Only : Boolean; Show_Target : Boolean := False; Parser_Friendly : Boolean := False) return String; -- Return the list of compilers. -- Unselectable compilers are hidden. If Selected_Only is true, then only -- compilers that are currently selected are displayed. -- If Parser_Friendly is set, then the list is displayed in a way that can -- be easily parsed automatically function Display_Before (Comp1, Comp2 : Compiler_Access) return Boolean; -- Whether Comp1 should be displayed before Comp2 when displaying lists of -- compilers. This ensures that similar languages are grouped, among othe -- things. procedure Filter_Compilers_List (Base : Knowledge_Base; Compilers : in out Compiler_Lists.List; For_Target_Set : Targets_Set_Id); -- Based on the currently selected compilers, check which other compilers -- can or cannot be selected by the user. -- This is not the case if the resulting selection in Compilers is not a -- supported config (multiple compilers for the same language, set of -- compilers explicitly marked as unsupported in the knowledge base,...). ------------------ -- Command line -- ------------------ -- This package provides support for manipulating the --config command line -- parameters. The intent is that they have the same form in all the tools -- that support it. The information provides to --config might be partial -- only, and this package provides support for completing it automatically -- based on the knowledge base. procedure Parse_Config_Parameter (Base : Knowledge_Base; Config : String; Compiler : out Compiler_Access; Requires_Compiler : out Boolean); -- Parse the --config parameter, and store the (partial) information -- found in Compiler. -- When a switch matches a language that requires no compiler, -- Requires_Compiler is set to False. -- Raises Invalid_Config if Config is invalid Invalid_Config : exception; -- Raised when the user has specified an invalid --config switch procedure Complete_Command_Line_Compilers (Base : in out Knowledge_Base; On_Target : Targets_Set_Id; Filters : Compiler_Lists.List; Compilers : in out Compiler_Lists.List; Target_Specified : Boolean; Selected_Target : in out Unbounded_String); -- In batch mode, the --config parameters indicate what compilers should be -- selected. Each of these switch selects the first matching compiler -- available, and all --config switch must match a compiler. -- The information provided by the user does not have to be complete, and -- this procedure completes all missing information like version, runtime, -- and so on. -- In gprconfig, it should only be called in batch mode, since otherwise -- --config only acts as a filter for the compilers that are found through -- the knowledge base. -- Filters is the list specified by the user as --config, and contains -- potentially partial information for each compiler. On output, Compilers -- is completed with the full information for all compilers in Filters. If -- at least one of the compilers in Filters cannot be found, Invalid_Config -- is raised. function Extra_Dirs_From_Filters (Filters : Compiler_Lists.List) return String; -- Compute the list of directories that should be prepended to the PATH -- when searching for compilers. These are all the directories that the -- user has explicitly specified in his filters (aka --config) ----------------------------- -- knowledge base contents -- ----------------------------- package Variables_Maps renames Name_Id_Maps; No_Compiler : constant Compiler; -- Describes one of the compilers found on the PATH. -- Path is the directory that contains the compiler executable. -- Path_Order is used for sorting in the interactive menu: it indicates the -- index in $PATH of the directory, so that we can show first the compilers -- that are first in path. -- Any of these compilers can be selected by the user as part of a config. -- However, to prevent incompatibilities, a compiler can be marked as not -- selectable. This will be re-evaluated based on the current selection. -- Complete is set to True if all the information about the compiler was -- computed. It is set to False if the compiler was specified through a -- command line argument --config, and part of the info needs to be -- computed. -- Index_In_List is used for the interactive menu, and is initialized -- automatically. type Compiler_Iterator is abstract tagged null record; -- An iterator that searches for all known compilers in a list of -- directories. Whenever a new compiler is found, the Callback primitive -- operation is called. procedure Callback (Iterator : in out Compiler_Iterator; Base : in out Knowledge_Base; Comp : Compiler; Runtime_Specified : Boolean; From_Extra_Dir : Boolean; Continue : out Boolean) is abstract; -- Called whenever a new compiler is discovered. -- It might be discovered either in a path added through a --config -- parameter (in which case From_Extra_Dir is True), or in a path specified -- in the environment variable $PATH (in which case it is False). If the -- directory is both in Extra_Dirs and in $PATH, From_Extra_Dir is set to -- False. -- If Runtime_Specified is True, only filters with a specified runtime are -- -- On exit, Continue should be set to False if there is no need to discover -- further compilers (however there will be no possibility to restart the -- search at the same point later on). procedure Foreach_Compiler_In_Path (Iterator : in out Compiler_Iterator; Base : in out Knowledge_Base; On_Target : Targets_Set_Id; Extra_Dirs : String := ""); -- Find all compilers in "Extra_Dirs & $PATH". -- Extra_Dirs should typically be the list of directories found in -- --config command line arguments. -- The only filtering done is the target, for optimization purposes (no -- need to computed all info about the compiler if we know it will not be -- uses anyway). procedure Known_Compiler_Names (Base : Knowledge_Base; List : out Ada.Strings.Unbounded.Unbounded_String); -- Set List to the comma-separated list of known compilers procedure Generate_Configuration (Base : Knowledge_Base; Compilers : Compiler_Lists.List; Output_File : String; Target : String; Selected_Targets_Set : Targets_Set_Id); -- Generate the configuration file for the list of selected compilers type Double_String is record Positive_Regexp : Unbounded_String; Negative_Regexp : Unbounded_String; end record; package Double_String_Lists is new Ada.Containers.Doubly_Linked_Lists (Double_String); use Double_String_Lists; procedure Put_Verbose (Str : String; Indent_Delta : Integer := 0); -- Print Str if verbose mode is activated. -- Indent_Delta will increase the current indentation level for all further -- traces, which is used to highlight nested calls. Only the sign of -- Indent_Delta is taken into account. -- Nothing is printed if Str is the empty string, only the indentation is -- changed function Filter_Match (Base : Knowledge_Base; Comp : Compiler; Filter : Compiler) return Boolean; -- Returns True if Comp match Filter (the latter corresponds to a --config -- command line argument). private type Targets_Set_Id is range -1 .. Natural'Last; All_Target_Sets : constant Targets_Set_Id := -1; Unknown_Targets_Set : constant Targets_Set_Id := 0; type Compiler is record Name : Name_Id := No_Name; -- The name of the compiler, as specified in the node of the -- knowledge base. If Compiler represents a filter as defined on through -- --config switch, then name can also be the base name of the -- executable we are looking for. In such a case, it never includes the -- exec suffix (.exe on Windows) Executable : Name_Id := No_Name; Target : Name_Id := No_Name; Targets_Set : Targets_Set_Id; Path : Name_Id := No_Name; Base_Name : Name_Id := No_Name; -- Base name of the executable. This does not include the exec suffix Version : Name_Id := No_Name; Variables : Variables_Maps.Map; Prefix : Name_Id := No_Name; Runtime : Name_Id := No_Name; Alt_Runtime : Name_Id := No_Name; Runtime_Dir : Name_Id := No_Name; Default_Runtime : Boolean := False; Any_Runtime : Boolean := False; Path_Order : Integer; Language_Case : Name_Id := No_Name; -- The supported language, with the casing read from the compiler. This -- is for display purposes only Language_LC : Name_Id := No_Name; -- The supported language, always lower case Selectable : Boolean := True; Selected : Boolean := False; Complete : Boolean := True; end record; No_Compiler : constant Compiler := (Name => No_Name, Target => No_Name, Targets_Set => Unknown_Targets_Set, Executable => No_Name, Base_Name => No_Name, Path => No_Name, Variables => Variables_Maps.Empty_Map, Version => No_Name, Prefix => No_Name, Runtime => No_Name, Alt_Runtime => No_Name, Default_Runtime => False, Any_Runtime => False, Runtime_Dir => No_Name, Language_Case => No_Name, Language_LC => No_Name, Selectable => False, Selected => False, Complete => True, Path_Order => 0); type Pattern_Matcher_Access is access all GNAT.Regpat.Pattern_Matcher; type External_Value_Type is (Value_Constant, Value_Shell, Value_Directory, Value_Grep, Value_Nogrep, Value_Filter, Value_Must_Match, Value_Variable, Value_Done); type External_Value_Node (Typ : External_Value_Type := Value_Constant) is record case Typ is when Value_Constant => Value : Name_Id; when Value_Shell => Command : Name_Id; when Value_Directory => Directory : Name_Id; Directory_Group : Integer; Dir_If_Match : Name_Id; Contents : Pattern_Matcher_Access; when Value_Grep => Regexp_Re : Pattern_Matcher_Access; Group : Natural; when Value_Nogrep => Regexp_No : Pattern_Matcher_Access; when Value_Filter => Filter : Name_Id; when Value_Must_Match => Must_Match : Name_Id; when Value_Variable => Var_Name : Name_Id; when Value_Done => null; end case; end record; package External_Value_Nodes is new Ada.Containers.Doubly_Linked_Lists (External_Value_Node); subtype External_Value is External_Value_Nodes.List; Null_External_Value : constant External_Value := External_Value_Nodes.Empty_List; type Compiler_Description is record Name : Name_Id := No_Name; Executable : Name_Id := No_Name; Executable_Re : Pattern_Matcher_Access; Prefix_Index : Integer := -1; Target : External_Value; Version : External_Value; Variables : External_Value; Languages : External_Value; Runtimes : External_Value; Default_Runtimes : String_Lists.List; end record; -- Executable_Re is only set if the name of the must be -- taken as a regular expression. package Compiler_Description_Maps is new Ada.Containers.Hashed_Maps (Name_Id, Compiler_Description, To_Hash, "="); type Compiler_Filter is record Name : Name_Id; Name_Re : Pattern_Matcher_Access; Version : Name_Id; Version_Re : Pattern_Matcher_Access; Runtime : Name_Id; Runtime_Re : Pattern_Matcher_Access; Language_LC : Name_Id; end record; -- Representation for a node (in ) package Compiler_Filter_Lists is new Ada.Containers.Doubly_Linked_Lists (Compiler_Filter); type Compilers_Filter is record Compiler : Compiler_Filter_Lists.List; Negate : Boolean := False; end record; No_Compilers_Filter : constant Compilers_Filter := (Compiler => Compiler_Filter_Lists.Empty_List, Negate => False); -- a filter, that matches if any of its child -- matches. package Compilers_Filter_Lists is new Ada.Containers.Doubly_Linked_Lists (Compilers_Filter); type Configuration is record Compilers_Filters : Compilers_Filter_Lists.List; Targets_Filters : Double_String_Lists.List; -- these are regexps Negate_Targets : Boolean := False; Config : Name_Id; Supported : Boolean; -- Whether the combination of compilers is supported end record; package Configuration_Lists is new Ada.Containers.Doubly_Linked_Lists (Configuration); package Target_Lists is new Ada.Containers.Doubly_Linked_Lists (Pattern_Matcher_Access); type Target_Set_Description is record Name : Name_Id; Patterns : Target_Lists.List; end record; subtype Known_Targets_Set_Id is Targets_Set_Id range 1 .. Targets_Set_Id'Last; -- Known targets set. They are in the base package Targets_Set_Vectors is new Ada.Containers.Vectors (Known_Targets_Set_Id, Target_Set_Description, "="); package Fallback_Targets_Set_Vectors is new Ada.Containers.Vectors (Known_Targets_Set_Id, String_Lists.List, String_Lists."="); type Knowledge_Base is record Compilers : Compiler_Description_Maps.Map; No_Compilers : String_Lists.List; Check_Executable_Regexp : Boolean := False; Configurations : Configuration_Lists.List; Targets_Sets : Targets_Set_Vectors.Vector; Fallback_Targets_Sets : Fallback_Targets_Set_Vectors.Vector; end record; -- Check_Executable_Regexp is set to True if at least some of the -- executable names are specified as regular expressions. In such a case, -- a slightly slower algorithm is used to search for compilers. -- No_Compilers is the list of languages that require no compiler, and thus -- should not be searched on the PATH. end GPR.Knowledge; gprbuild-25.0.0/gpr/src/gpr-names.adb000066400000000000000000000475361470075373400173570ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2021, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Containers.Indefinite_Vectors; with Ada.Text_IO; use Ada.Text_IO; with Interfaces; use Interfaces; with GPR.Cset; use GPR.Cset; with GPR.Output; use GPR.Output; with GPR.Debug; with GNAT.Case_Util; package body GPR.Names is -- This table stores the actual string names. Although logically there is -- no need for a terminating character (since the length is stored in the -- name entry table), we still store a NUL character at the end of every -- name (for convenience in interfacing to the C world). Hash_Num : constant Int := 2**16; -- Number of headers in the hash table. Current hash algorithm is closely -- tailored to this choice, so it can only be changed if a corresponding -- change is made to the hash algorithm. Hash_Max : constant Int := Hash_Num - 1; -- Indexes in the hash header table run from 0 to Hash_Num - 1 subtype Hash_Index_Type is Int range 0 .. Hash_Max; -- Range of hash index values Hash_Table : array (Hash_Index_Type) of Name_Id := (others => No_Name); -- The hash table is used to locate existing entries in the names table. -- The entries point to the first names table entry whose hash value -- matches the hash code. Then subsequent names table entries with the -- same hash code value are linked through the Hash_Link fields. type Name_Entry (Name_Len : Natural) is record Value : String (1 .. Name_Len); Hash_Link : Name_Id; -- Link to next entry in names table for same hash code Int_Info : Int; -- Int Value associated with this name end record; -- This is the table that is referenced by Name_Id entries. -- It contains one entry for each unique name in the table. subtype Valid_Name_Id is Name_Id range First_Name_Id .. Name_Id'Last; pragma Suppress (Container_Checks); package Name_Vectors is new Ada.Containers.Indefinite_Vectors (Valid_Name_Id, Name_Entry); Name_Entries : Name_Vectors.Vector; ----------------------- -- Local Subprograms -- ----------------------- function Hash return Hash_Index_Type; pragma Inline (Hash); -- Compute hash code for name stored in Name_Buffer (length in Name_Len) function In_Wide_Character_Range (C : Char_Code) return Boolean; pragma Inline (In_Wide_Character_Range); -- Determines if the given character code is in range of the type -- Wide_Character, and if so, returns True. If not, returns False. ----------------------------- -- Add_Char_To_Name_Buffer -- ----------------------------- procedure Add_Char_To_Name_Buffer (C : Character) is begin if Name_Len < Name_Buffer'Last then Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := C; end if; end Add_Char_To_Name_Buffer; ---------------------------- -- Add_Nat_To_Name_Buffer -- ---------------------------- procedure Add_Nat_To_Name_Buffer (V : Nat) is begin if V >= 10 then Add_Nat_To_Name_Buffer (V / 10); end if; Add_Char_To_Name_Buffer (Character'Val (Character'Pos ('0') + V rem 10)); end Add_Nat_To_Name_Buffer; ---------------------------- -- Add_Str_To_Name_Buffer -- ---------------------------- procedure Add_Str_To_Name_Buffer (S : String) is Start : constant Positive := Name_Len + 1; begin Name_Len := Name_Len + S'Length; if Name_Len <= Name_Buffer'Last then Name_Buffer (Start .. Name_Len) := S; elsif Start <= Name_Buffer'Last then Name_Buffer (Start .. Name_Buffer'Last) := S (S'First .. S'First + Name_Buffer'Last - Start); end if; end Add_Str_To_Name_Buffer; ------------------- -- Get_Character -- ------------------- function Get_Character (C : Char_Code) return Character is begin pragma Assert (C <= 255); return Character'Val (C); end Get_Character; ----------------------- -- Get_Lower_Name_Id -- ----------------------- function Get_Lower_Name_Id (Name : String) return Name_Id is begin Set_Name_Buffer (Name); GNAT.Case_Util.To_Lower (Name_Buffer (1 .. Name_Len)); return Name_Find; end Get_Lower_Name_Id; ----------------- -- Get_Name_Id -- ----------------- function Get_Name_Id (Name : String) return Name_Id is begin Set_Name_Buffer (Name); return Name_Find; end Get_Name_Id; ------------------- -- Get_Char_Code -- ------------------- function Get_Char_Code (C : Character) return Char_Code is begin return Char_Code'Val (Character'Pos (C)); end Get_Char_Code; --------------------- -- Get_Name_String -- --------------------- -- Procedure version leaving result in Name_Buffer, length in Name_Len procedure Get_Name_String (Id : Name_Id) is begin if Debug.Debug_Flag_A then Put ("<<<< Accessing index" & Id'Img & " (procedure Get_Name_String)"); end if; pragma Assert (Is_Valid_Name (Id)); Set_Name_Buffer (Name_Entries (Id).Value); if Debug.Debug_Flag_A then Put_Line (" Found: '" & Name_Buffer (1 .. Name_Len) & "' >>>>"); end if; end Get_Name_String; procedure Get_Name_String (Id : Unit_Name_Type) is begin Get_Name_String (Name_Id (Id)); end Get_Name_String; procedure Get_Name_String (Id : File_Name_Type) is begin Get_Name_String (Name_Id (Id)); end Get_Name_String; procedure Get_Name_String (Id : Path_Name_Type) is begin Get_Name_String (Name_Id (Id)); end Get_Name_String; --------------------- -- Get_Name_String -- --------------------- -- Function version returning a string function Get_Name_String (Id : Name_Id) return String is begin if Debug.Debug_Flag_A then Put ("<<<< Accessing index" & Id'Img & " (function Get_Name_String)"); end if; pragma Assert (Is_Valid_Name (Id), "Invalid Id" & Id'Img); return R : constant String := Name_Entries (Id).Value do if Debug.Debug_Flag_A then Put_Line (" Found: '" & R & "' >>>>"); end if; end return; end Get_Name_String; function Get_Name_String (Id : Unit_Name_Type) return String is begin return Get_Name_String (Name_Id (Id)); end Get_Name_String; function Get_Name_String (Id : File_Name_Type) return String is begin return Get_Name_String (Name_Id (Id)); end Get_Name_String; function Get_Name_String (Id : Path_Name_Type) return String is begin return Get_Name_String (Name_Id (Id)); end Get_Name_String; -------------------------- -- Get_Name_String_Safe -- -------------------------- -- Function version returning a string function Get_Name_String_Safe (Id : Name_Id) return String is (if Is_Valid_Name (Id) then Name_Entries (Id).Value else ""); function Get_Name_String_Safe (Id : File_Name_Type) return String is begin return Get_Name_String_Safe (Name_Id (Id)); end Get_Name_String_Safe; function Get_Name_String_Safe (Id : Path_Name_Type) return String is begin return Get_Name_String_Safe (Name_Id (Id)); end Get_Name_String_Safe; -------------------------------- -- Get_Name_String_And_Append -- -------------------------------- procedure Get_Name_String_And_Append (Id : Name_Id) is begin if Debug.Debug_Flag_A then Put ("<<<< Accessing index" & Id'Img & " (Get_Name_String_And_Append)"); end if; pragma Assert (Is_Valid_Name (Id)); Add_Str_To_Name_Buffer (Name_Entries (Id).Value); if Debug.Debug_Flag_A then Put_Line (" Found: '" & Name_Entries (Id).Value & "' >>>>"); end if; end Get_Name_String_And_Append; procedure Get_Name_String_And_Append (Id : File_Name_Type) is begin Get_Name_String_And_Append (Name_Id (Id)); end Get_Name_String_And_Append; procedure Get_Name_String_And_Append (Id : Path_Name_Type) is begin Get_Name_String_And_Append (Name_Id (Id)); end Get_Name_String_And_Append; ------------------------- -- Get_Name_Table_Int -- ------------------------- function Get_Name_Table_Int (Id : Name_Id) return Int is begin pragma Assert (Is_Valid_Name (Id)); return Name_Entries (Id).Int_Info; end Get_Name_Table_Int; function Get_Name_Table_Int (Id : Unit_Name_Type) return Int is begin return Get_Name_Table_Int (Name_Id (Id)); end Get_Name_Table_Int; function Get_Name_Table_Int (Id : File_Name_Type) return Int is begin return Get_Name_Table_Int (Name_Id (Id)); end Get_Name_Table_Int; ---------- -- Hash -- ---------- function Hash return Hash_Index_Type is -- This hash function looks at every character, in order to make it -- likely that similar strings get different hash values. The rotate by -- 7 bits has been determined empirically to be good, and it doesn't -- lose bits like a shift would. The final conversion can't overflow, -- because the table is 2**16 in size. This function probably needs to -- be changed if the hash table size is changed. -- Note that we could get some speed improvement by aligning the string -- to 32 or 64 bits, and doing word-wise xor's. We could also implement -- a growable table. It doesn't seem worth the trouble to do those -- things, for now. Result : Unsigned_16 := 0; begin for J in 1 .. Name_Len loop Result := Rotate_Left (Result, 7) xor Character'Pos (Name_Buffer (J)); end loop; return Hash_Index_Type (Result); end Hash; ------------------------ -- In_Character_Range -- ------------------------ function In_Character_Range (C : Char_Code) return Boolean is begin return (C <= 255); end In_Character_Range; ----------------------------- -- In_Wide_Character_Range -- ----------------------------- function In_Wide_Character_Range (C : Char_Code) return Boolean is begin return (C <= 65535); end In_Wide_Character_Range; ------------------- -- Is_Valid_Name -- ------------------- function Is_Valid_Name (Id : Name_Id) return Boolean is begin return Id in Name_Entries.First_Index .. Name_Entries.Last_Index; end Is_Valid_Name; -------------------- -- Length_Of_Name -- -------------------- function Length_Of_Name (Id : Name_Id) return Nat is begin return Int (Name_Entries (Id).Name_Len); end Length_Of_Name; function Length_Of_Name (Id : File_Name_Type) return Nat is begin return Int (Name_Entries (Name_Id (Id)).Name_Len); end Length_Of_Name; ---------------- -- Name_Enter -- ---------------- function Name_Enter return Name_Id is begin Name_Entries.Append ((Name_Len => Name_Len, Value => Name_Buffer (1 .. Name_Len), Int_Info => 0, Hash_Link => No_Name), 1); if Debug.Debug_Flag_A then Put_Line ("<<<< Appending: '" & Name_Buffer (1 .. Name_Len) & "' with index" & Name_Entries.Last_Index'Img & " (Name_Enter) >>>>"); end if; return Name_Entries.Last_Index; end Name_Enter; --------------- -- Name_Find -- --------------- function Name_Find return Name_Id is New_Id : Name_Id; -- Id of entry in hash search, and value to be returned Hash_Index : Hash_Index_Type; -- Computed hash index begin Hash_Index := Hash; New_Id := Hash_Table (Hash_Index); if New_Id = No_Name then Hash_Table (Hash_Index) := Name_Entries.Last_Index + 1; else Search : loop if Name_Entries (New_Id).Value /= Name_Buffer (1 .. Name_Len) then goto No_Match; end if; if Debug.Debug_Flag_A then Put_Line ("<<<< Found index" & New_Id'Img & " for: '" & Name_Buffer (1 .. Name_Len) & "' (Name_Find) >>>>"); end if; return New_Id; -- Current entry in hash chain does not match <> if Name_Entries (New_Id).Hash_Link /= No_Name then New_Id := Name_Entries (New_Id).Hash_Link; else Name_Entries (New_Id).Hash_Link := Name_Entries.Last_Index + 1; 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. We now create a new entry in the names table. The hash -- link pointing to the new entry (Name_Entries.Last+1) has been set. Name_Entries.Append ((Name_Len => Name_Len, Value => Name_Buffer (1 .. Name_Len), Hash_Link => No_Name, Int_Info => 0), 1); if Debug.Debug_Flag_A then Put_Line ("<<<< Appending: '" & Name_Buffer (1 .. Name_Len) & "' with index" & Name_Entries.Last_Index'Img & " (Name_Find) >>>>"); end if; return Name_Entries.Last_Index; end Name_Find; function Name_Find return Unit_Name_Type is Id : Name_Id; begin Id := Name_Find; return Unit_Name_Type (Id); end Name_Find; function Name_Find return File_Name_Type is Id : Name_Id; begin Id := Name_Find; return File_Name_Type (Id); end Name_Find; function Name_Find return Path_Name_Type is Id : Name_Id; begin Id := Name_Find; return Path_Name_Type (Id); end Name_Find; ---------------- -- Set_Casing -- ---------------- procedure Set_Casing (C : Casing_Type) is Ptr : Natural; After_Und : Boolean := True; -- True at start of string, and after an underline character or after -- any other special character that is not a normal identifier char). begin Ptr := 1; while Ptr <= Name_Len loop -- Underscore, or non-identifer character (error case) if Name_Buffer (Ptr) = '_' or else not Identifier_Char (Name_Buffer (Ptr)) then After_Und := True; Ptr := Ptr + 1; -- Lower case letter elsif Is_Lower_Case_Letter (Name_Buffer (Ptr)) then if C = All_Upper_Case or else (After_Und and then C = Mixed_Case) then Name_Buffer (Ptr) := Fold_Upper (Name_Buffer (Ptr)); end if; After_Und := False; Ptr := Ptr + 1; -- Upper case letter elsif Is_Upper_Case_Letter (Name_Buffer (Ptr)) then if C = All_Lower_Case or else (not After_Und and then C = Mixed_Case) then Name_Buffer (Ptr) := Fold_Lower (Name_Buffer (Ptr)); end if; After_Und := False; Ptr := Ptr + 1; -- Other identifier character (must be digit) else After_Und := False; Ptr := Ptr + 1; end if; end loop; end Set_Casing; ------------------------- -- Set_Name_Table_Int -- ------------------------- procedure Set_Name_Table_Int (Id : Name_Id; Val : Int) is begin pragma Assert (Is_Valid_Name (Id)); Name_Entries (Id).Int_Info := Val; end Set_Name_Table_Int; procedure Set_Name_Table_Int (Id : Unit_Name_Type; Val : Int) is begin Set_Name_Table_Int (Name_Id (Id), Val); end Set_Name_Table_Int; procedure Set_Name_Table_Int (Id : File_Name_Type; Val : Int) is begin Set_Name_Table_Int (Name_Id (Id), Val); end Set_Name_Table_Int; ---------------------------- -- Set_Name_Buffer -- ---------------------------- procedure Set_Name_Buffer (S : String) is begin Name_Len := S'Length; Name_Buffer (1 .. Name_Len) := S; end Set_Name_Buffer; ----------------------------- -- Store_Encoded_Character -- ----------------------------- procedure Store_Encoded_Character (C : Char_Code) is begin Name_Len := Name_Len + 1; if In_Character_Range (C) then declare CC : constant Character := Get_Character (C); begin if CC in 'a' .. 'z' or else CC in '0' .. '9' then Name_Buffer (Name_Len) := CC; else Name_Buffer (Name_Len) := 'U'; Name_Len := Name_Len + 2; Hex_Image (Word (C), Name_Buffer (Name_Len - 1 .. Name_Len)); end if; end; elsif In_Wide_Character_Range (C) then Name_Buffer (Name_Len) := 'W'; Name_Len := Name_Len + 4; Hex_Image (Word (C), Name_Buffer (Name_Len - 3 .. Name_Len)); else Name_Buffer (Name_Len) := 'W'; Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := 'W'; Name_Len := Name_Len + 8; Hex_Image (Word (C), Name_Buffer (Name_Len - 7 .. Name_Len)); end if; end Store_Encoded_Character; -------- -- wn -- -------- procedure wn2 (Id : Name_Id) is begin if not Id'Valid then Write_Line (""); elsif Id = No_Name then Write_Line (""); elsif Id = Error_Name then Write_Line (""); else Write_Line (Name_Entries (Id).Value); end if; end wn2; ---------------- -- Write_Name -- ---------------- procedure Write_Name (Id : Name_Id) is begin pragma Assert (Is_Valid_Name (Id), "invalid id" & Id'Img & Name_Entries.First_Index'Img & Name_Entries.Last_Index'Img); Get_Name_String (Id); Write_Str (Name_Buffer (1 .. Name_Len)); end Write_Name; procedure Write_Name (Id : Path_Name_Type) is begin Write_Name (Name_Id (Id)); end Write_Name; procedure Write_Name (Id : File_Name_Type) is begin Write_Name (Name_Id (Id)); end Write_Name; --------------------- -- Write_Unit_Name -- --------------------- procedure Write_Unit_Name (U : Unit_Name_Type) is begin Get_Name_String (U); Write_Str (Name_Buffer (1 .. Name_Len - 2)); if Name_Buffer (Name_Len) = 's' then Write_Str (" (spec)"); else Write_Str (" (body)"); end if; end Write_Unit_Name; end GPR.Names; gprbuild-25.0.0/gpr/src/gpr-names.ads000066400000000000000000000233571470075373400173730ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2021, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ package GPR.Names is Name_Buffer : String (1 .. 1_000_000); Name_Len : Natural := 0; procedure Get_Name_String (Id : Name_Id); procedure Get_Name_String (Id : Unit_Name_Type); procedure Get_Name_String (Id : File_Name_Type); procedure Get_Name_String (Id : Path_Name_Type); -- Get_Name_String is used to retrieve the string associated with an entry -- in the names table. The resulting string is stored in Name_Buffer and -- Name_Len is set. It is an error to call Get_Name_String with one of the -- special name Id values (No_Name or Error_Name). function Get_Name_String (Id : Name_Id) return String; function Get_Name_String (Id : Unit_Name_Type) return String; function Get_Name_String (Id : File_Name_Type) return String; function Get_Name_String (Id : Path_Name_Type) return String; -- This functional form returns the result as a string without affecting -- the contents of either Name_Buffer or Name_Len. The lower bound is 1. function Get_Name_String_Safe (Id : Name_Id) return String; function Get_Name_String_Safe (Id : File_Name_Type) return String; function Get_Name_String_Safe (Id : Path_Name_Type) return String; -- This functional form returns the result as a string without affecting -- the contents of either Name_Buffer or Name_Len. The lower bound is 1. function Get_Name_Id (Name : String) return Name_Id; -- Returns Name_Id associated with Name function Get_Lower_Name_Id (Name : String) return Name_Id; -- Returns Name_Id associated with To_Lower (Name) function Get_Path_Name_Id (Name : String) return Path_Name_Type; -- Returns Path_Name_Type associated with Name function Get_File_Name_Id (Name : String) return File_Name_Type; -- Returns File_Name_Type associated with Name function Get_Name_String_Or_Null (Id : Name_Id) return String; -- Same as above, except that on No_Name return Empty string procedure Get_Name_String_And_Append (Id : File_Name_Type) with Inline; procedure Get_Name_String_And_Append (Id : Path_Name_Type) with Inline; procedure Get_Name_String_And_Append (Id : Name_Id); -- Like Get_Name_String but the resulting characters are appended to the -- current contents of the entry stored in Name_Buffer, and Name_Len is -- incremented to include the added characters. function Is_Valid_Name (Id : Name_Id) return Boolean with Inline; -- Returns True if Id is defining a valid name function Length_Of_Name (Id : Name_Id) return Nat; function Length_Of_Name (Id : File_Name_Type) return Nat; pragma Inline (Length_Of_Name); function Name_Find return Name_Id; function Name_Find return Unit_Name_Type; function Name_Find return File_Name_Type; function Name_Find return Path_Name_Type; function Name_Enter return Name_Id; procedure Add_Char_To_Name_Buffer (C : Character); pragma Inline (Add_Char_To_Name_Buffer); -- Add given character to the end of the string currently stored in the -- Name_Buffer, incrementing Name_Len. procedure Add_Nat_To_Name_Buffer (V : Nat); -- Add decimal representation of given value to the end of the string -- currently stored in Name_Buffer, incrementing Name_Len as required. procedure Add_Str_To_Name_Buffer (S : String) with Inline; -- Add characters of string S to the end of the string currently stored in -- the Name_Buffer, incrementing Name_Len by the length of the string. procedure Set_Name_Buffer (S : String) with Inline; -- Put string S to start of the the Name_Buffer, Put S'Length to the -- Name_Len. function Get_Name_Table_Int (Id : Name_Id) return Int; function Get_Name_Table_Int (Id : Unit_Name_Type) return Int; function Get_Name_Table_Int (Id : File_Name_Type) return Int; pragma Inline (Get_Name_Table_Int); -- Fetches the Int value associated with the given name procedure Set_Name_Table_Int (Id : Name_Id; Val : Int); procedure Set_Name_Table_Int (Id : Unit_Name_Type; Val : Int); procedure Set_Name_Table_Int (Id : File_Name_Type; Val : Int); pragma Inline (Set_Name_Table_Int); -- Sets the Int value associated with the given name type Char_Code_Base is mod 2 ** 32; for Char_Code_Base'Size use 32; subtype Char_Code is Char_Code_Base range 0 .. 16#7FFF_FFFF#; for Char_Code'Value_Size use 32; for Char_Code'Object_Size use 32; function Get_Char_Code (C : Character) return Char_Code; pragma Inline (Get_Char_Code); -- Function to obtain internal character code from source character. For -- the moment, the internal character code is simply the Pos value of the -- input source character, but we provide this interface for possible later -- support of alternative character sets. function In_Character_Range (C : Char_Code) return Boolean; pragma Inline (In_Character_Range); -- Determines if the given character code is in range of type Character, -- and if so, returns True. If not, returns False. function Get_Character (C : Char_Code) return Character; pragma Inline (Get_Character); -- For a character C that is in Character range (see above function), this -- function returns the corresponding Character value. It is an error to -- call Get_Character if C is not in Character range. procedure Store_Encoded_Character (C : Char_Code); -- Stores given character code at the end of Name_Buffer, updating the -- value in Name_Len appropriately. Lower case letters and digits are -- stored unchanged. Other 8-bit characters are stored using the Uhh -- encoding (hh = hex code), other 16-bit wide character values are stored -- using the Whhhh (hhhh = hex code) encoding, and other 32-bit wide wide -- character values are stored using the WWhhhhhhhh (hhhhhhhh = hex code). -- Note that this procedure does not fold upper case letters (they are -- stored using the Uhh encoding). If folding is required, it must be -- done by the caller prior to the call. procedure Write_Name (Id : Name_Id); procedure Write_Name (Id : File_Name_Type); procedure Write_Name (Id : Path_Name_Type); -- Write_Name writes the characters of the specified name Id to the -- specific file File. No end of line is written, just the characters of -- the name. On return Name_Buffer and Name_Len are set as for a call to -- Get_Name_String. The name is written in encoded form (i.e. including -- Uhh, Whhh, Qx, _op as they appear in the name table). If Id is -- Error_Name, or No_Name, no text is output. procedure Write_Unit_Name (U : Unit_Name_Type); -- Output unit name with (body) or (spec) after as required. ------------------------ -- Debugging Routines -- ------------------------ procedure wn2 (Id : Name_Id); pragma Export (Ada, wn2); ------------------------------- -- Case Control Declarations -- ------------------------------- -- Declaration of type for describing casing convention type Casing_Type is (All_Upper_Case, -- All letters are upper case All_Lower_Case, -- All letters are lower case Mixed_Case, -- The initial letter, and any letters after underlines are upper case. -- All other letters are lower case Unknown -- Used if an identifier does not distinguish between the above cases, -- (e.g. X, Y_3, M4, A_B, or if it is inconsistent ABC_def). ); subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case; -- Exclude Unknown casing procedure Set_Casing (C : Casing_Type); -- Takes the name stored in the first Name_Len positions of Name_Buffer and -- modifies it to be consistent with the casing given by C. private function Get_Name_String_Or_Null (Id : Name_Id) return String is (if Id = No_Name then "" else Get_Name_String (Id)); function Get_Path_Name_Id (Name : String) return Path_Name_Type is (Path_Name_Type (Get_Name_Id (Name))); function Get_File_Name_Id (Name : String) return File_Name_Type is (File_Name_Type (Get_Name_Id (Name))); end GPR.Names; gprbuild-25.0.0/gpr/src/gpr-nmsc.adb000066400000000000000000012572701470075373400172130ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2000-2023, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada; use Ada; with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Directories; use Ada.Directories; with Ada.Strings; use Ada.Strings; with Ada.Strings.Fixed; use Ada.Strings.Fixed; with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; with Ada.Text_IO; use Ada.Text_IO; with Ada.Containers.Hashed_Maps; with Ada.Containers.Indefinite_Vectors; with Ada.Strings.Hash_Case_Insensitive; with Ada.Strings.Equal_Case_Insensitive; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.Dynamic_HTables; with GNAT.Regexp; use GNAT.Regexp; with GNAT.Table; with GPR.Com; with GPR.Debug; with GPR.Env; use GPR.Env; with GPR.Err; use GPR.Err; with GPR.Erroutc; use GPR.Erroutc; with GPR.Names; use GPR.Names; with GPR.Opt; use GPR.Opt; with GPR.Osint; use GPR.Osint; with GPR.Output; use GPR.Output; with GPR.Sinput; use GPR.Sinput; with GPR.Tree; use GPR.Tree; with GPR.Util; use GPR.Util; with GPR.Snames; use GPR.Snames; package body GPR.Nmsc is No_Continuation_String : aliased String := ""; Continuation_String : aliased String := "\"; -- Used in Check_Library for continuation error messages at the same -- location. type Name_Location is record Name : File_Name_Type; -- Key is duplicated, so that it is known when using functions Get_First -- and Get_Next, as these functions only return an Element. Location : Source_Ptr; Source : Source_Id := No_Source; Listed : Boolean := False; Found : Boolean := False; end record; No_Name_Location : constant Name_Location := (Name => No_File, Location => No_Location, Source => No_Source, Listed => False, Found => False); package Source_Names_Htable is new GNAT.Dynamic_HTables.Simple_HTable (Header_Num => Header_Num, Element => Name_Location, No_Element => No_Name_Location, Key => File_Name_Type, Hash => Hash, Equal => "="); -- File name information found in string list attribute (Source_Files or -- Source_List_File). Used to check that all referenced files were indeed -- found on the disk. type Unit_Exception is record Name : Name_Id; -- Key is duplicated, so that it is known when using functions Get_First -- and Get_Next, as these functions only return an Element. Spec : File_Name_Type; Impl : File_Name_Type; end record; No_Unit_Exception : constant Unit_Exception := (No_Name, No_File, No_File); package Unit_Exceptions_Htable is new GNAT.Dynamic_HTables.Simple_HTable (Header_Num => Header_Num, Element => Unit_Exception, No_Element => No_Unit_Exception, Key => Name_Id, Hash => Hash, Equal => "="); -- Record special naming schemes for Ada units (name of spec file and name -- of implementation file). The elements in this list come from the naming -- exceptions specified in the project files. type File_Found is record File : File_Name_Type := No_File; Excl_File : File_Name_Type := No_File; Excl_Line : Natural := 0; Found : Boolean := False; Location : Source_Ptr := No_Location; Project : Project_Id := No_Project; end record; No_File_Found : constant File_Found := (No_File, No_File, 0, False, No_Location, No_Project); package Excluded_Sources_Htable is new GNAT.Dynamic_HTables.Simple_HTable (Header_Num => Header_Num, Element => File_Found, No_Element => No_File_Found, Key => File_Name_Type, Hash => Hash, Equal => "="); -- A hash table to store the base names of excluded files, if any package Object_File_Names_Htable is new GNAT.Dynamic_HTables.Simple_HTable (Header_Num => Header_Num, Element => Source_Id, No_Element => No_Source, Key => File_Name_Type, Hash => Hash, Equal => "="); -- A hash table to store the object file names for a project, to check that -- two different sources have different object file names. type Project_Processing_Data is record Project : Project_Id; Source_Names : Source_Names_Htable.Instance; Unit_Exceptions : Unit_Exceptions_Htable.Instance; Excluded : Excluded_Sources_Htable.Instance; Source_List_File_Location : Source_Ptr; -- Location of the Source_List_File attribute, for error messages end record; -- This is similar to Tree_Processing_Data, but contains project-specific -- information which is only useful while processing the project, and can -- be discarded as soon as we have finished processing the project type Tree_Processing_Data is record Tree : Project_Tree_Ref; Node_Tree : GPR.Tree.Project_Node_Tree_Ref; Flags : GPR.Processing_Flags; In_Aggregate_Lib : Boolean; end record; -- Temporary data which is needed while parsing a project. It does not need -- to be kept in memory once a project has been fully loaded, but is -- necessary while performing consistency checks (duplicate sources,...) -- This data must be initialized before processing any project, and the -- same data is used for processing all projects in the tree. type Lib_Data is record Name : Name_Id; Proj : Project_Id; Tree : Project_Tree_Ref; end record; package Lib_Data_Table is new GNAT.Table (Table_Component_Type => Lib_Data, Table_Index_Type => Natural, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 100); -- A table to record library names in order to check that two library -- projects do not have the same library names. type Error_Message (Length : Positive) is record Flags : Processing_Flags; Location : Source_Ptr; Project : Project_Id; Msg : String (1 .. Length); end record; package Hold_Errors is new Ada.Containers.Indefinite_Vectors (Positive, Error_Message); Errors_Holder : Hold_Errors.Vector; -- Keep error messages until decision is it error, warning or should be -- forgotten. procedure Initialize (Data : out Tree_Processing_Data; Tree : Project_Tree_Ref; Node_Tree : GPR.Tree.Project_Node_Tree_Ref; Flags : GPR.Processing_Flags); -- Initialize Data procedure Free (Data : in out Tree_Processing_Data); -- Free the memory occupied by Data procedure Initialize (Data : in out Project_Processing_Data; Project : Project_Id); procedure Free (Data : in out Project_Processing_Data); -- Initialize or free memory for a project-specific data procedure Find_Excluded_Sources (Project : in out Project_Processing_Data; Data : in out Tree_Processing_Data); -- Find the list of files that should not be considered as source files -- for this project. Sets the list in the Project.Excluded_Sources_Htable. procedure Override_Kind (Source : Source_Id; Kind : Source_Kind); -- Override the reference kind for a source file. This properly updates -- the unit data if necessary. procedure Load_Naming_Exceptions (Project : in out Project_Processing_Data; Data : in out Tree_Processing_Data); -- All source files in Data.First_Source are considered as naming -- exceptions, and copied into the Source_Names and Unit_Exceptions tables -- as appropriate. type Search_Type is (Search_Project_Files, Search_Source_Directories); -- Search_Project_Files is to find project files. -- Search_Source_Directories is to find source directories. procedure Expand_Subdirectory_Pattern (Project : Project_Id; Data : in out Tree_Processing_Data; Patterns : String_List_Id; Ignore : String_List_Id; Search_For : Search_Type; Resolve_Links : Boolean; Callback : access procedure (Path : Path_Information; Pattern_Index : Natural)); -- Search the subdirectories of Project's directory for files or -- directories that match the globbing patterns found in Patterns (for -- instance "**/*.adb"). Typically, Patterns will be the value of the -- Source_Dirs or Excluded_Source_Dirs attributes. -- -- Every time such a file or directory is found, the callback is called. -- Resolve_Links indicates whether we should resolve links while -- normalizing names. -- -- In the callback, Pattern_Index is the index within Patterns where the -- expanded pattern was found (1 for the first element of Patterns and -- all its matching directories, then 2,...). -- -- We use a generic and not an access-to-subprogram because in some cases -- this code is compiled with the restriction No_Implicit_Dynamic_Code. -- An error message is raised if a pattern does not match any file. procedure Add_Source (Id : out Source_Id; Data : in out Tree_Processing_Data; Project : Project_Id; Source_Dir_Rank : Natural; Lang_Id : Language_Ptr; Kind : Source_Kind; File_Name : File_Name_Type; Display_File : File_Name_Type; Naming_Exception : Naming_Exception_Type := No; Path : Path_Information := No_Path_Information; Alternate_Languages : Language_List := null; Unit : Name_Id := No_Name; Index : Int := 0; Locally_Removed : Boolean := False; Location : Source_Ptr := No_Location); -- Add a new source to the different lists: list of all sources in the -- project tree, list of source of a project and list of sources of a -- language. If Path is specified, the file is also added to -- Source_Paths_HT. Location is used for error messages function Canonical_Case_File_Name (Name : Name_Id) return File_Name_Type; -- Same as Osint.Canonical_Case_File_Name but applies to Name_Id. -- This alters Name_Buffer. function Suffix_Matches (Filename : String; Suffix : File_Name_Type) return Boolean; -- True if the file name ends with the given suffix. Always returns False -- if Suffix is No_Name. procedure Replace_Into_Name_Buffer (Str : String; Pattern : String; Replacement : Character); -- Copy Str into Name_Buffer, replacing Pattern with Replacement. Str is -- converted to lower-case at the same time. procedure Check_Abstract_Project (Project : Project_Id; Data : in out Tree_Processing_Data); -- Check abstract projects attributes procedure Check_Configuration (Project : Project_Id; Data : in out Tree_Processing_Data); -- Check the configuration attributes for the project procedure Check_If_Externally_Built (Project : Project_Id; Data : in out Tree_Processing_Data); -- Check attribute Externally_Built of project Project in project tree -- Data.Tree and modify its data Data if it has the value "true". procedure Check_Interfaces (Project : Project_Id; Data : in out Tree_Processing_Data); -- If a list of sources is specified in attribute Interfaces, set -- In_Interfaces only for the sources specified in the list. procedure Check_Library_Attributes (Project : Project_Id; No_Sources : Boolean; Data : in out Tree_Processing_Data); -- Check the library attributes of project Project in project tree -- and modify its data Data accordingly. If the declared library attributes -- makes the project a library project, report an error when No_Sources -- is True. procedure Check_Package_Naming (Project : Project_Id; Data : in out Tree_Processing_Data); -- Check the naming scheme part of Data, and initialize the naming scheme -- data in the config of the various languages. procedure Check_Programming_Languages (Project : Project_Id; Data : in out Tree_Processing_Data); -- Check attribute Languages for the project with data Data in project -- tree Data.Tree and set the components of Data for all the programming -- languages indicated in attribute Languages, if any. procedure Check_Stand_Alone_Library (Project : Project_Id; Data : in out Tree_Processing_Data); -- Check if project Project in project tree Data.Tree is a Stand-Alone -- Library project, and modify its data Data accordingly if it is one. procedure Check_Unit_Name (Name : String; Unit : out Name_Id); -- Check that a name is a valid unit name function Compute_Directory_Last (Dir : String) return Natural; -- Return the index of the last significant character in Dir. This is used -- to avoid duplicate '/' (slash) characters at the end of directory names. procedure Search_Directories (Project : in out Project_Processing_Data; Data : in out Tree_Processing_Data; For_All_Sources : Boolean); -- Search the source directories to find the sources. If For_All_Sources is -- True, check each regular file name against the naming schemes of the -- various languages. Otherwise consider only the file names in hash table -- Source_Names. If Allow_Duplicate_Basenames then files with identical -- base names are permitted within a project for source-based languages -- (never for unit based languages). procedure Check_File (Project : in out Project_Processing_Data; Data : in out Tree_Processing_Data; Source_Dir_Rank : Natural; Path : Path_Name_Type; Display_Path : Path_Name_Type; File_Name : File_Name_Type; Display_File_Name : File_Name_Type; Locally_Removed : Boolean; For_All_Sources : Boolean); -- Check if file File_Name is a valid source of the project. This is used -- in multi-language mode only. When the file matches one of the naming -- schemes, it is added to various htables through Add_Source and to -- Source_Paths_Htable. -- -- File_Name is the same as Display_File_Name, but has been normalized. -- They do not include the directory information. -- -- Path and Display_Path on the other hand are the full path to the file. -- Path must have been normalized (canonical casing and possibly links -- resolved). -- -- Source_Directory is the directory in which the file was found. It is -- neither normalized nor has had links resolved, and must not end with a -- a directory separator, to avoid duplicates later on. -- -- If For_All_Sources is True, then all possible file names are analyzed -- otherwise only those currently set in the Source_Names hash table. procedure Check_File_Naming_Schemes (Project : Project_Processing_Data; File_Name : File_Name_Type; Alternate_Languages : out Language_List; Language : out Language_Ptr; Display_Language_Name : out Name_Id; Unit : out Name_Id; Lang_Kind : out Language_Kind; Kind : out Source_Kind); -- Check if the file name File_Name conforms to one of the naming schemes -- of the project. If the file does not match one of the naming schemes, -- set Language to No_Language_Index. Filename is the name of the file -- being investigated. It has been normalized (case-folded). File_Name is -- the same value. procedure Get_Object_Directory (Project : Project_Id; Data : in out Tree_Processing_Data; No_Sources : Boolean := False); -- Get the object directory of a project. procedure Get_Directories (Project : Project_Id; Data : in out Tree_Processing_Data; No_Sources : out Boolean); -- Get the object directory, the exec directory and the source directories -- of a project. Set No_Sources to True if there are no sources in the -- project and the project is not an extending project. procedure Get_Mains (Project : Project_Id; Data : in out Tree_Processing_Data); -- Get the mains of a project from attribute Main, if it exists, and put -- them in the project data. procedure Get_Sources_From_File (Path : String; Location : Source_Ptr; Project : in out Project_Processing_Data; Data : in out Tree_Processing_Data); -- Get the list of sources from a text file and put them in hash table -- Source_Names. procedure Find_Sources (Project : in out Project_Processing_Data; Data : in out Tree_Processing_Data); -- Process the Source_Files and Source_List_File attributes, and store the -- list of source files into the Source_Names htable. When these attributes -- are not defined, find all files matching the naming schemes in the -- source directories. If Allow_Duplicate_Basenames, then files with the -- same base names are authorized within a project for source-based -- languages (never for unit based languages) procedure Compute_Unit_Name (File_Name : File_Name_Type; Naming : Lang_Naming_Data; Kind : out Source_Kind; Unit : out Name_Id; Project : Project_Processing_Data); -- Check whether the file matches the naming scheme. If it does, -- compute its unit name. If Unit is set to No_Name on exit, none of the -- other out parameters are relevant. procedure Check_Illegal_Suffix (Project : Project_Id; Suffix : File_Name_Type; Dot_Replacement : File_Name_Type; Attribute_Name : String; Location : Source_Ptr; Data : in out Tree_Processing_Data); -- Display an error message if the given suffix is illegal for some reason. -- The name of the attribute we are testing is specified in Attribute_Name, -- which is used in the error message. Location is the location where the -- suffix is defined. procedure Locate_Directory (Project : Project_Id; Name : File_Name_Type; Path : out Path_Information; Dir_Exists : out Boolean; Data : in out Tree_Processing_Data; Create : String := ""; Location : Source_Ptr := No_Location; Must_Exist : Boolean := True; Externally_Built : Boolean := False); -- Locate a directory. Name is the directory name. Relative paths are -- resolved relative to the project's directory. If the directory does -- not exist: -- - if Must_Exit is False, we return without checking for its existence -- - otherwise, if Create is a non-empty string, it might get created, -- following the behavior prescribed by Create_Dirs. -- In all cases, Dir_Exists indicates whether the directory now exists. -- Create is also used for debugging traces to show which path we are -- computing. procedure Look_For_Sources (Project : in out Project_Processing_Data; Data : in out Tree_Processing_Data); -- Find all the sources of project Project in project tree Data.Tree and -- update its Data accordingly. This assumes that the special naming -- exceptions have already been processed. function Path_Name_Of (File_Name : File_Name_Type; Directory : Path_Name_Type) return String; -- Returns the path name of a (non project) file. Returns an empty string -- if file cannot be found. procedure Remove_Source (Tree : Project_Tree_Ref; Id : Source_Id; Replaced_By : Source_Id); -- Remove a file from the list of sources of a project. This might be -- because the file is replaced by another one in an extending project, -- or because a file was added as a naming exception but was not found -- in the end. procedure Report_No_Sources (Project : Project_Id; Lang_Name : String; Data : Tree_Processing_Data; Location : Source_Ptr; Continuation : Boolean := False); -- Report an error or a warning depending on the value of When_No_Sources -- when there are no sources for language Lang_Name. procedure Show_Source_Dirs (Project : Project_Id; Shared : Shared_Project_Tree_Data_Access); -- List all the source directories of a project procedure Write_Attr (Name, Value : String); -- Debug print a value for a specific property. Does nothing when not in -- debug mode procedure Error_Or_Warning (Flags : Processing_Flags; Kind : Error_Warning; Msg : String; Location : Source_Ptr; Project : Project_Id); -- Process a message depending on Kind. -- Error or Warning going to be printed. -- Silent going to be ignored. -- Decide_Later going to be kept until call to Messages_Decision, function No_Space_Img (N : Natural) return String; -- Image of a Natural without the initial space ---------------------- -- Error_Or_Warning -- ---------------------- procedure Error_Or_Warning (Flags : Processing_Flags; Kind : Error_Warning; Msg : String; Location : Source_Ptr; Project : Project_Id) is begin case Kind is when Silent => null; when Error => Error_Msg (Flags, Msg, Location, Project); when Warning => Error_Msg (Flags, "?" & Msg, Location, Project); when Decide_Later => Errors_Holder.Append (Error_Message'(Msg'Length, Flags, Location, Project, Msg)); end case; end Error_Or_Warning; ----------------------- -- Messages_Decision -- ----------------------- procedure Messages_Decision (Kind : Decided_Message) is begin for M of Errors_Holder loop Error_Or_Warning (M.Flags, Kind, M.Msg, M.Location, M.Project); end loop; Errors_Holder.Clear; end Messages_Decision; ------------------------------ -- Replace_Into_Name_Buffer -- ------------------------------ procedure Replace_Into_Name_Buffer (Str : String; Pattern : String; Replacement : Character) is Max : constant Integer := Str'Last - Pattern'Length + 1; J : Positive; begin Name_Len := 0; J := Str'First; while J <= Str'Last loop Name_Len := Name_Len + 1; if J <= Max and then Str (J .. J + Pattern'Length - 1) = Pattern then Name_Buffer (Name_Len) := Replacement; J := J + Pattern'Length; else Name_Buffer (Name_Len) := To_Lower (Str (J)); J := J + 1; end if; end loop; end Replace_Into_Name_Buffer; -------------------- -- Suffix_Matches -- -------------------- function Suffix_Matches (Filename : String; Suffix : File_Name_Type) return Boolean is Min_Prefix_Length : Natural := 0; begin if Suffix in No_File | Empty_File then return False; end if; declare Suf : String := Get_Name_String (Suffix); begin -- On non case-sensitive systems, use proper suffix casing Canonical_Case_File_Name (Suf); -- The file name must end with the suffix (which is not an extension) -- For instance a suffix "configure.in" must match a file with the -- same name. To avoid dummy cases, though, a suffix starting with -- '.' requires a file that is at least one character longer ('.cpp' -- should not match a file with the same name). if Suf (Suf'First) = '.' then Min_Prefix_Length := 1; end if; return Filename'Length >= Suf'Length + Min_Prefix_Length and then Filename (Filename'Last - Suf'Length + 1 .. Filename'Last) = Suf; end; end Suffix_Matches; ---------------- -- Write_Attr -- ---------------- procedure Write_Attr (Name, Value : String) is begin if Current_Verbosity = High then Debug_Output (Name & " = """ & Value & '"'); end if; end Write_Attr; ---------------- -- Add_Source -- ---------------- procedure Add_Source (Id : out Source_Id; Data : in out Tree_Processing_Data; Project : Project_Id; Source_Dir_Rank : Natural; Lang_Id : Language_Ptr; Kind : Source_Kind; File_Name : File_Name_Type; Display_File : File_Name_Type; Naming_Exception : Naming_Exception_Type := No; Path : Path_Information := No_Path_Information; Alternate_Languages : Language_List := null; Unit : Name_Id := No_Name; Index : Int := 0; Locally_Removed : Boolean := False; Location : Source_Ptr := No_Location) is Config : constant Language_Config := Lang_Id.Config; UData : Unit_Index; Add_Src : Boolean; Source : Source_Id; Prev_Unit : Unit_Index := No_Unit_Index; Source_To_Replace : Source_Id := No_Source; S_Or_B : Spec_Or_Body; begin -- Check if the same file name or unit is used in the prj tree Add_Src := True; if Kind = Sep then S_Or_B := Impl; else S_Or_B := Kind; end if; if Unit /= No_Name then Prev_Unit := Units_Htable.Get (Data.Tree.Units_HT, Unit); end if; if Prev_Unit /= No_Unit_Index and then Prev_Unit.File_Names (S_Or_B) /= null then -- Suspicious, we need to check later whether this is authorized Add_Src := False; Source := Prev_Unit.File_Names (S_Or_B); else Source := Source_Files_Htable.Get (Data.Tree.Source_Files_HT, File_Name); if Source /= No_Source and then Source.Index = Index then Add_Src := False; end if; end if; -- Always add the source if it is locally removed, to avoid incorrect -- duplicate checks. if Locally_Removed then Add_Src := True; -- A locally removed source may first replace a source in a project -- being extended. if Source /= No_Source and then Is_Extending (Project, Source.Project) and then Naming_Exception /= Inherited then Source_To_Replace := Source; end if; else -- Duplication of file/unit in same project is allowed if order of -- source directories is known, or if there is no compiler for the -- language. if Add_Src = False then Add_Src := True; if Project = Source.Project and then not Source.Locally_Removed then if Prev_Unit = No_Unit_Index then if Data.Flags.Allow_Duplicate_Basenames then Add_Src := True; elsif Lang_Id.Config.Compiler_Driver = Empty_File then Add_Src := True; elsif Source_Dir_Rank /= Source.Source_Dir_Rank then Add_Src := False; else Error_Msg_File_1 := File_Name; Error_Msg (Data.Flags, "duplicate source file name {", Location, Project); Add_Src := False; end if; else if Source_Dir_Rank /= Source.Source_Dir_Rank then Add_Src := False; -- We might be seeing the same file through a different -- path (for instance because of symbolic links). elsif Source.Path.Name /= Path.Name then if not Source.Duplicate_Unit then Error_Msg_Name_1 := Unit; Error_Msg (Data.Flags, "\duplicate unit %%", Location, Project); if Verbose_Mode then Error_Msg_Name_1 := Name_Id (Source.Path.Name); Error_Msg (Data.Flags, "\ %%", Location, Project); Error_Msg_Name_1 := Name_Id (Path.Name); Error_Msg (Data.Flags, "\ %%", Location, Project); end if; Source.Duplicate_Unit := True; end if; Add_Src := False; end if; end if; -- Do not allow the same unit name in different projects, -- except if one is extending the other. -- For a file based language, the same file name replaces a -- file in a project being extended, but it is allowed to have -- the same file name in unrelated projects. elsif Is_Extending (Project, Source.Project) then if not Locally_Removed and then Naming_Exception /= Inherited then Source_To_Replace := Source; end if; elsif Prev_Unit /= No_Unit_Index and then Prev_Unit.File_Names (Kind) /= null and then Source.Replaced_By = No_Source and then not Data.In_Aggregate_Lib then -- Path is set if this is a source we found on the disk, in -- which case we can provide more explicit error message. Path -- is unset when the source is added from one of the naming -- exceptions in the project. if Path /= No_Path_Information then Error_Msg_Name_1 := Unit; Error_Msg (Data.Flags, "unit %% cannot belong to several projects", Location, Project); Error_Msg_Name_1 := Project.Name; Error_Msg_Name_2 := Name_Id (Path.Display_Name); Error_Msg (Data.Flags, "\ project %%, %%", Location, Project); Error_Msg_Name_1 := Source.Project.Name; Error_Msg_Name_2 := Name_Id (Source.Path.Display_Name); Error_Msg (Data.Flags, "\ project %%, %%", Location, Project); else Error_Msg_Name_1 := Unit; Error_Msg_Name_2 := Source.Project.Name; Error_Msg (Data.Flags, "unit %% already belongs to project %%", Location, Project); end if; Add_Src := False; elsif Source.Replaced_By = No_Source and then not Data.Flags.Allow_Duplicate_Basenames and then Lang_Id.Config.Kind = File_Based and then Source.Language.Config.Kind = File_Based and then not Data.In_Aggregate_Lib then if Path /= No_Path_Information and then Path = Source.Path then Error_Msg_Name_1 := Name_Id (Path.Display_Name); Error_Msg_Name_2 := Source.Project.Name; Error_Msg (Data.Flags, "%% is already a source of project %%", Location, Project); Add_Src := False; else Add_Src := True; end if; elsif Source.Replaced_By /= No_Source and then not Data.Flags.Allow_Duplicate_Basenames and then Lang_Id.Config.Kind = Unit_Based and then Source.Language.Config.Kind = Unit_Based and then not Data.In_Aggregate_Lib then Error_Msg_File_1 := File_Name; Error_Msg_File_2 := File_Name_Type (Source.Project.Name); Error_Msg (Data.Flags, "{ is already a source of project {", Location, Project); -- Add the file anyway, to avoid further warnings like -- "language unknown". Add_Src := True; end if; end if; end if; if not Add_Src then return; end if; -- Add the new file Id := new Source_Data; if Current_Verbosity = High then Debug_Indent; Write_Str ("adding source File: "); Write_Str (Get_Name_String (Display_File)); if Index /= 0 then Write_Str (" at" & Index'Img); end if; if Lang_Id.Config.Kind = Unit_Based then Write_Str (" Unit: "); -- ??? in gprclean, it seems we sometimes pass an empty Unit name -- (see test extended_projects). if Unit /= No_Name then Write_Str (Get_Name_String (Unit)); end if; Write_Str (" Kind: "); Write_Str (Source_Kind'Image (Kind)); end if; Write_Eol; end if; Id.Project := Project; Id.Location := Location; Id.Source_Dir_Rank := Source_Dir_Rank; Id.Language := Lang_Id; Id.Kind := Kind; Id.Alternate_Languages := Alternate_Languages; Id.Locally_Removed := Locally_Removed; Id.Index := Index; Id.File := File_Name; Id.Display_File := Display_File; Id.Dep_Name := Dependency_Name (File_Name, Lang_Id.Config.Dependency_Kind); Id.Naming_Exception := Naming_Exception; Id.Object := Object_Name (File_Name, Config.Object_File_Suffix); Id.Switches := Switches_Name (File_Name); -- Add the source id to the Unit_Sources_HT hash table, if the unit name -- is not null. if Unit /= No_Name then -- Note: we might be creating a dummy unit here, when we in fact have -- a separate. For instance, file file-bar.adb will initially be -- assumed to be the IMPL of unit "file.bar". Only later on (in -- Check_Object_Files) will we parse those units that only have an -- impl and no spec to make sure whether we have a Separate in fact -- (that significantly reduces the number of times we need to parse -- the files, since we are then only interested in those with no -- spec). We still need those dummy units in the table, since that's -- the name we find in the ALI file UData := Units_Htable.Get (Data.Tree.Units_HT, Unit); if UData = No_Unit_Index then UData := new Unit_Data; UData.Name := Unit; if Naming_Exception /= Inherited then Units_Htable.Set (Data.Tree.Units_HT, Unit, UData); end if; end if; Id.Unit := UData; -- Note that this updates Unit information as well if Naming_Exception /= Inherited and then not Locally_Removed then Override_Kind (Id, Kind); end if; end if; if Path /= No_Path_Information then Id.Path := Path; Source_Paths_Htable.Set (Data.Tree.Source_Paths_HT, Path.Name, Id); end if; Id.Next_With_File_Name := Source_Files_Htable.Get (Data.Tree.Source_Files_HT, File_Name); Source_Files_Htable.Set (Data.Tree.Source_Files_HT, File_Name, Id); if Index /= 0 then Project.Has_Multi_Unit_Sources := True; end if; -- Add the source to the language list Id.Next_In_Lang := Lang_Id.First_Source; Lang_Id.First_Source := Id; if Source_To_Replace /= No_Source then Remove_Source (Data.Tree, Source_To_Replace, Id); end if; if Data.Tree.Replaced_Source_Number > 0 and then Replaced_Source_HTable.Get (Data.Tree.Replaced_Sources, Id.File) /= No_File then Replaced_Source_HTable.Remove (Data.Tree.Replaced_Sources, Id.File); Data.Tree.Replaced_Source_Number := Data.Tree.Replaced_Source_Number - 1; end if; end Add_Source; ------------------------------ -- Canonical_Case_File_Name -- ------------------------------ function Canonical_Case_File_Name (Name : Name_Id) return File_Name_Type is begin if Name = No_Name then return File_Name_Type (Name); else Get_Name_String (Name); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); return Name_Find; end if; end Canonical_Case_File_Name; --------------------------------- -- Process_Aggregated_Projects -- --------------------------------- procedure Process_Aggregated_Projects (Tree : Project_Tree_Ref; Project : Project_Id; Node_Tree : GPR.Tree.Project_Node_Tree_Ref; Flags : Processing_Flags) is Data : Tree_Processing_Data := (Tree => Tree, Node_Tree => Node_Tree, Flags => Flags, In_Aggregate_Lib => False); Project_Files : constant GPR.Variable_Value := GPR.Util.Value_Of (Snames.Name_Project_Files, Project.Decl.Attributes, Tree.Shared); Project_Path_For_Aggregate : GPR.Env.Project_Search_Path; procedure Found_Project_File (Path : Path_Information; Rank : Natural); -- Called for each project file aggregated by Project ------------------------ -- Found_Project_File -- ------------------------ procedure Found_Project_File (Path : Path_Information; Rank : Natural) is pragma Unreferenced (Rank); begin if Path.Name /= Project.Path.Name then Debug_Output ("aggregates: ", Name_Id (Path.Display_Name)); -- For usual "with" statement, this phase will have been done when -- parsing the project itself. However, for aggregate projects, we -- can only do this when processing the aggregate project, since -- the exact list of project files or project directories can -- depend on scenario variables. -- -- We only load the projects explicitly here, but do not process -- them. For the processing, GPR.Proc will take care of -- processing them, within the same call to Recursive_Process -- (thus avoiding the processing of a given project multiple -- times). -- -- ??? We might already have loaded the project Add_Aggregated_Project (Project, Path => Path.Display_Name); else Debug_Output ("pattern returned the aggregate itself, ignored"); end if; end Found_Project_File; -- Start of processing for Check_Aggregate_Project begin pragma Assert (Project.Qualifier in Aggregate_Project); if Project_Files.Default then Error_Msg_Name_1 := Snames.Name_Project_Files; Error_Msg (Flags, "Attribute %% must be specified in aggregate project", Project.Location, Project); return; end if; -- The aggregated projects are only searched relative to the directory -- of the aggregate project, not in the default project path. Initialize_Empty (Project_Path_For_Aggregate); Free (Project.Aggregated_Projects); -- Look for aggregated projects. For similarity with source files and -- dirs, the aggregated project files are not searched for on the -- project path, and are only found through the path specified in -- the Project_Files attribute. Expand_Subdirectory_Pattern (Project => Project, Data => Data, Patterns => Project_Files.Values, Ignore => Nil_String, Search_For => Search_Project_Files, Resolve_Links => Opt.Follow_Links_For_Files, Callback => Found_Project_File'Access); Free (Project_Path_For_Aggregate); end Process_Aggregated_Projects; ---------------------------- -- Check_Abstract_Project -- ---------------------------- procedure Check_Abstract_Project (Project : Project_Id; Data : in out Tree_Processing_Data) is Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; Source_Dirs : constant Variable_Value := Util.Value_Of (Name_Source_Dirs, Project.Decl.Attributes, Shared); Source_Files : constant Variable_Value := Util.Value_Of (Name_Source_Files, Project.Decl.Attributes, Shared); Source_List_File : constant Variable_Value := Util.Value_Of (Name_Source_List_File, Project.Decl.Attributes, Shared); Languages : constant Variable_Value := Util.Value_Of (Name_Languages, Project.Decl.Attributes, Shared); begin if Project.Source_Dirs /= Nil_String then if Source_Dirs.Values = Nil_String and then Source_Files.Values = Nil_String and then Languages.Values = Nil_String and then Source_List_File.Default then Project.Source_Dirs := Nil_String; else Error_Msg (Data.Flags, "non-empty set of sources can''t be defined in an abstract" & " project", Project.Location, Project); end if; end if; end Check_Abstract_Project; ------------------------- -- Check_Configuration -- ------------------------- procedure Check_Configuration (Project : Project_Id; Data : in out Tree_Processing_Data) is Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; Dot_Replacement : File_Name_Type := No_File; Casing : Casing_Type := All_Lower_Case; Separate_Suffix : File_Name_Type := No_File; Lang_Index : Language_Ptr := No_Language_Index; -- The index of the language data being checked procedure Process_Project_Level_Simple_Attributes; -- Process the simple attributes at the project level procedure Process_Project_Level_Array_Attributes; -- Process the associate array attributes at the project level procedure Process_Packages; -- Read the packages of the project ---------------------- -- Process_Packages -- ---------------------- procedure Process_Packages is Packages : Package_Id; Element : Package_Element; procedure Process_Binder (Arrays : Array_Id); -- Process the associated array attributes of package Binder procedure Process_Builder (Attributes : Variable_Id); -- Process the simple attributes of package Builder procedure Process_Clean (Attributes : Variable_Id); -- Process the simple attributes of package Clean procedure Process_Clean (Arrays : Array_Id); -- Process the associated array attributes of package Clean procedure Process_Compiler (Attributes : Variable_Id); -- Process the simple attributes of package Compiler procedure Process_Compiler (Arrays : Array_Id); -- Process the associated array attributes of package Compiler procedure Process_Naming (Attributes : Variable_Id); -- Process the simple attributes of package Naming procedure Process_Naming (Arrays : Array_Id); -- Process the associated array attributes of package Naming procedure Process_Linker (Attributes : Variable_Id); -- Process the simple attributes of package Linker of a -- configuration project. procedure Process_Linker (Arrays : Array_Id); -- Process the associated array attributes of package Linker procedure Resp_File_Format (Name : Name_Id; Format : out Response_File_Format; Success : out Boolean); -- Get a response file format named Name. Success is True if Name is -- a valine response file format name. -------------------- -- Process_Binder -- -------------------- procedure Process_Binder (Arrays : Array_Id) is Current_Array_Id : Array_Id; Current_Array : Array_Data; Element_Id : Array_Element_Id; Element : Array_Element; begin -- Process the associative array attribute of package Binder Current_Array_Id := Arrays; while Current_Array_Id /= No_Array loop Current_Array := Shared.Arrays.Table (Current_Array_Id); Element_Id := Current_Array.Value; while Element_Id /= No_Array_Element loop Element := Shared.Array_Elements.Table (Element_Id); if Element.Index /= All_Other_Names then -- Get the name of the language Lang_Index := Get_Language_From_Name (Project, Get_Name_String (Element.Index)); if Lang_Index /= No_Language_Index then if Current_Array.Name = Name_Driver then -- Attribute Driver () Lang_Index.Config.Binder_Driver := File_Name_Type (Element.Value.Value); elsif Current_Array.Name = Name_Required_Switches then Put (Into_List => Lang_Index.Config.Binder_Required_Switches, From_List => Element.Value.Values, In_Tree => Data.Tree); elsif Current_Array.Name = Name_Prefix then -- Attribute Prefix () Lang_Index.Config.Binder_Prefix := Element.Value.Value; elsif Current_Array.Name = Name_Objects_Path then -- Attribute Objects_Path () Lang_Index.Config.Objects_Path := Element.Value.Value; elsif Current_Array.Name = Name_Objects_Path_File then -- Attribute Objects_Path () Lang_Index.Config.Objects_Path_File := Element.Value.Value; end if; end if; end if; Element_Id := Element.Next; end loop; Current_Array_Id := Current_Array.Next; end loop; end Process_Binder; --------------------- -- Process_Builder -- --------------------- procedure Process_Builder (Attributes : Variable_Id) is Attribute_Id : Variable_Id; Attribute : Variable; begin -- Process non associated array attribute from package Builder Attribute_Id := Attributes; while Attribute_Id /= No_Variable loop Attribute := Shared.Variable_Elements.Table (Attribute_Id); if not Attribute.Value.Default then if Attribute.Name = Name_Executable_Suffix then -- Attribute Executable_Suffix: the suffix of the -- executables. Project.Config.Executable_Suffix := Attribute.Value.Value; end if; end if; Attribute_Id := Attribute.Next; end loop; end Process_Builder; ------------------- -- Process_Clean -- ------------------- procedure Process_Clean (Attributes : Variable_Id) is Attribute_Id : Variable_Id; Attribute : Variable; List : String_List_Id; begin -- Process non associated array attributes from package Clean Attribute_Id := Attributes; while Attribute_Id /= No_Variable loop Attribute := Shared.Variable_Elements.Table (Attribute_Id); if not Attribute.Value.Default then if Attribute.Name = Name_Artifacts_In_Exec_Dir then -- Attribute Artifacts_In_Exec_Dir: the list of file -- names to be cleaned in the exec dir of the main -- project. List := Attribute.Value.Values; if List /= Nil_String then Put (Into_List => Project.Config.Artifacts_In_Exec_Dir, From_List => List, In_Tree => Data.Tree); end if; elsif Attribute.Name = Name_Artifacts_In_Object_Dir then -- Attribute Artifacts_In_Exec_Dir: the list of file -- names to be cleaned in the object dir of every -- project. List := Attribute.Value.Values; if List /= Nil_String then Put (Into_List => Project.Config.Artifacts_In_Object_Dir, From_List => List, In_Tree => Data.Tree); end if; end if; end if; Attribute_Id := Attribute.Next; end loop; end Process_Clean; procedure Process_Clean (Arrays : Array_Id) is Current_Array_Id : Array_Id; Current_Array : Array_Data; Element_Id : Array_Element_Id; Element : Array_Element; List : String_List_Id; begin -- Process the associated array attributes of package Clean Current_Array_Id := Arrays; while Current_Array_Id /= No_Array loop Current_Array := Shared.Arrays.Table (Current_Array_Id); Element_Id := Current_Array.Value; while Element_Id /= No_Array_Element loop Element := Shared.Array_Elements.Table (Element_Id); -- Get the name of the language Lang_Index := Get_Language_From_Name (Project, Get_Name_String (Element.Index)); if Lang_Index /= No_Language_Index then -- Attribute Object_Artifact_Extensions () if Current_Array.Name = Name_Object_Artifact_Extensions then List := Element.Value.Values; if List /= Nil_String then Put (Into_List => Lang_Index.Config.Clean_Object_Artifacts, From_List => List, In_Tree => Data.Tree); end if; -- Attribute Source_Artifact_Extensions () elsif Current_Array.Name = Name_Source_Artifact_Extensions then List := Element.Value.Values; if List /= Nil_String then Put (Into_List => Lang_Index.Config.Clean_Source_Artifacts, From_List => List, In_Tree => Data.Tree); end if; end if; end if; Element_Id := Element.Next; end loop; Current_Array_Id := Current_Array.Next; end loop; end Process_Clean; ---------------------- -- Process_Compiler -- ---------------------- procedure Process_Compiler (Attributes : Variable_Id) is Attribute_Id : Variable_Id; Attribute : Variable; begin -- Process non associated array attributes from package Compiler Attribute_Id := Attributes; while Attribute_Id /= No_Variable loop Attribute := Shared.Variable_Elements.Table (Attribute_Id); if not Attribute.Value.Default then if Attribute.Name = Name_Max_Command_Line_Length then declare Value : Natural; begin Value := Natural'Value (Get_Name_String (Attribute.Value.Value)); if Project.Config.Max_Command_Line_Length = 0 or else Value < Project.Config.Max_Command_Line_Length then Project.Config.Max_Command_Line_Length := Value; end if; exception when Constraint_Error => Error_Msg (Data.Flags, "value must be positive or equal to 0", Attribute.Value.Location, Project); end; end if; end if; Attribute_Id := Attribute.Next; end loop; end Process_Compiler; procedure Process_Compiler (Arrays : Array_Id) is Current_Array_Id : Array_Id; Current_Array : Array_Data; Element_Id : Array_Element_Id; Element : Array_Element; List : String_List_Id; begin -- Process the associative array attribute of package Compiler Current_Array_Id := Arrays; while Current_Array_Id /= No_Array loop Current_Array := Shared.Arrays.Table (Current_Array_Id); Element_Id := Current_Array.Value; while Element_Id /= No_Array_Element loop Element := Shared.Array_Elements.Table (Element_Id); if Element.Index /= All_Other_Names then -- Get the name of the language Lang_Index := Get_Language_From_Name (Project, Get_Name_String (Element.Index)); if Lang_Index /= No_Language_Index then -- Attribute Dependency_Kind () if Current_Array.Name = Name_Dependency_Kind then Get_Name_String (Element.Value.Value); begin Lang_Index.Config.Dependency_Kind := Dependency_File_Kind'Value (Name_Buffer (1 .. Name_Len)); exception when Constraint_Error => Error_Msg (Data.Flags, "illegal value for Dependency_Kind", Element.Value.Location, Project); end; -- Attribute Dependency_Switches () elsif Current_Array.Name = Name_Dependency_Switches then if Lang_Index.Config.Dependency_Kind = None then Lang_Index.Config.Dependency_Kind := Makefile; end if; List := Element.Value.Values; if List /= Nil_String then Put (Into_List => Lang_Index.Config.Dependency_Option, From_List => List, In_Tree => Data.Tree); end if; -- Attribute Dependency_Driver () elsif Current_Array.Name = Name_Dependency_Driver then if Lang_Index.Config.Dependency_Kind = None then Lang_Index.Config.Dependency_Kind := Makefile; end if; List := Element.Value.Values; if List /= Nil_String then Put (Into_List => Lang_Index.Config.Compute_Dependency, From_List => List, In_Tree => Data.Tree); end if; -- Attribute Language_Kind () elsif Current_Array.Name = Name_Language_Kind then Get_Name_String (Element.Value.Value); begin Lang_Index.Config.Kind := Language_Kind'Value (Name_Buffer (1 .. Name_Len)); exception when Constraint_Error => Error_Msg (Data.Flags, "illegal value for Language_Kind", Element.Value.Location, Project); end; -- Attribute Include_Switches () elsif Current_Array.Name = Name_Include_Switches then List := Element.Value.Values; if List = Nil_String then Error_Msg (Data.Flags, "include option cannot be null", Element.Value.Location, Project); end if; Put (Into_List => Lang_Index.Config.Include_Option, From_List => List, In_Tree => Data.Tree); -- Attribute Include_Switches_Via_Spec -- () elsif Current_Array.Name = Name_Include_Switches_Via_Spec then List := Element.Value.Values; if List = Nil_String then Error_Msg (Data.Flags, "include switches via spec cannot be null", Element.Value.Location, Project); end if; Put (Into_List => Lang_Index.Config.Include_Switches_Via_Spec, From_List => List, In_Tree => Data.Tree); -- Attribute Include_Path () elsif Current_Array.Name = Name_Include_Path then Lang_Index.Config.Include_Path := Element.Value.Value; -- Attribute Include_Path_File () elsif Current_Array.Name = Name_Include_Path_File then Lang_Index.Config.Include_Path_File := Element.Value.Value; -- Attribute Driver () elsif Current_Array.Name = Name_Driver then Lang_Index.Config.Compiler_Driver := File_Name_Type (Element.Value.Value); -- Attributes Required_Switches () and -- Leading_Required_Switches (. elsif Current_Array.Name = Name_Required_Switches or else Current_Array.Name = Name_Leading_Required_Switches then Put (Into_List => Lang_Index.Config. Compiler_Leading_Required_Switches, From_List => Element.Value.Values, In_Tree => Data.Tree); -- Attribute Trailing_Required_Switches ( elsif Current_Array.Name = Name_Trailing_Required_Switches then Put (Into_List => Lang_Index.Config. Compiler_Trailing_Required_Switches, From_List => Element.Value.Values, In_Tree => Data.Tree); -- Attribute Multi_Unit_Switches () elsif Current_Array.Name = Name_Multi_Unit_Switches then Put (Into_List => Lang_Index.Config.Multi_Unit_Switches, From_List => Element.Value.Values, In_Tree => Data.Tree); -- Attribute Multi_Unit_Object_Separator (lang) elsif Current_Array.Name = Name_Multi_Unit_Object_Separator then Get_Name_String (Element.Value.Value); if Name_Len /= 1 then Error_Msg (Data.Flags, "multi-unit object separator must have a" & " single character", Element.Value.Location, Project); elsif Name_Buffer (1) = ' ' then Error_Msg (Data.Flags, "multi-unit object separator cannot be a" & " space", Element.Value.Location, Project); else Lang_Index.Config.Multi_Unit_Object_Separator := Name_Buffer (1); end if; -- Attribute Source_File_Switches () elsif Current_Array.Name = Name_Source_File_Switches then Put (Into_List => Lang_Index.Config.Source_File_Switches, From_List => Element.Value.Values, In_Tree => Data.Tree); -- Attribute Object_File_Suffix () elsif Current_Array.Name = Name_Object_File_Suffix then if Get_Name_String (Element.Value.Value) = "" then Error_Msg (Data.Flags, "object file suffix cannot be empty", Element.Value.Location, Project); else Lang_Index.Config.Object_File_Suffix := Element.Value.Value; end if; -- Attribute Object_File_Switches () elsif Current_Array.Name = Name_Object_File_Switches then Put (Into_List => Lang_Index.Config.Object_File_Switches, From_List => Element.Value.Values, In_Tree => Data.Tree); -- Attribute Object_Path_Switches () elsif Current_Array.Name = Name_Object_Path_Switches then Put (Into_List => Lang_Index.Config.Object_Path_Switches, From_List => Element.Value.Values, In_Tree => Data.Tree); -- Attribute Compiler_Pic_Option () elsif Current_Array.Name = Name_Pic_Option then List := Element.Value.Values; if List = Nil_String then Error_Msg (Data.Flags, "compiler PIC option cannot be null", Element.Value.Location, Project); end if; Put (Into_List => Lang_Index.Config.Compilation_PIC_Option, From_List => List, In_Tree => Data.Tree); -- Attribute Mapping_File_Switches () elsif Current_Array.Name = Name_Mapping_File_Switches then List := Element.Value.Values; if List = Nil_String then Error_Msg (Data.Flags, "mapping file switches cannot be null", Element.Value.Location, Project); end if; Put (Into_List => Lang_Index.Config.Mapping_File_Switches, From_List => List, In_Tree => Data.Tree); -- Attribute Mapping_Spec_Suffix () elsif Current_Array.Name = Name_Mapping_Spec_Suffix then Lang_Index.Config.Mapping_Spec_Suffix := File_Name_Type (Element.Value.Value); -- Attribute Mapping_Body_Suffix () elsif Current_Array.Name = Name_Mapping_Body_Suffix then Lang_Index.Config.Mapping_Body_Suffix := File_Name_Type (Element.Value.Value); -- Attribute Config_File_Switches () elsif Current_Array.Name = Name_Config_File_Switches then List := Element.Value.Values; if List = Nil_String then Error_Msg (Data.Flags, "config file switches cannot be null", Element.Value.Location, Project); end if; Put (Into_List => Lang_Index.Config.Config_File_Switches, From_List => List, In_Tree => Data.Tree); -- Attribute Objects_Path () elsif Current_Array.Name = Name_Objects_Path then Lang_Index.Config.Objects_Path := Element.Value.Value; -- Attribute Objects_Path_File () elsif Current_Array.Name = Name_Objects_Path_File then Lang_Index.Config.Objects_Path_File := Element.Value.Value; -- Attribute Config_Body_File_Name () elsif Current_Array.Name = Name_Config_Body_File_Name then Lang_Index.Config.Config_Body := Element.Value.Value; -- Attribute Config_Body_File_Name_Index () elsif Current_Array.Name = Name_Config_Body_File_Name_Index then Lang_Index.Config.Config_Body_Index := Element.Value.Value; -- Attribute Config_Body_File_Name_Pattern() elsif Current_Array.Name = Name_Config_Body_File_Name_Pattern then Lang_Index.Config.Config_Body_Pattern := Element.Value.Value; -- Attribute Config_Spec_File_Name () elsif Current_Array.Name = Name_Config_Spec_File_Name then Lang_Index.Config.Config_Spec := Element.Value.Value; -- Attribute Config_Spec_File_Name_Index () elsif Current_Array.Name = Name_Config_Spec_File_Name_Index then Lang_Index.Config.Config_Spec_Index := Element.Value.Value; -- Attribute Config_Spec_File_Name_Pattern() elsif Current_Array.Name = Name_Config_Spec_File_Name_Pattern then Lang_Index.Config.Config_Spec_Pattern := Element.Value.Value; -- Attribute Config_File_Dependency_Support () elsif Current_Array.Name = Name_Config_File_Dependency_Support then begin Lang_Index.Config.Config_File_Dependency_Support := Boolean'Value (Get_Name_String (Element.Value.Value)); exception when Constraint_Error => Error_Msg (Data.Flags, "illegal value for " & "Config_File_Dependency_Support", Element.Value.Location, Project); end; -- Attribute Config_File_Unique () elsif Current_Array.Name = Name_Config_File_Unique then begin Lang_Index.Config.Config_File_Unique := Boolean'Value (Get_Name_String (Element.Value.Value)); exception when Constraint_Error => Error_Msg (Data.Flags, "illegal value for Config_File_Unique", Element.Value.Location, Project); end; -- Attribute Response_File_Format () elsif Current_Array.Name = Name_Response_File_Format then declare Success : Boolean; begin Resp_File_Format (Element.Value.Value, Lang_Index.Config.Resp_File_Format, Success); if not Success then Error_Msg (Data.Flags, "illegal response file format", Element.Value.Location, Project); end if; end; -- Attribute Response_File_Switches () elsif Current_Array.Name = Name_Response_File_Switches then Put (Into_List => Lang_Index.Config.Resp_File_Options, From_List => Element.Value.Values, In_Tree => Data.Tree); end if; end if; end if; Element_Id := Element.Next; end loop; Current_Array_Id := Current_Array.Next; end loop; end Process_Compiler; -------------------- -- Process_Naming -- -------------------- procedure Process_Naming (Attributes : Variable_Id) is Attribute_Id : Variable_Id; Attribute : Variable; begin -- Process non associated array attribute from package Naming Attribute_Id := Attributes; while Attribute_Id /= No_Variable loop Attribute := Shared.Variable_Elements.Table (Attribute_Id); if not Attribute.Value.Default then if Attribute.Name = Name_Separate_Suffix then -- Attribute Separate_Suffix Get_Name_String (Attribute.Value.Value); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); Separate_Suffix := Name_Find; elsif Attribute.Name = Name_Casing then -- Attribute Casing begin if Attribute.Value.Value /= No_Name then Casing := Value (Get_Name_String (Attribute.Value.Value)); end if; exception when Constraint_Error => Error_Msg (Data.Flags, "invalid value for Casing", Attribute.Value.Location, Project); end; elsif Attribute.Name = Name_Dot_Replacement then -- Attribute Dot_Replacement Dot_Replacement := File_Name_Type (Attribute.Value.Value); end if; end if; Attribute_Id := Attribute.Next; end loop; end Process_Naming; procedure Process_Naming (Arrays : Array_Id) is Current_Array_Id : Array_Id; Current_Array : Array_Data; Element_Id : Array_Element_Id; Element : Array_Element; begin -- Process the associative array attribute of package Naming Current_Array_Id := Arrays; while Current_Array_Id /= No_Array loop Current_Array := Shared.Arrays.Table (Current_Array_Id); Element_Id := Current_Array.Value; while Element_Id /= No_Array_Element loop Element := Shared.Array_Elements.Table (Element_Id); -- Get the name of the language Lang_Index := Get_Language_From_Name (Project, Get_Name_String (Element.Index)); if Lang_Index /= No_Language_Index and then Element.Value.Kind = Single and then Element.Value.Value /= No_Name then if Current_Array.Name = Name_Spec_Suffix or else Current_Array.Name = Name_Specification_Suffix then -- Attribute Spec_Suffix () Get_Name_String (Element.Value.Value); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); Lang_Index.Config.Naming_Data.Spec_Suffix := Name_Find; elsif Current_Array.Name = Name_Implementation_Suffix or else Current_Array.Name = Name_Body_Suffix then Get_Name_String (Element.Value.Value); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); -- Attribute Body_Suffix () Lang_Index.Config.Naming_Data.Body_Suffix := Name_Find; Lang_Index.Config.Naming_Data.Separate_Suffix := Lang_Index.Config.Naming_Data.Body_Suffix; end if; end if; Element_Id := Element.Next; end loop; Current_Array_Id := Current_Array.Next; end loop; end Process_Naming; -------------------- -- Process_Linker -- -------------------- procedure Process_Linker (Attributes : Variable_Id) is Attribute_Id : Variable_Id; Attribute : Variable; begin -- Process non associated array attribute from package Linker Attribute_Id := Attributes; while Attribute_Id /= No_Variable loop Attribute := Shared.Variable_Elements.Table (Attribute_Id); if not Attribute.Value.Default then if Attribute.Name = Name_Driver then -- Attribute Linker'Driver: the default linker to use Project.Config.Linker := Path_Name_Type (Attribute.Value.Value); -- Linker'Driver is also used to link shared libraries -- if the obsolescent attribute Library_GCC has not been -- specified. if Project.Config.Shared_Lib_Driver = No_File then Project.Config.Shared_Lib_Driver := File_Name_Type (Attribute.Value.Value); end if; elsif Attribute.Name = Name_Required_Switches then -- Attribute Required_Switches: the minimum trailing -- options to use when invoking the linker Put (Into_List => Project.Config.Trailing_Linker_Required_Switches, From_List => Attribute.Value.Values, In_Tree => Data.Tree); elsif Attribute.Name = Name_Map_File_Option then Project.Config.Map_File_Option := Attribute.Value.Value; elsif Attribute.Name = Name_Max_Command_Line_Length then declare Value : Natural; begin Value := Natural'Value (Get_Name_String (Attribute.Value.Value)); if Project.Config.Max_Command_Line_Length = 0 or else Value < Project.Config.Max_Command_Line_Length then Project.Config.Max_Command_Line_Length := Value; end if; exception when Constraint_Error => Error_Msg (Data.Flags, "value must be positive or equal to 0", Attribute.Value.Location, Project); end; elsif Attribute.Name = Name_Response_File_Format then declare Success : Boolean; begin Resp_File_Format (Name => Attribute.Value.Value, Format => Project.Config.Resp_File_Format, Success => Success); if not Success then Error_Msg (Data.Flags, "illegal response file format", Attribute.Value.Location, Project); end if; end; elsif Attribute.Name = Name_Response_File_Switches then Put (Into_List => Project.Config.Resp_File_Options, From_List => Attribute.Value.Values, In_Tree => Data.Tree); elsif Attribute.Name = Name_Export_File_Switch then Project.Config.Export_File_Switch := Attribute.Value.Value; elsif Attribute.Name = Name_Export_File_Format then declare Name : constant Name_Id := Get_Lower_Name_Id (Get_Name_String (Attribute.Value.Value)); begin if Name = Name_None then Project.Config.Export_File_Format := None; elsif Name = Name_Gnu then Project.Config.Export_File_Format := GNU; elsif Name = Name_Def then Project.Config.Export_File_Format := Def; elsif Name = Name_Flat then Project.Config.Export_File_Format := Flat; else Error_Msg (Data.Flags, "illegal export file format", Attribute.Value.Location, Project); end if; end; end if; end if; Attribute_Id := Attribute.Next; end loop; end Process_Linker; procedure Process_Linker (Arrays : Array_Id) is Current_Array_Id : Array_Id; Current_Array : Array_Data; Element_Id : Array_Element_Id; Element : Array_Element; begin -- Process the associated array attributes of package Clean Current_Array_Id := Arrays; while Current_Array_Id /= No_Array loop Current_Array := Shared.Arrays.Table (Current_Array_Id); if Current_Array.Name = Name_Unconditional_Linking then Element_Id := Current_Array.Value; while Element_Id /= No_Array_Element loop Element := Shared.Array_Elements.Table (Element_Id); -- Get the name of the language Lang_Index := Get_Language_From_Name (Project, Get_Name_String (Element.Index)); if Lang_Index /= No_Language_Index then -- Attribute Unconditional_Linking () begin Lang_Index.Unconditional_Linking := Boolean'Value (Get_Name_String (Element.Value.Value)); exception when Constraint_Error => Error_Msg (Data.Flags, "illegal value for Unconditional_Linking", Element.Value.Location, Project); end; end if; Element_Id := Element.Next; end loop; end if; Current_Array_Id := Current_Array.Next; end loop; end Process_Linker; ---------------------- -- Resp_File_Format -- ---------------------- procedure Resp_File_Format (Name : Name_Id; Format : out Response_File_Format; Success : out Boolean) is Low_Name : constant Name_Id := Get_Lower_Name_Id (Get_Name_String (Name)); begin Success := True; if Low_Name = Name_None then Format := None; elsif Low_Name = Name_Gnu then Format := GNU; elsif Low_Name = Name_Object_List then Format := Object_List; elsif Low_Name = Name_Option_List then Format := Option_List; elsif Low_Name = Name_Gcc then Format := GCC; elsif Low_Name = Name_Gcc_Gnu then Format := GCC_GNU; elsif Low_Name = Name_Gcc_Option_List then Format := GCC_Option_List; elsif Low_Name = Name_Gcc_Object_List then Format := GCC_Object_List; else Success := False; Format := None; end if; end Resp_File_Format; -- Start of processing for Process_Packages begin Packages := Project.Decl.Packages; while Packages /= No_Package loop Element := Shared.Packages.Table (Packages); if Element.Name = Name_Binder then -- Process attributes of package Binder Process_Binder (Element.Decl.Arrays); elsif Element.Name = Name_Builder then -- Process attributes of package Builder Process_Builder (Element.Decl.Attributes); elsif Element.Name = Name_Clean then -- Process attributes of package Clean Process_Clean (Element.Decl.Attributes); Process_Clean (Element.Decl.Arrays); elsif Element.Name = Name_Compiler then -- Process attributes of package Compiler Process_Compiler (Element.Decl.Attributes); Process_Compiler (Element.Decl.Arrays); elsif Element.Name = Name_Linker then -- Process attributes of package Linker Process_Linker (Element.Decl.Attributes); Process_Linker (Element.Decl.Arrays); elsif Element.Name = Name_Naming then -- Process attributes of package Naming Process_Naming (Element.Decl.Attributes); Process_Naming (Element.Decl.Arrays); end if; Packages := Element.Next; end loop; end Process_Packages; --------------------------------------------- -- Process_Project_Level_Simple_Attributes -- --------------------------------------------- procedure Process_Project_Level_Simple_Attributes is Attribute_Id : Variable_Id; Attribute : Variable; List : String_List_Id; begin -- Process non associated array attribute at project level Attribute_Id := Project.Decl.Attributes; while Attribute_Id /= No_Variable loop Attribute := Shared.Variable_Elements.Table (Attribute_Id); if not Attribute.Value.Default then if Attribute.Name = Name_Target then -- Attribute Target: the target specified Project.Config.Target := Attribute.Value.Value; elsif Attribute.Name = Name_Library_Builder then -- Attribute Library_Builder: the application to invoke -- to build libraries. Project.Config.Library_Builder := Path_Name_Type (Attribute.Value.Value); elsif Attribute.Name = Name_Archive_Builder then -- Attribute Archive_Builder: the archive builder -- (usually "ar") and its minimum options (usually "cr"). List := Attribute.Value.Values; if List /= Nil_String then Put (Into_List => Project.Config.Archive_Builder, From_List => List, In_Tree => Data.Tree); end if; elsif Attribute.Name = Name_Archive_Builder_Append_Option then -- Attribute Archive_Builder: the archive builder -- (usually "ar") and its minimum options (usually "cr"). List := Attribute.Value.Values; if List /= Nil_String then Put (Into_List => Project.Config.Archive_Builder_Append_Option, From_List => List, In_Tree => Data.Tree); end if; elsif Attribute.Name = Name_Archive_Indexer then -- Attribute Archive_Indexer: the optional archive -- indexer (usually "ranlib") with its minimum options -- (usually none). List := Attribute.Value.Values; if List = Nil_String then Error_Msg (Data.Flags, "archive indexer cannot be null", Attribute.Value.Location, Project); end if; Put (Into_List => Project.Config.Archive_Indexer, From_List => List, In_Tree => Data.Tree); elsif Attribute.Name = Name_Object_Lister then -- Attribute Object_Lister: the optional object -- lister (usually "nm") with its minimum options. List := Attribute.Value.Values; if List = Nil_String then Error_Msg (Data.Flags, "object lister cannot be null", Attribute.Value.Location, Project); end if; Put (Into_List => Project.Config.Object_Lister, From_List => List, In_Tree => Data.Tree); elsif Attribute.Name = Name_Object_Lister_Matcher then -- Attribute Object_Lister_Matcher: mandatory when -- object lister (usually "nm") is defined. Project.Config.Object_Lister_Matcher := Attribute.Value.Value; elsif Attribute.Name = Name_Library_Partial_Linker then -- Attribute Library_Partial_Linker: the optional linker -- driver with its minimum options, to partially link -- archives. Put (Into_List => Project.Config.Lib_Partial_Linker, From_List => Attribute.Value.Values, In_Tree => Data.Tree); elsif Attribute.Name = Name_Library_GCC then Project.Config.Shared_Lib_Driver := File_Name_Type (Attribute.Value.Value); Error_Msg (Data.Flags, "?Library_'G'C'C is an obsolescent attribute, use" & " Linker''Driver instead", Attribute.Value.Location, Project); elsif Attribute.Name = Name_Archive_Suffix then Project.Config.Archive_Suffix := File_Name_Type (Attribute.Value.Value); elsif Attribute.Name = Name_Linker_Executable_Option then -- Attribute Linker_Executable_Option: optional options -- to specify an executable name. Defaults to "-o". List := Attribute.Value.Values; if List = Nil_String then Error_Msg (Data.Flags, "linker executable option cannot be null", Attribute.Value.Location, Project); end if; Put (Into_List => Project.Config.Linker_Executable_Option, From_List => List, In_Tree => Data.Tree); elsif Attribute.Name = Name_Linker_Lib_Dir_Option then -- Attribute Linker_Lib_Dir_Option: optional options -- to specify a library search directory. Defaults to -- "-L". Get_Name_String (Attribute.Value.Value); if Name_Len = 0 then Error_Msg (Data.Flags, "linker library directory option cannot be empty", Attribute.Value.Location, Project); end if; Project.Config.Linker_Lib_Dir_Option := Attribute.Value.Value; elsif Attribute.Name = Name_Linker_Lib_Name_Option then -- Attribute Linker_Lib_Name_Option: optional options -- to specify the name of a library to be linked in. -- Defaults to "-l". Get_Name_String (Attribute.Value.Value); if Name_Len = 0 then Error_Msg (Data.Flags, "linker library name option cannot be empty", Attribute.Value.Location, Project); end if; Project.Config.Linker_Lib_Name_Option := Attribute.Value.Value; elsif Attribute.Name = Name_Run_Path_Option then -- Attribute Run_Path_Option: optional options to -- specify a path for libraries. List := Attribute.Value.Values; if List /= Nil_String then Put (Into_List => Project.Config.Run_Path_Option, From_List => List, In_Tree => Data.Tree); end if; elsif Attribute.Name = Name_Run_Path_Origin then Get_Name_String (Attribute.Value.Value); if Name_Len = 0 then Error_Msg (Data.Flags, "run path origin cannot be empty", Attribute.Value.Location, Project); end if; Project.Config.Run_Path_Origin := Attribute.Value.Value; elsif Attribute.Name = Name_Library_Install_Name_Option then Project.Config.Library_Install_Name_Option := Attribute.Value.Value; elsif Attribute.Name = Name_Separate_Run_Path_Options then declare pragma Unsuppress (All_Checks); begin Project.Config.Separate_Run_Path_Options := Boolean'Value (Get_Name_String (Attribute.Value.Value)); exception when Constraint_Error => Error_Msg (Data.Flags, "invalid value """ & Get_Name_String_Safe (Attribute.Value.Value) & """ for Separate_Run_Path_Options", Attribute.Value.Location, Project); end; elsif Attribute.Name = Name_Library_Support then declare pragma Unsuppress (All_Checks); begin Project.Config.Lib_Support := Library_Support'Value (Get_Name_String (Attribute.Value.Value)); exception when Constraint_Error => Error_Msg (Data.Flags, "invalid value """ & Get_Name_String_Safe (Attribute.Value.Value) & """ for Library_Support", Attribute.Value.Location, Project); end; elsif Attribute.Name = Name_Library_Encapsulated_Supported then declare pragma Unsuppress (All_Checks); begin Project.Config.Lib_Encapsulated_Supported := Boolean'Value (Get_Name_String (Attribute.Value.Value)); exception when Constraint_Error => Error_Msg (Data.Flags, "invalid value """ & Get_Name_String_Safe (Attribute.Value.Value) & """ for Library_Encapsulated_Supported", Attribute.Value.Location, Project); end; elsif Attribute.Name = Name_Shared_Library_Prefix then Project.Config.Shared_Lib_Prefix := File_Name_Type (Attribute.Value.Value); elsif Attribute.Name = Name_Shared_Library_Suffix then Project.Config.Shared_Lib_Suffix := File_Name_Type (Attribute.Value.Value); elsif Attribute.Name = Name_Symbolic_Link_Supported then declare pragma Unsuppress (All_Checks); begin Project.Config.Symbolic_Link_Supported := Boolean'Value (Get_Name_String (Attribute.Value.Value)); exception when Constraint_Error => Error_Msg (Data.Flags, "invalid value """ & Get_Name_String_Safe (Attribute.Value.Value) & """ for Symbolic_Link_Supported", Attribute.Value.Location, Project); end; elsif Attribute.Name = Name_Library_Major_Minor_Id_Supported then declare pragma Unsuppress (All_Checks); begin Project.Config.Lib_Maj_Min_Id_Supported := Boolean'Value (Get_Name_String (Attribute.Value.Value)); exception when Constraint_Error => Error_Msg (Data.Flags, "invalid value """ & Get_Name_String_Safe (Attribute.Value.Value) & """ for Library_Major_Minor_Id_Supported", Attribute.Value.Location, Project); end; elsif Attribute.Name = Name_Library_Auto_Init_Supported then declare pragma Unsuppress (All_Checks); begin Project.Config.Auto_Init_Supported := Boolean'Value (Get_Name_String (Attribute.Value.Value)); exception when Constraint_Error => Error_Msg (Data.Flags, "invalid value """ & Get_Name_String_Safe (Attribute.Value.Value) & """ for Library_Auto_Init_Supported", Attribute.Value.Location, Project); end; elsif Attribute.Name = Name_Shared_Library_Minimum_Switches then List := Attribute.Value.Values; if List /= Nil_String then Put (Into_List => Project.Config.Shared_Lib_Min_Options, From_List => List, In_Tree => Data.Tree); end if; elsif Attribute.Name = Name_Library_Version_Switches then List := Attribute.Value.Values; if List /= Nil_String then Put (Into_List => Project.Config.Lib_Version_Options, From_List => List, In_Tree => Data.Tree); end if; elsif Attribute.Name = Name_Warning_Message then if Project.Extended_By = No_Project then declare Message : constant Name_Id := Attribute.Value.Value; begin if Message not in No_Name | The_Empty_String then Error_Msg (Data.Flags, "?" & Mask_Control_Characters (Get_Name_String (Message)), Project.Location, Project); end if; end; end if; end if; end if; Attribute_Id := Attribute.Next; end loop; end Process_Project_Level_Simple_Attributes; -------------------------------------------- -- Process_Project_Level_Array_Attributes -- -------------------------------------------- procedure Process_Project_Level_Array_Attributes is Current_Array_Id : Array_Id; Current_Array : Array_Data; Element_Id : Array_Element_Id; Element : Array_Element; List : String_List_Id; begin -- Process the associative array attributes at project level Current_Array_Id := Project.Decl.Arrays; while Current_Array_Id /= No_Array loop Current_Array := Shared.Arrays.Table (Current_Array_Id); Element_Id := Current_Array.Value; while Element_Id /= No_Array_Element loop Element := Shared.Array_Elements.Table (Element_Id); -- Get the name of the language Lang_Index := Get_Language_From_Name (Project, Get_Name_String (Element.Index)); if Lang_Index /= No_Language_Index then if Current_Array.Name = Name_Inherit_Source_Path then List := Element.Value.Values; if List /= Nil_String then Put (Into_List => Lang_Index.Config.Include_Compatible_Languages, From_List => List, In_Tree => Data.Tree, Lower_Case => True); end if; elsif Current_Array.Name = Name_Toolchain_Description then -- Attribute Toolchain_Description () Lang_Index.Config.Toolchain_Description := Element.Value.Value; elsif Current_Array.Name = Name_Toolchain_Version then -- Attribute Toolchain_Version () Lang_Index.Config.Toolchain_Version := Element.Value.Value; -- For Ada, set proper checksum computation mode, -- which has changed from version to version. if Lang_Index.Name = Name_Ada then declare Vers : constant String := Get_Name_String (Element.Value.Value); pragma Assert (Vers'First = 1); begin -- Version 6.3 or earlier if Vers'Length >= 8 and then Vers (1 .. 5) = GNAT_And_Space and then Vers (7) = '.' and then (Vers (6) < '6' or else (Vers (6) = '6' and then Vers (8) < '4')) then Checksum_GNAT_6_3 := True; -- Version 5.03 or earlier if Vers (6) < '5' or else (Vers (6) = '5' and then Vers (Vers'Last) < '4') then Checksum_GNAT_5_03 := True; -- Version 5.02 or earlier (no checksums) if Vers (6) /= '5' or else Vers (Vers'Last) < '3' then Checksum_Accumulate_Token_Checksum := False; end if; end if; end if; end; end if; elsif Current_Array.Name = Name_Required_Toolchain_Version then -- Attribute Required_Toolchain_Version () Lang_Index.Config.Required_Toolchain_Version := Element.Value.Value; elsif Current_Array.Name = Name_Runtime_Library_Dir then -- Attribute Runtime_Library_Dir () if Lang_Index.Config.Runtime_Library_Dirs = No_Name_List then Name_List_Table.Append (Shared.Name_Lists, New_Val => (Element.Value.Value, No_Name_List)); Lang_Index.Config.Runtime_Library_Dirs := Name_List_Table.Last (Shared.Name_Lists); end if; elsif Current_Array.Name = Name_Runtime_Library_Dirs then -- Attribute Runtime_Library_Dirs () declare Dirs : String_List_Id := Element.Value.Values; Elem : String_Element; begin Lang_Index.Config.Runtime_Library_Dirs := No_Name_List; Shared.Ada_Runtime_Dir := No_Name; while Dirs /= Nil_String loop Elem := Shared.String_Elements.Table (Dirs); Name_List_Table.Append (Shared.Name_Lists, New_Val => (Elem.Value, Lang_Index.Config.Runtime_Library_Dirs)); Lang_Index.Config.Runtime_Library_Dirs := Name_List_Table.Last (Shared.Name_Lists); Dirs := Elem.Next; end loop; end; elsif Current_Array.Name = Name_Runtime_Source_Dir then -- Attribute Runtime_Source_Dir () if Lang_Index.Config.Runtime_Source_Dirs = No_Name_List then Name_List_Table.Append (Shared.Name_Lists, New_Val => (Element.Value.Value, No_Name_List)); Lang_Index.Config.Runtime_Source_Dirs := Name_List_Table.Last (Shared.Name_Lists); end if; elsif Current_Array.Name = Name_Runtime_Source_Dirs then -- Attribute Runtime_Source_Dirs () declare Dirs : String_List_Id := Element.Value.Values; Elem : String_Element; begin Lang_Index.Config.Runtime_Source_Dirs := No_Name_List; while Dirs /= Nil_String loop Elem := Shared.String_Elements.Table (Dirs); Name_List_Table.Append (Shared.Name_Lists, New_Val => (Elem.Value, Lang_Index.Config.Runtime_Source_Dirs)); Lang_Index.Config.Runtime_Source_Dirs := Name_List_Table.Last (Shared.Name_Lists); Dirs := Elem.Next; end loop; end; elsif Current_Array.Name = Name_Runtime_Dir then declare Runtime_Dir : constant String := Get_Name_String (Element.Value.Value); procedure Get_Directories (Runtime_Dirs : in out Name_List_Index; Path_File_Name : String; Directory : String); -- Get the runtime source directories or the runtime -- library directories. --------------------- -- Get_Directories -- --------------------- procedure Get_Directories (Runtime_Dirs : in out Name_List_Index; Path_File_Name : String; Directory : String) is Path : constant String := Runtime_Dir & Directory_Separator & Path_File_Name; File : Ada.Text_IO.File_Type; Line : String (1 .. 1_000); Last : Natural; Last_Name : Name_List_Index; Local_Runtime_Dirs : Name_List_Index := No_Name_List; begin Runtime_Dirs := No_Name_List; if Is_Regular_File (Path) then Open (File, In_File, Path); while not End_Of_File (File) loop Get_Line (File, Line, Last); if Last > 0 then if Is_Absolute_Path (Line (1 .. Last)) then Name_Len := 0; else Set_Name_Buffer (Runtime_Dir & Directory_Separator); end if; Add_Str_To_Name_Buffer (Line (1 .. Last)); Name_List_Table.Append (Shared.Name_Lists, New_Val => (Name_Find, No_Name_List)); Last_Name := Name_List_Table.Last (Shared.Name_Lists); if Local_Runtime_Dirs = No_Name_List then Runtime_Dirs := Last_Name; else Shared.Name_Lists.Table (Local_Runtime_Dirs).Next := Last_Name; end if; Local_Runtime_Dirs := Last_Name; end if; end loop; Close (File); else Name_List_Table.Append (Shared.Name_Lists, New_Val => (Get_Name_Id (Runtime_Dir & Directory_Separator & Directory), No_Name_List)); Runtime_Dirs := Name_List_Table.Last (Shared.Name_Lists); end if; end Get_Directories; begin Lang_Index.Config.Runtime_Dir := Element.Value.Value; if Lang_Index.Name = Name_Ada then if Shared.Ada_Runtime_Dir = Element.Value.Value then Lang_Index.Config.Runtime_Library_Dirs := Shared.Ada_Runtime_Library_Dirs; Lang_Index.Config.Runtime_Source_Dirs := Shared.Ada_Runtime_Source_Dirs; Lang_Index.Config.Runtime_Library_Version := Shared.Ada_Runtime_Library_Version; else Get_Directories (Runtime_Dirs => Lang_Index.Config.Runtime_Source_Dirs, Path_File_Name => "ada_source_path", Directory => "adainclude"); Get_Directories (Runtime_Dirs => Lang_Index.Config.Runtime_Library_Dirs, Path_File_Name => "ada_object_path", Directory => "adalib"); declare Lib_Dirs : Name_List_Index := Lang_Index.Config.Runtime_Library_Dirs; Library_Dir : Name_Node; Version : Name_Id := No_Name; begin while Lib_Dirs /= No_Name_List loop Library_Dir := Shared.Name_Lists.Table (Lib_Dirs); if Is_Regular_File (Get_Name_String (Library_Dir.Name) & "/system.ali") then declare File : File_Type; Line : String (1 .. 1_000); Last : Natural; Start : Natural; begin Open (File, In_File, Get_Name_String (Library_Dir.Name) & "/system.ali"); Get_Line (File, Line, Last); Close (File); Start := Index (Line (1 .. Last), " v"); if Start /= 0 then Set_Name_Buffer (GNAT_And_Space); Add_Str_To_Name_Buffer (Line (Start + 2 .. Last - 1)); Version := Name_Find; end if; exit; end; end if; Lib_Dirs := Library_Dir.Next; end loop; if Version /= No_Name then Lang_Index.Config. Runtime_Library_Version := Version; else Lang_Index.Config. Runtime_Library_Version := Lang_Index.Config.Toolchain_Version; end if; Shared.Ada_Runtime_Dir := Element.Value.Value; Shared.Ada_Runtime_Library_Dirs := Lang_Index.Config.Runtime_Library_Dirs; Shared.Ada_Runtime_Source_Dirs := Lang_Index.Config.Runtime_Source_Dirs; Shared.Ada_Runtime_Library_Version := Lang_Index.Config.Runtime_Library_Version; end; end if; end if; end; elsif Current_Array.Name = Name_Runtime_Library_Version then -- Attribute Runtime_Library_Version () Lang_Index.Config.Runtime_Library_Version := Element.Value.Value; elsif Current_Array.Name = Name_Object_Generated then declare pragma Unsuppress (All_Checks); Value : Boolean; begin Value := Boolean'Value (Get_Name_String (Element.Value.Value)); Lang_Index.Config.Object_Generated := Value; -- If no object is generated, no object may be -- linked. if not Value then Lang_Index.Config.Objects_Linked := False; end if; exception when Constraint_Error => Error_Msg (Data.Flags, "invalid value """ & Get_Name_String_Safe (Element.Value.Value) & """ for Object_Generated", Element.Value.Location, Project); end; elsif Current_Array.Name = Name_Objects_Linked then declare pragma Unsuppress (All_Checks); Value : Boolean; begin Value := Boolean'Value (Get_Name_String (Element.Value.Value)); -- No change if Object_Generated is False, as this -- forces Objects_Linked to be False too. if Lang_Index.Config.Object_Generated then Lang_Index.Config.Objects_Linked := Value; end if; exception when Constraint_Error => Error_Msg (Data.Flags, "invalid value """ & Get_Name_String_Safe (Element.Value.Value) & """ for Objects_Linked", Element.Value.Location, Project); end; elsif Current_Array.Name = Name_Only_Dirs_With_Sources then declare pragma Unsuppress (All_Checks); Value : Boolean; begin Value := Boolean'Value (Get_Name_String (Element.Value.Value)); -- No change if Object_Generated is False, as this -- forces Objects_Linked to be False too. Lang_Index.Config.Only_Dirs_With_Sources := Value; exception when Constraint_Error => Error_Msg (Data.Flags, "invalid value """ & Get_Name_String_Safe (Element.Value.Value) & """ for Only_Dirs_With_Sources", Element.Value.Location, Project); end; end if; end if; Element_Id := Element.Next; end loop; Current_Array_Id := Current_Array.Next; end loop; end Process_Project_Level_Array_Attributes; -- Start of processing for Check_Configuration begin Process_Project_Level_Simple_Attributes; Process_Project_Level_Array_Attributes; Process_Packages; -- For unit based languages, set Casing, Dot_Replacement and -- Separate_Suffix in Naming_Data. Lang_Index := Project.Languages; while Lang_Index /= No_Language_Index loop if Lang_Index.Config.Required_Toolchain_Version /= No_Name and then Lang_Index.Config.Toolchain_Version /= Lang_Index.Config.Required_Toolchain_Version then declare function No_GNAT_Prefix (Id : Name_Id) return String; -- Returns version string without "GNAT " prefix for Ada -- language if prefix exists. Returns version string as is for -- non Ada languages. -------------------- -- No_GNAT_Prefix -- -------------------- function No_GNAT_Prefix (Id : Name_Id) return String is Result : constant String := Get_Name_String_Or_Null (Id); begin if Lang_Index.Name = Name_Ada and then Starts_With (Result, GNAT_And_Space) then return Result (Result'First + GNAT_And_Space'Length .. Result'Last); else return Result; end if; end No_GNAT_Prefix; TVC : constant String := No_GNAT_Prefix (Lang_Index.Config.Toolchain_Version); TVR : constant String := No_GNAT_Prefix (Lang_Index.Config.Required_Toolchain_Version); begin if TVC /= TVR then Error_Msg (Data.Flags, "Toolchain version " & (if TVC = "" then "" else '"' & TVC & """ ") & "for language " & Get_Name_String_Safe (Lang_Index.Name) & " differs from the required one """ & TVR & '"', No_Location, Project); end if; end; end if; if Lang_Index.Config.Kind = Unit_Based then Lang_Index.Config.Naming_Data.Casing := Casing; Lang_Index.Config.Naming_Data.Dot_Replacement := Dot_Replacement; if Separate_Suffix /= No_File then Lang_Index.Config.Naming_Data.Separate_Suffix := Separate_Suffix; end if; exit; end if; Lang_Index := Lang_Index.Next; end loop; -- Give empty names to various prefixes/suffixes, if they have not -- been specified in the configuration. if Project.Config.Archive_Suffix = No_File then Project.Config.Archive_Suffix := Empty_File; end if; if Project.Config.Shared_Lib_Prefix = No_File then Project.Config.Shared_Lib_Prefix := Empty_File; end if; if Project.Config.Shared_Lib_Suffix = No_File then Project.Config.Shared_Lib_Suffix := Empty_File; end if; Lang_Index := Project.Languages; while Lang_Index /= No_Language_Index loop if Is_Allowed_Language (Lang_Index.Name) then -- For all languages, Compiler_Driver should be specified. But -- there is no warning if it is not, as there may not be any -- source of the language. If there is such a source, then an -- error will be reported when trying to compile this source. if Lang_Index.Config.Compiler_Driver /= No_File or else Project.Externally_Built or else not Is_Allowed_Language (Lang_Index.Name) then if Lang_Index.Config.Kind = Unit_Based then -- For unit based languages, Dot_Replacement, Spec_Suffix -- and Body_Suffix need to be specified. if Lang_Index.Config.Naming_Data.Dot_Replacement = No_File then Error_Msg (Data.Flags, "Dot_Replacement not specified for " & Get_Name_String_Safe (Lang_Index.Name), No_Location, Project); end if; if Lang_Index.Config.Naming_Data.Spec_Suffix = No_File then Error_Msg (Data.Flags, "\Spec_Suffix not specified for " & Get_Name_String_Safe (Lang_Index.Name), No_Location, Project); end if; if Lang_Index.Config.Naming_Data.Body_Suffix = No_File then Error_Msg (Data.Flags, "\Body_Suffix not specified for " & Get_Name_String_Safe (Lang_Index.Name), No_Location, Project); end if; else -- For file based languages, either Spec_Suffix or -- Body_Suffix need to be specified. if Data.Flags.Require_Sources_Other_Lang and then Lang_Index.Config.Naming_Data.Spec_Suffix = No_File and then Lang_Index.Config.Naming_Data.Body_Suffix = No_File then Error_Msg_Name_1 := Lang_Index.Display_Name; Error_Msg (Data.Flags, "\no suffixes specified for %%", No_Location, Project); end if; end if; end if; end if; Lang_Index := Lang_Index.Next; end loop; end Check_Configuration; ------------------------------- -- Check_If_Externally_Built -- ------------------------------- procedure Check_If_Externally_Built (Project : Project_Id; Data : in out Tree_Processing_Data) is Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; Externally_Built : constant Variable_Value := Util.Value_Of (Name_Externally_Built, Project.Decl.Attributes, Shared); begin if not Externally_Built.Default then declare Lower_Value : constant String := To_Lower (Get_Name_String (Externally_Built.Value)); begin if Lower_Value = "true" then Project.Externally_Built := True; elsif Lower_Value /= "false" then Error_Msg (Data.Flags, "Externally_Built may only be true or false", Externally_Built.Location, Project); end if; end; end if; -- A virtual project extending an externally built project is itself -- externally built. if Project.Virtual and then Project.Extends /= No_Project then Project.Externally_Built := Project.Extends.Externally_Built; end if; if Project.Externally_Built then Debug_Output ("project is externally built"); else Debug_Output ("project is not externally built"); end if; end Check_If_Externally_Built; ---------------------- -- Check_Interfaces -- ---------------------- procedure Check_Interfaces (Project : Project_Id; Data : in out Tree_Processing_Data) is Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; Interfaces : constant GPR.Variable_Value := GPR.Util.Value_Of (Snames.Name_Interfaces, Project.Decl.Attributes, Shared); Library_Interface : constant GPR.Variable_Value := GPR.Util.Value_Of (Snames.Name_Library_Interface, Project.Decl.Attributes, Shared); List : String_List_Id; Element : String_Element; Name : File_Name_Type; Iter : Source_Iterator; Source : Source_Id; Project_2 : Project_Id; Other : Source_Id; Unit_Found : Boolean; Interface_ALIs : String_List_Id := Nil_String; Other_Interfaces : String_List_Id := Nil_String; procedure Init_Interfaces; -- Set In_Interfaces to False for all sources. It will be set to True -- later for the sources in the [Library_]Interface list. -- Set In_Interfaces to True for sources from --src-subdirs directory. procedure Append_Interface_ALIs; procedure Append_Interfaces (List : in out String_List_Id; Value, Display_Value : File_Name_Type); ----------------------- -- Append_Interfaces -- ----------------------- procedure Append_Interfaces (List : in out String_List_Id; Value, Display_Value : File_Name_Type) is begin String_Element_Table.Increment_Last (Shared.String_Elements); Shared.String_Elements.Table (String_Element_Table.Last (Shared.String_Elements)) := (Value => Name_Id (Value), Index => 0, Display_Value => Name_Id (Display_Value), Location => No_Location, Next => List); List := String_Element_Table.Last (Shared.String_Elements); end Append_Interfaces; --------------------------- -- Append_Interface_ALIs -- --------------------------- procedure Append_Interface_ALIs is Src : Source_Id; begin if Source.Kind = Spec then Src := Other_Part (Source); end if; if Src = No_Source then Src := Source; end if; Append_Interfaces (Interface_ALIs, Src.Dep_Name, Src.Dep_Name); end Append_Interface_ALIs; --------------------- -- Init_Interfaces -- --------------------- procedure Init_Interfaces is begin Project_2 := Project; while Project_2 /= No_Project loop Iter := For_Each_Source (Data.Tree, Project_2); loop Source := GPR.Element (Iter); exit when Source = No_Source; if Source.In_Src_Subdir then Append_Interface_ALIs; else Source.In_Interfaces := False; end if; Next (Iter); end loop; Project_2 := Project_2.Extends; end loop; end Init_Interfaces; begin if not Interfaces.Default then Init_Interfaces; List := Interfaces.Values; while List /= Nil_String loop Element := Shared.String_Elements.Table (List); Name := Canonical_Case_File_Name (Element.Value); Project_2 := Project; Big_Loop : while Project_2 /= No_Project loop if Project.Qualifier = Aggregate_Library then -- For an aggregate library we want to consider sources of -- all aggregated projects. Iter := For_Each_Source (Data.Tree); else Iter := For_Each_Source (Data.Tree, Project_2); end if; loop Source := GPR.Element (Iter); exit when Source = No_Source; if Source.File = Name then if not Source.Locally_Removed then Source.In_Interfaces := True; Source.Declared_In_Interfaces := True; Other := Other_Part (Source); if Other /= No_Source then Other.In_Interfaces := True; Other.Declared_In_Interfaces := True; end if; -- Unit based case if Source.Language.Config.Kind = Unit_Based then Append_Interface_ALIs; -- File based case else Append_Interfaces (Other_Interfaces, Source.File, Source.Display_File); end if; Debug_Output ("interface: ", Name_Id (Source.Path.Name)); end if; exit Big_Loop; end if; Next (Iter); end loop; Project_2 := Project_2.Extends; end loop Big_Loop; if Source = No_Source and then not Languages_Are_Restricted then Error_Msg_File_1 := File_Name_Type (Element.Value); Error_Msg_Name_1 := Project.Name; Error_Msg (Data.Flags, "{ cannot be an interface of project %% " & "as it is not one of its sources", Element.Location, Project); end if; List := Element.Next; end loop; Project.Interfaces_Defined := True; Project.Lib_Interface_ALIs := Interface_ALIs; Project.Other_Interfaces := Other_Interfaces; elsif Project.Library and then not Library_Interface.Default then Init_Interfaces; List := Library_Interface.Values; while List /= Nil_String loop Element := Shared.String_Elements.Table (List); Name := File_Name_Type (Get_Lower_Name_Id (Get_Name_String (Element.Value))); Unit_Found := False; Project_2 := Project; Big_Loop_2 : while Project_2 /= No_Project loop if Project.Qualifier = Aggregate_Library then -- For an aggregate library we want to consider sources of -- all aggregated projects. Iter := For_Each_Source (Data.Tree); else Iter := For_Each_Source (Data.Tree, Project_2); end if; loop Source := GPR.Element (Iter); exit when Source = No_Source; if Source.Unit /= No_Unit_Index and then Source.Unit.Name = Name_Id (Name) then if not Source.Locally_Removed then Source.In_Interfaces := True; Source.Declared_In_Interfaces := True; Project.Interfaces_Defined := True; Other := Other_Part (Source); if Other /= No_Source then Other.In_Interfaces := True; Other.Declared_In_Interfaces := True; end if; Debug_Output ("interface: ", Name_Id (Source.Path.Name)); Append_Interface_ALIs; end if; Unit_Found := True; exit Big_Loop_2; end if; Next (Iter); end loop; Project_2 := Project_2.Extends; end loop Big_Loop_2; if not Unit_Found then Error_Msg_Name_1 := Name_Id (Name); Error_Msg (Data.Flags, "%% is not a unit of this project", Element.Location, Project); end if; List := Element.Next; end loop; Project.Lib_Interface_ALIs := Interface_ALIs; elsif Project.Extends /= No_Project and then Project.Extends.Interfaces_Defined then Project.Interfaces_Defined := True; Iter := For_Each_Source (Data.Tree, Project); loop Source := GPR.Element (Iter); exit when Source = No_Source; if not Source.Declared_In_Interfaces then Source.In_Interfaces := False; end if; Next (Iter); end loop; Project.Lib_Interface_ALIs := Project.Extends.Lib_Interface_ALIs; end if; end Check_Interfaces; ------------------------------ -- Check_Library_Attributes -- ------------------------------ -- This procedure is awfully long (over 700 lines) should be broken up??? procedure Check_Library_Attributes (Project : Project_Id; No_Sources : Boolean; Data : in out Tree_Processing_Data) is Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; Attributes : constant Variable_Id := Project.Decl.Attributes; Lib_Dir : constant Variable_Value := GPR.Util.Value_Of (Snames.Name_Library_Dir, Attributes, Shared); Lib_Name : constant GPR.Variable_Value := GPR.Util.Value_Of (Snames.Name_Library_Name, Attributes, Shared); Lib_Standalone : constant GPR.Variable_Value := GPR.Util.Value_Of (Snames.Name_Library_Standalone, Attributes, Shared); Lib_Version : constant GPR.Variable_Value := GPR.Util.Value_Of (Snames.Name_Library_Version, Attributes, Shared); Lib_ALI_Dir : constant GPR.Variable_Value := GPR.Util.Value_Of (Snames.Name_Library_Ali_Dir, Attributes, Shared); Lib_GCC : constant GPR.Variable_Value := GPR.Util.Value_Of (Snames.Name_Library_GCC, Attributes, Shared); The_Lib_Kind : constant GPR.Variable_Value := GPR.Util.Value_Of (Snames.Name_Library_Kind, Attributes, Shared); Imported_Project_List : Project_List; Continuation : String_Access := No_Continuation_String'Access; Support_For_Libraries : Library_Support; Library_Directory_Present : Boolean; procedure Check_Library (Proj : Project_Id; Extends : Boolean); -- Check if an imported or extended project if also a library project procedure Check_Aggregate_Library_Dirs; -- Check that the library directory and the library ALI directory of an -- aggregate library project are not the same as the object directory or -- the library directory of any of its aggregated projects. ---------------------------------- -- Check_Aggregate_Library_Dirs -- ---------------------------------- procedure Check_Aggregate_Library_Dirs is procedure Process_Aggregate (Proj : Project_Id); -- Recursive procedure to check the aggregated projects, as they may -- also be aggregated library projects. ----------------------- -- Process_Aggregate -- ----------------------- procedure Process_Aggregate (Proj : Project_Id) is Agg : Aggregated_Project_List; begin Agg := Proj.Aggregated_Projects; while Agg /= null loop Error_Msg_Name_1 := Agg.Project.Name; if Agg.Project.Qualifier /= Aggregate_Library and then Project.Library_ALI_Dir.Name = Agg.Project.Object_Directory.Name then Error_Msg (Data.Flags, "aggregate library 'A'L'I directory cannot be shared with" & " object directory of aggregated project %%", The_Lib_Kind.Location, Project); elsif Project.Library_ALI_Dir.Name = Agg.Project.Library_Dir.Name then Error_Msg (Data.Flags, "aggregate library 'A'L'I directory cannot be shared with" & " library directory of aggregated project %%", The_Lib_Kind.Location, Project); elsif Agg.Project.Qualifier /= Aggregate_Library and then Project.Library_Dir.Name = Agg.Project.Object_Directory.Name then Error_Msg (Data.Flags, "aggregate library directory cannot be shared with" & " object directory of aggregated project %%", The_Lib_Kind.Location, Project); elsif Project.Library_Dir.Name = Agg.Project.Library_Dir.Name then Error_Msg (Data.Flags, "aggregate library directory cannot be shared with" & " library directory of aggregated project %%", The_Lib_Kind.Location, Project); end if; if Agg.Project.Qualifier = Aggregate_Library then Process_Aggregate (Agg.Project); end if; Agg := Agg.Next; end loop; end Process_Aggregate; -- Start of processing for Check_Aggregate_Library_Dirs begin if Project.Qualifier = Aggregate_Library then Process_Aggregate (Project); end if; end Check_Aggregate_Library_Dirs; ------------------- -- Check_Library -- ------------------- procedure Check_Library (Proj : Project_Id; Extends : Boolean) is Src_Id : Source_Id; Iter : Source_Iterator; begin if Proj /= No_Project then if not Proj.Library then -- The only not library projects that are OK are those that -- have no sources. However, header files from non-Ada -- languages are OK, as there is nothing to compile. Iter := For_Each_Source (Data.Tree, Proj); loop Src_Id := GPR.Element (Iter); exit when Src_Id = No_Source or else Src_Id.Language.Config.Kind /= File_Based or else Src_Id.Kind /= Spec; Next (Iter); end loop; if Src_Id /= No_Source then Error_Msg_Name_1 := Project.Name; Error_Msg_Name_2 := Proj.Name; if Extends then if Project.Library_Kind /= Static then Error_Msg (Data.Flags, Continuation.all & "shared library project %% cannot extend project" & " %% that is not a library project", Project.Location, Project); Continuation := Continuation_String'Access; end if; elsif not Unchecked_Shared_Lib_Imports and then Project.Library_Kind /= Static then Error_Msg (Data.Flags, Continuation.all & "shared library project %% cannot import project %%" & " that is not a shared library project", Project.Location, Project); Continuation := Continuation_String'Access; end if; end if; elsif not Extends and then Project.Library_Kind /= Static and then not Lib_Standalone.Default and then To_Lower (Get_Name_String (Lib_Standalone.Value)) = "encapsulated" and then Proj.Library_Kind in Relocatable | Dynamic then -- An encapsulated library must depend only on static libraries Error_Msg_Name_1 := Project.Name; Error_Msg_Name_2 := Proj.Name; Error_Msg (Data.Flags, Continuation.all & "encapsulated library project %% cannot import shared " & "library project %%", Project.Location, Project); Continuation := Continuation_String'Access; elsif Project.Library_Kind /= Static and then Proj.Library_Kind = Static and then (Lib_Standalone.Default or else To_Lower (Get_Name_String (Lib_Standalone.Value)) /= "encapsulated") then Error_Msg_Name_1 := Project.Name; Error_Msg_Name_2 := Proj.Name; if Extends then Error_Msg (Data.Flags, Continuation.all & "shared library project %% cannot extend static" & " library project %%", Project.Location, Project); Continuation := Continuation_String'Access; elsif not Unchecked_Shared_Lib_Imports then Error_Msg (Data.Flags, Continuation.all & "shared library project %% cannot import static" & " library project %%", Project.Location, Project); Continuation := Continuation_String'Access; end if; end if; end if; end Check_Library; Dir_Exists : Boolean; -- Start of processing for Check_Library_Attributes begin Library_Directory_Present := Lib_Dir.Value not in No_Name | Empty_String; -- Special case of extending project if Project.Extends /= No_Project then -- If the project extended is a library project, we inherit the -- library name, if it is not redefined; we check that the library -- directory is specified. if Project.Extends.Library then if Project.Qualifier = Standard then Error_Msg (Data.Flags, "a standard project cannot extend a library project", Project.Location, Project); else if Lib_Name.Default then Project.Library_Name := Project.Extends.Library_Name; end if; if Lib_Dir.Default then if not Project.Virtual then Error_Msg (Data.Flags, "a project extending a library project must specify an" & " attribute Library_Dir", Project.Location, Project); else -- For a virtual project extending a library project, -- inherit library directory and library kind. Project.Library_Dir := Project.Extends.Library_Dir; Library_Directory_Present := True; Project.Library_Kind := Project.Extends.Library_Kind; end if; end if; end if; end if; end if; pragma Assert (Lib_Name.Kind = Single); if Lib_Name.Value = Empty_String then if Current_Verbosity = High and then Project.Library_Name = No_Name then Debug_Indent; Write_Line ("no library name"); end if; else -- There is no restriction on the syntax of library names Project.Library_Name := Lib_Name.Value; end if; if Project.Library_Name /= No_Name then if Current_Verbosity = High then Write_Attr ("Library name: ", Get_Name_String (Project.Library_Name)); end if; pragma Assert (Lib_Dir.Kind = Single); if not Library_Directory_Present then Debug_Output ("no library directory"); else -- Find path name (unless inherited), check that it is a directory if Project.Library_Dir = No_Path_Information then Locate_Directory (Project, File_Name_Type (Lib_Dir.Value), Path => Project.Library_Dir, Dir_Exists => Dir_Exists, Data => Data, Create => "library", Must_Exist => False, Location => Lib_Dir.Location, Externally_Built => Project.Externally_Built); else Dir_Exists := Is_Directory (Get_Name_String (Project.Library_Dir.Display_Name)); end if; if not Dir_Exists then if Directories_Must_Exist_In_Projects and then Project.Qualifier /= Abstract_Project then -- Get the absolute name of the library directory that does -- not exist, to report an error. Error_Msg_File_1 := File_Name_Type (Project.Library_Dir.Display_Name); Error_Or_Warning (Data.Flags, Data.Flags.Require_Obj_Dirs, "library directory { does not exist", Lib_Dir.Location, Project); end if; -- Checks for object/source directories elsif not Project.Externally_Built -- An aggregate library does not have sources or objects, so -- these tests are not required in this case. and then Project.Qualifier /= Aggregate_Library and then not No_Sources then -- Library directory cannot be the same as Object directory if Project.Library_Dir.Name = Project.Object_Directory.Name then Error_Msg (Data.Flags, "library directory cannot be the same as object" & " directory", Lib_Dir.Location, Project); Project.Library_Dir := No_Path_Information; else declare OK : Boolean := True; Dirs_Id : String_List_Id; Dir_Elem : String_Element; Pid : Project_List; begin -- The library directory cannot be the same as a source -- directory of the current project. Dirs_Id := Project.Source_Dirs; while Dirs_Id /= Nil_String loop Dir_Elem := Shared.String_Elements.Table (Dirs_Id); Dirs_Id := Dir_Elem.Next; if Project.Library_Dir.Name = Path_Name_Type (Dir_Elem.Value) then Error_Msg_File_1 := File_Name_Type (Dir_Elem.Value); Error_Msg (Data.Flags, "library directory cannot be the same as source" & " directory {", Lib_Dir.Location, Project); OK := False; exit; end if; end loop; if OK then -- The library directory cannot be the same as a -- source directory of another project either. Pid := Data.Tree.Projects; Project_Loop : loop exit Project_Loop when Pid = null; if Pid.Project /= Project then Dirs_Id := Pid.Project.Source_Dirs; Dir_Loop : while Dirs_Id /= Nil_String loop Dir_Elem := Shared.String_Elements.Table (Dirs_Id); Dirs_Id := Dir_Elem.Next; if Project.Library_Dir.Name = Path_Name_Type (Dir_Elem.Value) then Error_Msg_File_1 := File_Name_Type (Dir_Elem.Value); Error_Msg_Name_1 := Pid.Project.Name; Error_Msg (Data.Flags, "library directory cannot be the same" & " as source directory { of project" & " %%", Lib_Dir.Location, Project); OK := False; exit Project_Loop; end if; end loop Dir_Loop; end if; Pid := Pid.Next; end loop Project_Loop; end if; if not OK then Project.Library_Dir := No_Path_Information; elsif Current_Verbosity = High then -- Display the Library directory in high verbosity Write_Attr ("Library directory", Get_Name_String (Project.Library_Dir.Display_Name)); end if; end; end if; end if; end if; end if; Project.Library := Project.Library_Dir /= No_Path_Information and then Project.Library_Name /= No_Name; if Project.Library and then No_Sources then Project.Library := False; Project.Library_Dir := No_Path_Information; Project.Library_Name := No_Name; Error_Msg (Data.Flags, "a project with no sources cannot be a library project", Project.Location, Project); return; elsif Project.Extends = No_Project then case Project.Qualifier is when Standard => if Project.Library then Error_Msg (Data.Flags, "a standard project cannot be a library project", Lib_Name.Location, Project); end if; when Library | Aggregate_Library => if not Project.Library then if Project.Library_Name = No_Name then Error_Msg (Data.Flags, "attribute Library_Name not declared", Project.Location, Project); if not Library_Directory_Present then Error_Msg (Data.Flags, "\attribute Library_Dir not declared", Project.Location, Project); end if; elsif Project.Library_Dir = No_Path_Information then Error_Msg (Data.Flags, "attribute Library_Dir not declared", Project.Location, Project); end if; end if; when others => null; end case; end if; if Project.Library then Support_For_Libraries := Project.Config.Lib_Support; if not Project.Externally_Built and then Support_For_Libraries = GPR.None then Error_Msg (Data.Flags, "?libraries are not supported on this platform", Lib_Name.Location, Project); Project.Library := False; else if Lib_ALI_Dir.Value = Empty_String then Debug_Output ("no library ALI directory specified"); Project.Library_ALI_Dir := Project.Library_Dir; else -- Find path name, check that it is a directory Locate_Directory (Project, File_Name_Type (Lib_ALI_Dir.Value), Path => Project.Library_ALI_Dir, Create => "library ALI", Dir_Exists => Dir_Exists, Data => Data, Must_Exist => False, Location => Lib_ALI_Dir.Location, Externally_Built => Project.Externally_Built); if not Dir_Exists and then Opt.Directories_Must_Exist_In_Projects then -- Get the absolute name of the library ALI directory that -- does not exist, to report an error. Error_Msg_File_1 := File_Name_Type (Project.Library_ALI_Dir.Display_Name); Error_Or_Warning (Data.Flags, Data.Flags.Require_Obj_Dirs, "library 'A'L'I directory { does not exist", Lib_ALI_Dir.Location, Project); end if; if not Project.Externally_Built and then Project.Library_ALI_Dir /= Project.Library_Dir then -- The library ALI directory cannot be the same as the -- Object directory. if Project.Library_ALI_Dir = Project.Object_Directory then Error_Msg (Data.Flags, "library 'A'L'I directory cannot be the same as object" & " directory", Lib_ALI_Dir.Location, Project); Project.Library_ALI_Dir := No_Path_Information; else declare OK : Boolean := True; Dirs_Id : String_List_Id; Dir_Elem : String_Element; Pid : Project_List; begin -- The library ALI directory cannot be the same as -- a source directory of the current project. Dirs_Id := Project.Source_Dirs; while Dirs_Id /= Nil_String loop Dir_Elem := Shared.String_Elements.Table (Dirs_Id); Dirs_Id := Dir_Elem.Next; if Project.Library_ALI_Dir.Name = Path_Name_Type (Dir_Elem.Value) then Error_Msg_File_1 := File_Name_Type (Dir_Elem.Value); Error_Msg (Data.Flags, "library 'A'L'I directory cannot be the same" & " as source directory {", Lib_ALI_Dir.Location, Project); OK := False; exit; end if; end loop; if OK then -- The library ALI directory cannot be the same as -- a source directory of another project either. Pid := Data.Tree.Projects; ALI_Project_Loop : loop exit ALI_Project_Loop when Pid = null; if Pid.Project /= Project then Dirs_Id := Pid.Project.Source_Dirs; ALI_Dir_Loop : while Dirs_Id /= Nil_String loop Dir_Elem := Shared.String_Elements.Table (Dirs_Id); Dirs_Id := Dir_Elem.Next; if Project.Library_ALI_Dir.Name = Path_Name_Type (Dir_Elem.Value) then Error_Msg_File_1 := File_Name_Type (Dir_Elem.Value); Error_Msg_Name_1 := Pid.Project.Name; Error_Msg (Data.Flags, "library 'A'L'I directory cannot be" & " the same as source directory {" & " of project %%", Lib_ALI_Dir.Location, Project); OK := False; exit ALI_Project_Loop; end if; end loop ALI_Dir_Loop; end if; Pid := Pid.Next; end loop ALI_Project_Loop; end if; if not OK then Project.Library_ALI_Dir := No_Path_Information; elsif Current_Verbosity = High then -- Display Library ALI directory in high verbosity Write_Attr ("Library ALI dir", Get_Name_String (Project.Library_ALI_Dir.Display_Name)); end if; end; end if; end if; end if; pragma Assert (Lib_Version.Kind = Single); if Lib_Version.Value = Empty_String or else not Project.Config.Symbolic_Link_Supported then Debug_Output ("no library version specified"); else Project.Lib_Internal_Name := Lib_Version.Value; end if; pragma Assert (The_Lib_Kind.Kind = Single); if The_Lib_Kind.Value = Empty_String then Debug_Output ("no library kind specified"); elsif The_Lib_Kind.Value = No_Name then Error_Msg (Data.Flags, "incorrect value specified for library kind", The_Lib_Kind.Location, Project); Project.Library := False; else Get_Name_String (The_Lib_Kind.Value); declare Kind_Name : constant String := To_Lower (Name_Buffer (1 .. Name_Len)); OK : Boolean := True; begin if Kind_Name = "static" then Project.Library_Kind := Static; elsif Kind_Name = "static-pic" then Project.Library_Kind := Static_Pic; elsif Kind_Name = "dynamic" then Project.Library_Kind := Dynamic; elsif Kind_Name = "relocatable" then Project.Library_Kind := Relocatable; else Error_Msg (Data.Flags, "illegal value for Library_Kind", The_Lib_Kind.Location, Project); OK := False; end if; if Current_Verbosity = High and then OK then Write_Attr ("Library kind", Kind_Name); end if; if Project.Library_Kind /= Static then if not Project.Externally_Built and then Support_For_Libraries = GPR.Static_Only then Error_Msg (Data.Flags, "only static libraries are supported on this" & " platform", The_Lib_Kind.Location, Project); Project.Library := False; else -- Check if (obsolescent) attribute Library_GCC or -- Linker'Driver is declared. if Lib_GCC.Value /= Empty_String then Error_Msg (Data.Flags, "?Library_'G'C'C is an obsolescent attribute, " & "use Linker''Driver instead", Lib_GCC.Location, Project); Project.Config.Shared_Lib_Driver := File_Name_Type (Lib_GCC.Value); else declare Linker : constant Package_Id := Value_Of (Name_Linker, Project.Decl.Packages, Shared); Driver : constant Variable_Value := Value_Of (Name => No_Name, Attribute_Or_Array_Name => Name_Driver, In_Package => Linker, Shared => Shared); begin if Driver /= Nil_Variable_Value and then Driver.Value /= Empty_String then Project.Config.Shared_Lib_Driver := File_Name_Type (Driver.Value); end if; end; end if; end if; end if; end; end if; if Project.Library and then Project.Qualifier /= Aggregate_Library then Debug_Output ("this is a library project file"); Check_Library (Project.Extends, Extends => True); Compute_All_Imported_Projects (Project, Data.Tree); Imported_Project_List := Project.All_Imported_Projects; while Imported_Project_List /= null loop Check_Library (Imported_Project_List.Project, Extends => False); Imported_Project_List := Imported_Project_List.Next; end loop; end if; end if; end if; -- Check if Linker'Switches or Linker'Default_Switches are declared. -- Warn if they are declared, as it is a common error to think that -- library are "linked" with Linker switches. if Project.Library then declare Linker_Package_Id : constant Package_Id := Util.Value_Of (Name_Linker, Project.Decl.Packages, Shared); Linker_Package : Package_Element; Switches : Array_Element_Id := No_Array_Element; begin if Linker_Package_Id /= No_Package then Linker_Package := Shared.Packages.Table (Linker_Package_Id); Switches := Value_Of (Name => Name_Switches, In_Arrays => Linker_Package.Decl.Arrays, Shared => Shared); if Switches = No_Array_Element then Switches := Value_Of (Name => Name_Default_Switches, In_Arrays => Linker_Package.Decl.Arrays, Shared => Shared); end if; if Switches /= No_Array_Element then Error_Msg (Data.Flags, "?\Linker switches not taken into account in library " & "projects", No_Location, Project); end if; end if; end; end if; if Project.Extends /= No_Project and then Project.Extends.Library then -- Remove the library name from Lib_Data_Table for J in 1 .. Lib_Data_Table.Last loop if Lib_Data_Table.Table (J).Proj = Project.Extends then Lib_Data_Table.Table (J) := Lib_Data_Table.Table (Lib_Data_Table.Last); Lib_Data_Table.Set_Last (Lib_Data_Table.Last - 1); exit; end if; end loop; end if; if Project.Library and then not Lib_Name.Default then -- Check if the same library name is used in an other library project for J in 1 .. Lib_Data_Table.Last loop if Lib_Data_Table.Table (J).Name = Project.Library_Name and then Lib_Data_Table.Table (J).Tree = Data.Tree then Error_Msg_Name_1 := Lib_Data_Table.Table (J).Proj.Display_Name; Error_Msg (Data.Flags, "Library name cannot be the same as in project %%", Lib_Name.Location, Project); Project.Library := False; end if; end loop; end if; -- Check that aggregated libraries do not share the aggregate -- Library_ALI_Dir. if Project.Qualifier = Aggregate_Library then Check_Aggregate_Library_Dirs; end if; if Project.Library and not Data.In_Aggregate_Lib then -- Record the library name Lib_Data_Table.Append ((Name => Project.Library_Name, Proj => Project, Tree => Data.Tree)); end if; end Check_Library_Attributes; -------------------------- -- Check_Package_Naming -- -------------------------- procedure Check_Package_Naming (Project : Project_Id; Data : in out Tree_Processing_Data) is Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; Naming_Id : constant Package_Id := Util.Value_Of (Name_Naming, Project.Decl.Packages, Shared); Naming : Package_Element; Ada_Body_Suffix_Loc : Source_Ptr := No_Location; procedure Check_Naming; -- Check the validity of the Naming package (suffixes valid, ...) procedure Check_Common (Dot_Replacement : in out File_Name_Type; Casing : in out Casing_Type; Casing_Defined : out Boolean; Separate_Suffix : in out File_Name_Type; Sep_Suffix_Loc : out Source_Ptr); -- Check attributes common procedure Process_Exceptions_File_Based (Lang_Id : Language_Ptr; Kind : Source_Kind); procedure Process_Exceptions_Unit_Based (Lang_Id : Language_Ptr; Kind : Source_Kind); -- Process the naming exceptions for the two types of languages procedure Initialize_Naming_Data; -- Initialize internal naming data for the various languages ------------------ -- Check_Common -- ------------------ procedure Check_Common (Dot_Replacement : in out File_Name_Type; Casing : in out Casing_Type; Casing_Defined : out Boolean; Separate_Suffix : in out File_Name_Type; Sep_Suffix_Loc : out Source_Ptr) is Dot_Repl : constant Variable_Value := Util.Value_Of (Name_Dot_Replacement, Naming.Decl.Attributes, Shared); Casing_String : constant Variable_Value := Util.Value_Of (Name_Casing, Naming.Decl.Attributes, Shared); Sep_Suffix : constant Variable_Value := Util.Value_Of (Name_Separate_Suffix, Naming.Decl.Attributes, Shared); Dot_Repl_Loc : Source_Ptr; begin Sep_Suffix_Loc := No_Location; if not Dot_Repl.Default and then Dot_Repl.Value /= No_Name then pragma Assert (Dot_Repl.Kind = Single, "Dot_Replacement is not a string"); if Dot_Repl.Value = Empty_String then Error_Msg (Data.Flags, "Dot_Replacement cannot be empty", Dot_Repl.Location, Project); end if; Dot_Replacement := Canonical_Case_File_Name (Dot_Repl.Value); Dot_Repl_Loc := Dot_Repl.Location; declare Repl : constant String := Get_Name_String (Dot_Replacement); Not_OK : Boolean; subtype Printable_ASCII is Character range '!' .. '~'; begin -- Dot_Replacement cannot -- - be empty -- - start or end with an alphanumeric -- - be a single '_' -- - start with an '_' followed by an alphanumeric -- - contain a '.' except if it is "." Not_OK := Repl'Length = 0 or else Is_Alphanumeric (Repl (Repl'First)) or else Is_Alphanumeric (Repl (Repl'Last)) or else (Repl (Repl'First) = '_' and then (Repl'Length = 1 or else Is_Alphanumeric (Repl (Repl'First + 1)))) or else (Repl'Length > 1 and then Index (Source => Repl, Pattern => ".") /= 0); -- Dot_Replacement cannot include any character that is not -- printable ASCII except space (' '). if not Not_OK then for J in Repl'Range loop if not (Repl (J) in Printable_ASCII) then Not_OK := True; exit; end if; end loop; end if; if Not_OK then Error_Msg (Data.Flags, '"' & Repl & """ is illegal for Dot_Replacement", Dot_Repl_Loc, Project); end if; end; end if; if Dot_Replacement /= No_File then Write_Attr ("Dot_Replacement", Get_Name_String (Dot_Replacement)); end if; Casing_Defined := False; if not Casing_String.Default and then Casing_String.Value /= No_Name then pragma Assert (Casing_String.Kind = Single, "Casing is not a string"); declare Casing_Image : constant String := Get_Name_String (Casing_String.Value); begin if Casing_Image'Length = 0 then Error_Msg (Data.Flags, "Casing cannot be an empty string", Casing_String.Location, Project); end if; Casing := Value (Casing_Image); Casing_Defined := True; exception when Constraint_Error => Name_Len := Casing_Image'Length; Name_Buffer (1 .. Name_Len) := Casing_Image; Error_Msg_Name_1 := Name_Find; Error_Msg (Data.Flags, "%% is not a correct Casing", Casing_String.Location, Project); end; end if; Write_Attr ("Casing", Image (Casing)); if not Sep_Suffix.Default then if Sep_Suffix.Value = Empty_String then Error_Msg (Data.Flags, "Separate_Suffix cannot be empty", Sep_Suffix.Location, Project); else Separate_Suffix := Canonical_Case_File_Name (Sep_Suffix.Value); Sep_Suffix_Loc := Sep_Suffix.Location; Check_Illegal_Suffix (Project, Separate_Suffix, Dot_Replacement, "Separate_Suffix", Sep_Suffix.Location, Data); end if; end if; if Separate_Suffix /= No_File then Write_Attr ("Separate_Suffix", Get_Name_String (Separate_Suffix)); end if; end Check_Common; ----------------------------------- -- Process_Exceptions_File_Based -- ----------------------------------- procedure Process_Exceptions_File_Based (Lang_Id : Language_Ptr; Kind : Source_Kind) is Lang : constant Name_Id := Lang_Id.Name; Exceptions : Array_Element_Id; Exception_List : Variable_Value; Element_Id : String_List_Id; Element : String_Element; File_Name : File_Name_Type; Source : Source_Id; begin case Kind is when Impl | Sep => Exceptions := Value_Of (Name_Implementation_Exceptions, In_Arrays => Naming.Decl.Arrays, Shared => Shared); when Spec => Exceptions := Value_Of (Name_Specification_Exceptions, In_Arrays => Naming.Decl.Arrays, Shared => Shared); end case; Exception_List := Value_Of (Index => Lang, In_Array => Exceptions, Shared => Shared); if Exception_List /= Nil_Variable_Value then Element_Id := Exception_List.Values; while Element_Id /= Nil_String loop Element := Shared.String_Elements.Table (Element_Id); File_Name := Canonical_Case_File_Name (Element.Value); Source := Source_Files_Htable.Get (Data.Tree.Source_Files_HT, File_Name); while Source /= No_Source and then Source.Project /= Project loop Source := Source.Next_With_File_Name; end loop; if Source = No_Source then Add_Source (Id => Source, Data => Data, Project => Project, Source_Dir_Rank => 0, Lang_Id => Lang_Id, Kind => Kind, File_Name => File_Name, Display_File => File_Name_Type (Element.Value), Naming_Exception => Yes, Location => Element.Location); else -- Check if the file name is already recorded for another -- language or another kind. if Source.Language /= Lang_Id then Error_Msg (Data.Flags, "the same file cannot be a source of two languages", Element.Location, Project); elsif Source.Kind /= Kind then Error_Msg (Data.Flags, "the same file cannot be a source and a template", Element.Location, Project); end if; -- If the file is already recorded for the same -- language and the same kind, it means that the file -- name appears several times in the *_Exceptions -- attribute; so there is nothing to do. end if; Element_Id := Element.Next; end loop; end if; end Process_Exceptions_File_Based; ----------------------------------- -- Process_Exceptions_Unit_Based -- ----------------------------------- procedure Process_Exceptions_Unit_Based (Lang_Id : Language_Ptr; Kind : Source_Kind) is Exceptions : Array_Element_Id; Element : Array_Element; Unit : Name_Id; Index : Int; File_Name : File_Name_Type; Source : Source_Id; Naming_Exception : Naming_Exception_Type; begin case Kind is when Impl | Sep => Exceptions := Value_Of (Name_Body, In_Arrays => Naming.Decl.Arrays, Shared => Shared); if Exceptions = No_Array_Element then Exceptions := Value_Of (Name_Implementation, In_Arrays => Naming.Decl.Arrays, Shared => Shared); end if; when Spec => Exceptions := Value_Of (Name_Spec, In_Arrays => Naming.Decl.Arrays, Shared => Shared); if Exceptions = No_Array_Element then Exceptions := Value_Of (Name_Specification, In_Arrays => Naming.Decl.Arrays, Shared => Shared); end if; end case; while Exceptions /= No_Array_Element loop Element := Shared.Array_Elements.Table (Exceptions); if Element.Restricted then Naming_Exception := Inherited; else Naming_Exception := Yes; end if; File_Name := Canonical_Case_File_Name (Element.Value.Value); Index := Element.Value.Index; -- Check if it is a valid unit name Check_Unit_Name (Get_Name_String (Element.Index), Unit); if Unit = No_Name then Error_Msg_Name_1 := Element.Index; Error_Msg (Data.Flags, "%% is not a valid unit name.", Element.Value.Location, Project); end if; if Unit /= No_Name then Add_Source (Id => Source, Data => Data, Project => Project, Source_Dir_Rank => 0, Lang_Id => Lang_Id, Kind => Kind, File_Name => File_Name, Display_File => File_Name_Type (Element.Value.Value), Unit => Unit, Index => Index, Location => Element.Value.Location, Naming_Exception => Naming_Exception); end if; Exceptions := Element.Next; end loop; end Process_Exceptions_Unit_Based; ------------------ -- Check_Naming -- ------------------ procedure Check_Naming is Dot_Replacement : File_Name_Type := File_Name_Type (First_Name_Id + Character'Pos ('-')); Separate_Suffix : File_Name_Type := No_File; Casing : Casing_Type := All_Lower_Case; Casing_Defined : Boolean; Lang_Id : Language_Ptr; Sep_Suffix_Loc : Source_Ptr; Suffix : Variable_Value; Lang : Name_Id; function Name_Id_Hash (Key : Name_Id) return Ada.Containers.Hash_Type; function Name_Id_Hash (Key : Name_Id) return Ada.Containers.Hash_Type is begin return Ada.Strings.Hash_Case_Insensitive (Get_Name_String (Key)); end Name_Id_Hash; function Name_Id_Equal_Case_Insensitive (Left, Right : Name_Id) return Boolean; function Name_Id_Equal_Case_Insensitive (Left, Right : Name_Id) return Boolean is begin return Ada.Strings.Equal_Case_Insensitive (Get_Name_String (Left), Get_Name_String (Right)); end Name_Id_Equal_Case_Insensitive; package Suffix_Lang_Maps is new Ada.Containers.Hashed_Maps (Key_Type => Name_Id, -- Suffix Element_Type => Name_Id, -- Language Hash => Name_Id_Hash, Equivalent_Keys => Name_Id_Equal_Case_Insensitive, "=" => Name_Id_Equal_Case_Insensitive); Suffix_Lang_Map : Suffix_Lang_Maps.Map; use type Suffix_Lang_Maps.Cursor; begin Check_Common (Dot_Replacement => Dot_Replacement, Casing => Casing, Casing_Defined => Casing_Defined, Separate_Suffix => Separate_Suffix, Sep_Suffix_Loc => Sep_Suffix_Loc); -- For all unit based languages, if any, set the specified value -- of Dot_Replacement, Casing and/or Separate_Suffix. Do not -- systematically overwrite, since the defaults come from the -- configuration file. if Dot_Replacement /= No_File or else Casing_Defined or else Separate_Suffix /= No_File then Lang_Id := Project.Languages; while Lang_Id /= No_Language_Index loop if Lang_Id.Config.Kind = Unit_Based then if Dot_Replacement /= No_File then Lang_Id.Config.Naming_Data.Dot_Replacement := Dot_Replacement; end if; if Casing_Defined then Lang_Id.Config.Naming_Data.Casing := Casing; end if; end if; Lang_Id := Lang_Id.Next; end loop; end if; -- Next, get the spec and body suffixes Lang_Id := Project.Languages; while Lang_Id /= No_Language_Index loop Lang := Lang_Id.Name; -- Spec_Suffix Suffix := Value_Of (Name => Lang, Attribute_Or_Array_Name => Name_Spec_Suffix, In_Package => Naming_Id, Shared => Shared); if Suffix = Nil_Variable_Value then Suffix := Value_Of (Name => Lang, Attribute_Or_Array_Name => Name_Specification_Suffix, In_Package => Naming_Id, Shared => Shared); end if; if Suffix /= Nil_Variable_Value and then Suffix.Value /= No_Name then -- Check if there is an ambiguity for the spec suffix -- i.e. it is already associated (as a spec or body suffix) -- with another language. declare Associated_Lang : constant Suffix_Lang_Maps.Cursor := Suffix_Lang_Map.Find (Key => Suffix.Value); begin if Associated_Lang /= Suffix_Lang_Maps.No_Element then Error_Msg (Data.Flags, "Spec_Suffix (""" & Get_Name_String_Safe (Suffix.Value) & """) for language " & Get_Name_String_Safe (Lang_Id.Name) & " is also defined for language " & Get_Name_String_Safe (Suffix_Lang_Map (Suffix.Value)) & '.', Suffix.Location, Project); else Suffix_Lang_Map.Include (Key => Suffix.Value, New_Item => Lang_Id.Name); end if; end; Lang_Id.Config.Naming_Data.Spec_Suffix := File_Name_Type (Suffix.Value); Check_Illegal_Suffix (Project, Lang_Id.Config.Naming_Data.Spec_Suffix, Lang_Id.Config.Naming_Data.Dot_Replacement, "Spec_Suffix", Suffix.Location, Data); Write_Attr ("Spec_Suffix", Get_Name_String (Lang_Id.Config.Naming_Data.Spec_Suffix)); end if; -- Body_Suffix Suffix := Value_Of (Name => Lang, Attribute_Or_Array_Name => Name_Body_Suffix, In_Package => Naming_Id, Shared => Shared); if Suffix = Nil_Variable_Value then Suffix := Value_Of (Name => Lang, Attribute_Or_Array_Name => Name_Implementation_Suffix, In_Package => Naming_Id, Shared => Shared); end if; if Suffix /= Nil_Variable_Value and then Suffix.Value /= No_Name then -- Check if there is an ambiguity for the body suffix -- i.e. it is already associated (as a spec or body suffix) -- with another language. declare Associated_Lang : constant Suffix_Lang_Maps.Cursor := Suffix_Lang_Map.Find (Key => Suffix.Value); begin if Associated_Lang /= Suffix_Lang_Maps.No_Element then Error_Msg (Data.Flags, "Body_Suffix (""" & Get_Name_String_Safe (Suffix.Value) & """) for language " & Get_Name_String_Safe (Lang_Id.Name) & " is also defined for language " & Get_Name_String_Safe (Suffix_Lang_Map (Suffix.Value)) & '.', Suffix.Location, Project); else Suffix_Lang_Map.Include (Key => Suffix.Value, New_Item => Lang_Id.Name); end if; end; Lang_Id.Config.Naming_Data.Body_Suffix := File_Name_Type (Suffix.Value); -- The default value of separate suffix should be the same as -- the body suffix, so we need to compute that first. if Separate_Suffix = No_File then Lang_Id.Config.Naming_Data.Separate_Suffix := Lang_Id.Config.Naming_Data.Body_Suffix; Write_Attr ("Sep_Suffix", Get_Name_String (Lang_Id.Config.Naming_Data.Separate_Suffix)); else Lang_Id.Config.Naming_Data.Separate_Suffix := Separate_Suffix; end if; Check_Illegal_Suffix (Project, Lang_Id.Config.Naming_Data.Body_Suffix, Lang_Id.Config.Naming_Data.Dot_Replacement, "Body_Suffix", Suffix.Location, Data); Write_Attr ("Body_Suffix", Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix)); elsif Separate_Suffix /= No_File then Lang_Id.Config.Naming_Data.Separate_Suffix := Separate_Suffix; end if; -- Spec_Suffix cannot be equal to Body_Suffix or Separate_Suffix, -- since that would cause a clear ambiguity. Note that we do allow -- a Spec_Suffix to have the same termination as one of these, -- which causes a potential ambiguity, but we resolve that by -- matching the longest possible suffix. if Lang_Id.Config.Naming_Data.Spec_Suffix /= No_File and then Lang_Id.Config.Naming_Data.Spec_Suffix = Lang_Id.Config.Naming_Data.Body_Suffix then Error_Msg (Data.Flags, "Body_Suffix (""" & Get_Name_String_Safe (Lang_Id.Config.Naming_Data.Body_Suffix) & """) cannot be the same as Spec_Suffix.", Ada_Body_Suffix_Loc, Project); end if; if Lang_Id.Config.Naming_Data.Body_Suffix /= Lang_Id.Config.Naming_Data.Separate_Suffix and then Lang_Id.Config.Naming_Data.Spec_Suffix = Lang_Id.Config.Naming_Data.Separate_Suffix then Error_Msg (Data.Flags, "Separate_Suffix (""" & Get_Name_String_Safe (Lang_Id.Config.Naming_Data.Separate_Suffix) & """) cannot be the same as Spec_Suffix.", Sep_Suffix_Loc, Project); end if; Lang_Id := Lang_Id.Next; end loop; -- Get the naming exceptions for all languages, but not for virtual -- projects. if not Project.Virtual and then Project.Source_Dirs /= Nil_String then for Kind in Spec_Or_Body loop Lang_Id := Project.Languages; while Lang_Id /= No_Language_Index loop case Lang_Id.Config.Kind is when File_Based => Process_Exceptions_File_Based (Lang_Id, Kind); when Unit_Based => Process_Exceptions_Unit_Based (Lang_Id, Kind); end case; Lang_Id := Lang_Id.Next; end loop; end loop; end if; end Check_Naming; ---------------------------- -- Initialize_Naming_Data -- ---------------------------- procedure Initialize_Naming_Data is Specs : Array_Element_Id := Util.Value_Of (Name_Spec_Suffix, Naming.Decl.Arrays, Shared); Impls : Array_Element_Id := Util.Value_Of (Name_Body_Suffix, Naming.Decl.Arrays, Shared); Lang : Language_Ptr; Lang_Name : Name_Id; Value : Variable_Value; Extended : Project_Id; begin -- At this stage, the project already contains the default extensions -- for the various languages. We now merge those suffixes read in the -- user project, and they override the default. while Specs /= No_Array_Element loop Lang_Name := Shared.Array_Elements.Table (Specs).Index; Lang := Get_Language_From_Name (Project, Name => Get_Name_String (Lang_Name)); -- An extending project inherits its parent projects' languages -- so if needed we should create entries for those languages if Lang = null then Extended := Project.Extends; while Extended /= null loop Lang := Get_Language_From_Name (Extended, Name => Get_Name_String (Lang_Name)); exit when Lang /= null; Extended := Extended.Extends; end loop; if Lang /= null then Lang := new Language_Data'(Lang.all); Lang.First_Source := null; Lang.Next := Project.Languages; Project.Languages := Lang; end if; end if; -- If language was not found in project or the projects it extends if Lang = null then Debug_Output ("ignoring spec naming data (lang. not in project): ", Lang_Name); else Value := Shared.Array_Elements.Table (Specs).Value; if Value.Kind = Single then Lang.Config.Naming_Data.Spec_Suffix := Canonical_Case_File_Name (Value.Value); end if; end if; Specs := Shared.Array_Elements.Table (Specs).Next; end loop; while Impls /= No_Array_Element loop Lang_Name := Shared.Array_Elements.Table (Impls).Index; Lang := Get_Language_From_Name (Project, Name => Get_Name_String (Lang_Name)); if Lang = null then Debug_Output ("ignoring impl naming data (lang. not in project): ", Lang_Name); else Value := Shared.Array_Elements.Table (Impls).Value; if Lang.Name = Name_Ada then Ada_Body_Suffix_Loc := Value.Location; end if; if Value.Kind = Single then Lang.Config.Naming_Data.Body_Suffix := Canonical_Case_File_Name (Value.Value); end if; end if; Impls := Shared.Array_Elements.Table (Impls).Next; end loop; end Initialize_Naming_Data; -- Start of processing for Check_Naming_Schemes begin -- No Naming package or parsing a configuration file? nothing to do if Naming_Id /= No_Package and then Project.Qualifier /= Configuration then Naming := Shared.Packages.Table (Naming_Id); Debug_Increase_Indent ("checking package Naming for ", Project.Name); Initialize_Naming_Data; Check_Naming; Debug_Decrease_Indent ("done checking package naming"); end if; end Check_Package_Naming; --------------------------------- -- Check_Programming_Languages -- --------------------------------- procedure Check_Programming_Languages (Project : Project_Id; Data : in out Tree_Processing_Data) is Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; Languages : Variable_Value := Nil_Variable_Value; Def_Lang : Variable_Value := Nil_Variable_Value; Def_Lang_Id : Name_Id; procedure Add_Language (Name, Display_Name : Name_Id); -- Add a new language to the list of languages for the project. -- Nothing is done if the language has already been defined ------------------ -- Add_Language -- ------------------ procedure Add_Language (Name, Display_Name : Name_Id) is Lang : Language_Ptr; begin Lang := Project.Languages; while Lang /= No_Language_Index loop if Name = Lang.Name then return; end if; Lang := Lang.Next; end loop; Lang := new Language_Data'(No_Language_Data); Lang.Next := Project.Languages; Project.Languages := Lang; Lang.Name := Name; Lang.Display_Name := Display_Name; end Add_Language; -- Start of processing for Check_Programming_Languages begin Project.Languages := null; Languages := GPR.Util.Value_Of (Name_Languages, Project.Decl.Attributes, Shared); Def_Lang := GPR.Util.Value_Of (Name_Default_Language, Project.Decl.Attributes, Shared); -- Check if languages are specified in this project if Languages.Default then -- Fail if there is no default language defined if Def_Lang.Default then Error_Msg (Data.Flags, "no languages defined for this project", Project.Location, Project); Def_Lang_Id := No_Name; else Def_Lang_Id := Get_Lower_Name_Id (Get_Name_String (Def_Lang.Value)); end if; if Def_Lang_Id /= No_Name then Get_Name_String (Def_Lang_Id); Name_Buffer (1) := To_Upper (Name_Buffer (1)); Add_Language (Name => Def_Lang_Id, Display_Name => Name_Find); end if; else declare Current : String_List_Id := Languages.Values; Element : String_Element; begin -- If there are no languages declared, there are no sources if Current = Nil_String then Project.Source_Dirs := Nil_String; if Project.Qualifier = Standard then Error_Msg (Data.Flags, "a standard project must have at least one language", Languages.Location, Project); end if; else -- Look through all the languages specified in attribute -- Languages. while Current /= Nil_String loop Element := Shared.String_Elements.Table (Current); Add_Language (Get_Lower_Name_Id (Get_Name_String (Element.Value)), Display_Name => Element.Value); Current := Element.Next; end loop; end if; end; end if; end Check_Programming_Languages; ------------------------------- -- Check_Stand_Alone_Library -- ------------------------------- procedure Check_Stand_Alone_Library (Project : Project_Id; Data : in out Tree_Processing_Data) is Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; Lib_Name : constant GPR.Variable_Value := GPR.Util.Value_Of (Snames.Name_Library_Name, Project.Decl.Attributes, Shared); Lib_Standalone : constant GPR.Variable_Value := GPR.Util.Value_Of (Snames.Name_Library_Standalone, Project.Decl.Attributes, Shared); Lib_Auto_Init : constant GPR.Variable_Value := GPR.Util.Value_Of (Snames.Name_Library_Auto_Init, Project.Decl.Attributes, Shared); Lib_Src_Dir : constant GPR.Variable_Value := GPR.Util.Value_Of (Snames.Name_Library_Src_Dir, Project.Decl.Attributes, Shared); Lib_Symbol_File : constant GPR.Variable_Value := GPR.Util.Value_Of (Snames.Name_Library_Symbol_File, Project.Decl.Attributes, Shared); Lib_Symbol_Policy : constant GPR.Variable_Value := GPR.Util.Value_Of (Snames.Name_Library_Symbol_Policy, Project.Decl.Attributes, Shared); Auto_Init_Supported : constant Boolean := Project.Config.Auto_Init_Supported; begin -- It is a stand-alone library project file if there is at least one -- declared or inherited interface. if Project.Lib_Interface_ALIs = Nil_String and then Project.Other_Interfaces = Nil_String then if not Lib_Standalone.Default and then To_Lower (Get_Name_String (Lib_Standalone.Value)) /= "no" then Error_Msg (Data.Flags, "Library_Standalone valid only if library has interfaces", Lib_Standalone.Location, Project); end if; else if Project.Standalone_Library = No then Project.Standalone_Library := Standard; end if; -- The name of a stand-alone library needs to have the syntax of an -- Ada identifier. declare Name : constant String := Get_Name_String (Project.Library_Name); OK : Boolean := Is_Letter (Name (Name'First)); Underline : Boolean := False; begin for J in Name'First + 1 .. Name'Last loop exit when not OK; if Is_Alphanumeric (Name (J)) then Underline := False; elsif Name (J) = '_' then if Underline then OK := False; else Underline := True; end if; else OK := False; end if; end loop; OK := OK and not Underline; if not OK then Error_Msg (Data.Flags, "Incorrect library name for a Stand-Alone Library", Lib_Name.Location, Project); return; end if; end; if Lib_Standalone.Default then Project.Standalone_Library := Standard; else Get_Name_String (Lib_Standalone.Value); Set_Casing (All_Lower_Case); if Name_Buffer (1 .. Name_Len) = "standard" then Project.Standalone_Library := Standard; elsif Name_Buffer (1 .. Name_Len) = "encapsulated" then Project.Standalone_Library := Encapsulated; elsif Name_Buffer (1 .. Name_Len) = "no" then Project.Standalone_Library := No; Error_Msg (Data.Flags, "wrong value for Library_Standalone when Library_Interface" & " defined", Lib_Standalone.Location, Project); else Error_Msg (Data.Flags, "invalid value for attribute Library_Standalone", Lib_Standalone.Location, Project); end if; end if; -- Check value of attribute Library_Auto_Init and set Lib_Auto_Init -- accordingly. if Lib_Auto_Init.Default then -- If no attribute Library_Auto_Init is declared, then set auto -- init only if it is supported. Project.Lib_Auto_Init := Auto_Init_Supported; else Get_Name_String (Lib_Auto_Init.Value); Set_Casing (All_Lower_Case); if Name_Buffer (1 .. Name_Len) = "false" then Project.Lib_Auto_Init := False; elsif Name_Buffer (1 .. Name_Len) = "true" then if Auto_Init_Supported then Project.Lib_Auto_Init := True; else -- Library_Auto_Init cannot be "true" if auto init is not -- supported. Error_Msg (Data.Flags, "library auto init not supported on this platform", Lib_Auto_Init.Location, Project); end if; else Error_Msg (Data.Flags, "invalid value for attribute Library_Auto_Init", Lib_Auto_Init.Location, Project); end if; end if; -- If attribute Library_Src_Dir is defined and not the empty string, -- check if the directory exist and is not the object directory or -- one of the source directories. This is the directory where copies -- of the interface sources will be copied. Note that this directory -- may be the library directory. if Lib_Src_Dir.Value /= Empty_String then declare Dir_Id : constant File_Name_Type := File_Name_Type (Lib_Src_Dir.Value); Dir_Exists : Boolean; begin Locate_Directory (Project, Dir_Id, Path => Project.Library_Src_Dir, Dir_Exists => Dir_Exists, Data => Data, Must_Exist => False, Create => "library source copy", Location => Lib_Src_Dir.Location, Externally_Built => Project.Externally_Built); -- If directory does not exist, report an error if not Dir_Exists then if Opt.Directories_Must_Exist_In_Projects then -- Get the absolute name of the library directory that -- does not exist, to report an error. Error_Msg_File_1 := File_Name_Type (Project.Library_Src_Dir.Display_Name); Error_Or_Warning (Data.Flags, Data.Flags.Require_Obj_Dirs, "Directory { does not exist", Lib_Src_Dir.Location, Project); end if; -- Report error if it is the same as the object directory elsif Project.Library_Src_Dir = Project.Object_Directory then Error_Msg (Data.Flags, "directory to copy interfaces cannot be the object" & " directory", Lib_Src_Dir.Location, Project); Project.Library_Src_Dir := No_Path_Information; else declare Src_Dirs : String_List_Id; Src_Dir : String_Element; Pid : Project_List; begin -- Interface copy directory cannot be one of the source -- directory of the current project. Src_Dirs := Project.Source_Dirs; while Src_Dirs /= Nil_String loop Src_Dir := Shared.String_Elements.Table (Src_Dirs); -- Report error if it is one of the source directories if Project.Library_Src_Dir.Name = Path_Name_Type (Src_Dir.Value) then Error_Msg (Data.Flags, "directory to copy interfaces cannot be one of" & " the source directories", Lib_Src_Dir.Location, Project); Project.Library_Src_Dir := No_Path_Information; exit; end if; Src_Dirs := Src_Dir.Next; end loop; if Project.Library_Src_Dir /= No_Path_Information then -- It cannot be a source directory of any other -- project either. Pid := Data.Tree.Projects; Project_Loop : loop exit Project_Loop when Pid = null; Src_Dirs := Pid.Project.Source_Dirs; Dir_Loop : while Src_Dirs /= Nil_String loop Src_Dir := Shared.String_Elements.Table (Src_Dirs); -- Report error if it is one of the source -- directories. if Project.Library_Src_Dir.Name = Path_Name_Type (Src_Dir.Value) then Error_Msg_File_1 := File_Name_Type (Src_Dir.Value); Error_Msg_Name_1 := Pid.Project.Name; Error_Msg (Data.Flags, "directory to copy interfaces cannot be" & " the same as source directory { of" & " project %%", Lib_Src_Dir.Location, Project); Project.Library_Src_Dir := No_Path_Information; exit Project_Loop; end if; Src_Dirs := Src_Dir.Next; end loop Dir_Loop; Pid := Pid.Next; end loop Project_Loop; end if; end; -- In high verbosity, if there is a valid Library_Src_Dir, -- display its path name. if Project.Library_Src_Dir /= No_Path_Information and then Current_Verbosity = High then Write_Attr ("Directory to copy interfaces", Get_Name_String (Project.Library_Src_Dir.Name)); end if; end if; end; end if; -- Check the symbol related attributes -- First, the symbol policy if Lib_Symbol_Policy.Default then Project.Symbol_Data.Symbol_Policy := Restricted; else declare Value : constant String := To_Lower (Get_Name_String (Lib_Symbol_Policy.Value)); begin -- Symbol policy must have one of a limited number of values if Value = "unrestricted" then Project.Symbol_Data.Symbol_Policy := Unrestricted; elsif Value = "restricted" then Project.Symbol_Data.Symbol_Policy := Restricted; else Error_Msg (Data.Flags, "illegal value for Library_Symbol_Policy", Lib_Symbol_Policy.Location, Project); end if; end; end if; if not Lib_Symbol_File.Default then -- Library_Symbol_File is defined, check file exists Project.Symbol_Data.Symbol_File := Path_Name_Type (Lib_Symbol_File.Value); Get_Name_String (Lib_Symbol_File.Value); if Name_Len = 0 then Error_Msg (Data.Flags, "symbol file name cannot be an empty string", Lib_Symbol_File.Location, Project); else if not Is_Absolute_Path (Name_Buffer (1 .. Name_Len)) then Get_Name_String (Project.Directory.Display_Name); Get_Name_String_And_Append (Lib_Symbol_File.Value); Project.Symbol_Data.Symbol_File := Name_Find; end if; if not Is_Regular_File (Get_Name_String (Project.Symbol_Data.Symbol_File)) then Error_Msg_File_1 := File_Name_Type (Lib_Symbol_File.Value); Error_Msg_Warn := False; Error_Msg (Data.Flags, " 0; First : Positive; function Is_Reserved (Name : Name_Id) return Boolean; function Is_Reserved (S : String) return Boolean; -- Check that the given name is not an Ada 95 reserved word. The reason -- for the Ada 95 here is that we do not want to exclude the case of an -- Ada 95 unit called Interface (for example). In Ada 2005, such a unit -- name would be rejected anyway by the compiler. That means there is no -- requirement that the project file parser reject this. ----------------- -- Is_Reserved -- ----------------- function Is_Reserved (S : String) return Boolean is begin return Is_Reserved (Get_Name_Id (S)); end Is_Reserved; ----------------- -- Is_Reserved -- ----------------- function Is_Reserved (Name : Name_Id) return Boolean is begin if Name in Reserved_Ada_95 then Unit := No_Name; Debug_Output ("project reserved word: ", Name); return True; else return False; end if; end Is_Reserved; -- Start of processing for Check_Unit_Name begin Name_Len := The_Name'Length; Name_Buffer (1 .. Name_Len) := The_Name; Real_Name := Name_Find; if Is_Reserved (Real_Name) then return; end if; First := The_Name'First; for Index in The_Name'Range loop if Need_Letter then -- We need a letter (at the beginning, and following a dot), -- but we don't have one. if Is_Letter (The_Name (Index)) then Need_Letter := False; else OK := False; if Current_Verbosity = High then Debug_Indent; Write_Str (Index'Img); Write_Str (": '"); Write_Char (The_Name (Index)); Write_Line ("' is not a letter."); end if; exit; end if; elsif Last_Underscore and then (The_Name (Index) = '_' or else The_Name (Index) = '.') then -- Two underscores are illegal, and a dot cannot follow -- an underscore. OK := False; if Current_Verbosity = High then Debug_Indent; Write_Str (Index'Img); Write_Str (": '"); Write_Char (The_Name (Index)); Write_Line ("' is illegal here."); end if; exit; elsif The_Name (Index) = '.' then -- First, check if the name before the dot is not a reserved word if Is_Reserved (The_Name (First .. Index - 1)) then return; end if; First := Index + 1; -- We need a letter after a dot Need_Letter := True; elsif The_Name (Index) = '_' then Last_Underscore := True; else -- We need an letter or a digit Last_Underscore := False; if not Is_Alphanumeric (The_Name (Index)) then OK := False; if Current_Verbosity = High then Debug_Indent; Write_Str (Index'Img); Write_Str (": '"); Write_Char (The_Name (Index)); Write_Line ("' is not alphanumeric."); end if; exit; end if; end if; end loop; -- Cannot end with an underscore or a dot OK := OK and then not Need_Letter and then not Last_Underscore; if OK then if First /= Name'First and then Is_Reserved (The_Name (First .. The_Name'Last)) then return; end if; Unit := Real_Name; else -- Signal a problem with No_Name Unit := No_Name; end if; end Check_Unit_Name; ---------------------------- -- Compute_Directory_Last -- ---------------------------- function Compute_Directory_Last (Dir : String) return Natural is begin if Dir'Length > 1 and then Is_Directory_Separator (Dir (Dir'Last - 1)) then return Dir'Last - 1; else return Dir'Last; end if; end Compute_Directory_Last; -------------------------- -- Get_Object_Directory -- -------------------------- procedure Get_Object_Directory (Project : Project_Id; Data : in out Tree_Processing_Data; No_Sources : Boolean := False) is Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; Object_Dir : constant Variable_Value := Util.Value_Of (Name_Object_Dir, Project.Decl.Attributes, Shared); Dir_Exists : Boolean; begin -- Set the object directory to its default which may be nil, if there -- is no sources in the project. if No_Sources then Project.Object_Directory := No_Path_Information; else Project.Object_Directory := Project.Directory; end if; -- Check the object directory if Object_Dir.Value not in No_Name | Empty_String then Get_Name_String (Object_Dir.Value); if Name_Len = 0 then Error_Msg (Data.Flags, "Object_Dir cannot be empty", Object_Dir.Location, Project); elsif Create_Dirs /= Never_Create_Dirs and then No_Sources and then Project.Extends = No_Project then -- Do not create an object directory for a non extending project -- with no sources. Locate_Directory (Project, File_Name_Type (Object_Dir.Value), Path => Project.Object_Directory, Dir_Exists => Dir_Exists, Data => Data, Location => Object_Dir.Location, Must_Exist => False, Externally_Built => Project.Externally_Built); else -- We check that the specified object directory does exist. -- However, even when it doesn't exist, we set it to a default -- value. This is for the benefit of tools that recover from -- errors; for example, these tools could create the non existent -- directory. We always return an absolute directory name though. Locate_Directory (Project, File_Name_Type (Object_Dir.Value), Path => Project.Object_Directory, Create => "object", Dir_Exists => Dir_Exists, Data => Data, Location => Object_Dir.Location, Must_Exist => False, Externally_Built => Project.Externally_Built); if not Dir_Exists and then not Project.Externally_Built and then Project.Qualifier /= Abstract_Project then if Opt.Directories_Must_Exist_In_Projects then -- The object directory does not exist, report an error if -- the project is not externally built. Error_Msg_File_1 := File_Name_Type (Object_Dir.Value); Error_Or_Warning (Data.Flags, Data.Flags.Require_Obj_Dirs, "object directory { not found", Object_Dir.Location, Project); end if; end if; end if; elsif not No_Sources and then (Subdirs /= null or else Build_Tree_Dir /= null) then Name_Len := 1; Name_Buffer (1) := '.'; Locate_Directory (Project, Name_Find, Path => Project.Object_Directory, Create => "object", Dir_Exists => Dir_Exists, Data => Data, Location => Object_Dir.Location, Externally_Built => Project.Externally_Built); end if; if Current_Verbosity = High then if Project.Object_Directory = No_Path_Information then Debug_Output ("no object directory"); else Write_Attr ("Object directory", Get_Name_String (Project.Object_Directory.Display_Name)); end if; end if; end Get_Object_Directory; --------------------- -- Get_Directories -- --------------------- procedure Get_Directories (Project : Project_Id; Data : in out Tree_Processing_Data; No_Sources : out Boolean) is Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; Exec_Dir : constant Variable_Value := Util.Value_Of (Name_Exec_Dir, Project.Decl.Attributes, Shared); Source_Dirs : constant Variable_Value := Util.Value_Of (Name_Source_Dirs, Project.Decl.Attributes, Shared); Ignore_Source_Sub_Dirs : constant Variable_Value := Util.Value_Of (Name_Ignore_Source_Sub_Dirs, Project.Decl.Attributes, Shared); Excluded_Source_Dirs : constant Variable_Value := Util.Value_Of (Name_Excluded_Source_Dirs, Project.Decl.Attributes, Shared); Source_Files : constant Variable_Value := Util.Value_Of (Name_Source_Files, Project.Decl.Attributes, Shared); Last_Source_Dir : String_List_Id := Nil_String; Last_Src_Dir_Rank : Number_List_Index := No_Number_List; Languages : constant Variable_Value := GPR.Util.Value_Of (Name_Languages, Project.Decl.Attributes, Shared); procedure Add_To_Or_Remove_From_Source_Dirs (Path : Path_Information; Rank : Natural; Remove : Boolean); -- When Remove = False, Adds the directory Path_Id to the list of -- source_dirs if not already in the list. When Remove = True, -- removes directory Path_Id if in the list. procedure Add_To_Source_Dirs (Path : Path_Information; Rank : Natural); -- Adds the directory Path_Id to the list of source_dirs if not already -- in the list. procedure Remove_From_Source_Dirs (Path : Path_Information; Rank : Natural); -- Removes directory Path_Id if in the list. procedure Find_Source_Dirs (Patterns : String_List_Id; Ignore : String_List_Id; Callback : not null access procedure (Path : Path_Information; Pattern_Index : Natural) := Add_To_Source_Dirs'Access); ---------------------- -- Find_Source_Dirs -- ---------------------- procedure Find_Source_Dirs (Patterns : String_List_Id; Ignore : String_List_Id; Callback : not null access procedure (Path : Path_Information; Pattern_Index : Natural) := Add_To_Source_Dirs'Access) is begin Expand_Subdirectory_Pattern (Project => Project, Data => Data, Patterns => Patterns, Ignore => Ignore, Search_For => Search_Source_Directories, Resolve_Links => Opt.Follow_Links_For_Dirs, Callback => Callback); end Find_Source_Dirs; --------------------------------------- -- Add_To_Or_Remove_From_Source_Dirs -- --------------------------------------- procedure Add_To_Or_Remove_From_Source_Dirs (Path : Path_Information; Rank : Natural; Remove : Boolean) is List : String_List_Id; Prev : String_List_Id; Rank_List : Number_List_Index; Prev_Rank : Number_List_Index; Element : String_Element; begin Prev := Nil_String; Prev_Rank := No_Number_List; List := Project.Source_Dirs; Rank_List := Project.Source_Dir_Ranks; while List /= Nil_String loop Element := Shared.String_Elements.Table (List); exit when Element.Value = Name_Id (Path.Name); Prev := List; List := Element.Next; Prev_Rank := Rank_List; Rank_List := Shared.Number_Lists.Table (Prev_Rank).Next; end loop; -- The directory is in the list if List is not Nil_String if not Remove and then List = Nil_String then Debug_Output ("adding source dir=", Name_Id (Path.Display_Name)); String_Element_Table.Increment_Last (Shared.String_Elements); Element := (Value => Name_Id (Path.Name), Index => 0, Display_Value => Name_Id (Path.Display_Name), Location => No_Location, Next => Nil_String); Number_List_Table.Increment_Last (Shared.Number_Lists); if Last_Source_Dir = Nil_String then -- This is the first source directory Project.Source_Dirs := String_Element_Table.Last (Shared.String_Elements); Project.Source_Dir_Ranks := Number_List_Table.Last (Shared.Number_Lists); else -- We already have source directories, link the previous -- last to the new one. Shared.String_Elements.Table (Last_Source_Dir).Next := String_Element_Table.Last (Shared.String_Elements); Shared.Number_Lists.Table (Last_Src_Dir_Rank).Next := Number_List_Table.Last (Shared.Number_Lists); end if; -- And register this source directory as the new last Last_Source_Dir := String_Element_Table.Last (Shared.String_Elements); Shared.String_Elements.Table (Last_Source_Dir) := Element; Last_Src_Dir_Rank := Number_List_Table.Last (Shared.Number_Lists); Shared.Number_Lists.Table (Last_Src_Dir_Rank) := (Number => Rank, Next => No_Number_List); elsif Remove and then List /= Nil_String then -- Remove source dir if present if Prev = Nil_String then Project.Source_Dirs := Shared.String_Elements.Table (List).Next; Project.Source_Dir_Ranks := Shared.Number_Lists.Table (Rank_List).Next; else Shared.String_Elements.Table (Prev).Next := Shared.String_Elements.Table (List).Next; Shared.Number_Lists.Table (Prev_Rank).Next := Shared.Number_Lists.Table (Rank_List).Next; end if; end if; end Add_To_Or_Remove_From_Source_Dirs; ------------------------ -- Add_To_Source_Dirs -- ------------------------ procedure Add_To_Source_Dirs (Path : Path_Information; Rank : Natural) is begin Add_To_Or_Remove_From_Source_Dirs (Path, Rank, Remove => False); end Add_To_Source_Dirs; ----------------------------- -- Remove_From_Source_Dirs -- ----------------------------- procedure Remove_From_Source_Dirs (Path : Path_Information; Rank : Natural) is begin Add_To_Or_Remove_From_Source_Dirs (Path, Rank, Remove => True); end Remove_From_Source_Dirs; -- Local declarations Dir_Exists : Boolean; -- Start of processing for Get_Directories begin No_Sources := Project.Qualifier = Abstract_Project or else (((not Source_Files.Default and then Source_Files.Values = Nil_String) or else (not Source_Dirs.Default and then Source_Dirs.Values = Nil_String) or else (not Languages.Default and then Languages.Values = Nil_String)) and then Project.Extends = No_Project); Debug_Output ("starting to look for directories"); Get_Object_Directory (Project, Data, No_Sources); -- Check the exec directory -- We set the object directory to its default Project.Exec_Directory := Project.Object_Directory; if Exec_Dir.Value not in Empty_String | No_Name then Get_Name_String (Exec_Dir.Value); if Name_Len = 0 then Error_Msg (Data.Flags, "Exec_Dir cannot be empty", Exec_Dir.Location, Project); elsif Create_Dirs /= Never_Create_Dirs and then No_Sources and then Project.Extends = No_Project then -- Do not create an exec directory for a non extending project -- with no sources. Locate_Directory (Project, File_Name_Type (Exec_Dir.Value), Path => Project.Exec_Directory, Dir_Exists => Dir_Exists, Data => Data, Must_Exist => False, Location => Exec_Dir.Location, Externally_Built => Project.Externally_Built); else -- We check that the specified exec directory does exist Locate_Directory (Project, File_Name_Type (Exec_Dir.Value), Path => Project.Exec_Directory, Dir_Exists => Dir_Exists, Data => Data, Create => "exec", Must_Exist => False, Location => Exec_Dir.Location, Externally_Built => Project.Externally_Built); if not Dir_Exists and then not Project.Externally_Built and then not (Project.Qualifier = Abstract_Project) then if Opt.Directories_Must_Exist_In_Projects then Error_Msg_File_1 := File_Name_Type (Exec_Dir.Value); Error_Or_Warning (Data.Flags, Data.Flags.Require_Obj_Dirs, "exec directory { not found", Project.Location, Project); else Project.Exec_Directory := No_Path_Information; end if; end if; end if; end if; if Current_Verbosity = High then if Project.Exec_Directory = No_Path_Information then Debug_Output ("no exec directory"); else Debug_Output ("exec directory: ", Name_Id (Project.Exec_Directory.Display_Name)); end if; end if; -- Look for the source directories Debug_Output ("starting to look for source directories"); pragma Assert (Source_Dirs.Kind = List, "Source_Dirs is not a list"); if not Source_Files.Default and then Source_Files.Values = Nil_String then Project.Source_Dirs := Nil_String; if Project.Qualifier = Standard then Error_Msg (Data.Flags, "a standard project must have sources", Source_Files.Location, Project); end if; -- No source dirs: nothing further to do return; end if; -- If we were provided src-subdirs, add / in -- front of the source directories so that files found in this directory -- will override original source files. if Src_Subdirs /= null and then Project.Qualifier /= Abstract_Project and then not No_Sources then declare function Try_Src_Subdir (Prefix : Name_Id) return Boolean; -- Try to add source subdirectory in object directory Obj_Dir with -- Prefix or not if Prefix is No_Name. Returns True on success. function Get_Src_Subdir (Prefix : Name_Id) return String is ((if Prefix = No_Name then "" else Get_Name_String (Prefix) & '-') & Src_Subdirs.all & Directory_Separator); -- Returns --src-subdirs parameter either with project name prefix -- or not if PRefix is No_Name. -------------------- -- Try_Src_Subdir -- -------------------- function Try_Src_Subdir (Prefix : Name_Id) return Boolean is Src_Subdir : constant String := Get_Src_Subdir (Prefix); Name : Path_Name_Type; N : String := Get_Name_String (Project.Object_Directory.Name) & Src_Subdir; begin if Is_Directory (N) then Canonical_Case_File_Name (N); Name := Get_Path_Name_Id (N); -- Set Rank to 0 so that duplicate units are silently -- accepted. Add_To_Source_Dirs (Path => (Name => Name, Display_Name => Get_Path_Name_Id (Get_Name_String (Project.Object_Directory.Display_Name) & Src_Subdir)), Rank => 0); return True; end if; return False; end Try_Src_Subdir; begin if Try_Src_Subdir (Project.Name) or else Try_Src_Subdir (No_Name) then null; end if; end; end if; if Source_Dirs.Default then -- No Source_Dirs specified: the single source directory is the one -- containing the project file. Add_To_Source_Dirs (Path => Project.Directory, Rank => 1); else Find_Source_Dirs (Source_Dirs.Values, Ignore_Source_Sub_Dirs.Values); if Project.Source_Dirs = Nil_String and then Project.Qualifier = Standard then Error_Msg (Data.Flags, "a standard project must have source directories", Source_Dirs.Location, Project); end if; end if; if not Excluded_Source_Dirs.Default and then Excluded_Source_Dirs.Values /= Nil_String then Find_Source_Dirs (Excluded_Source_Dirs.Values, Nil_String, Remove_From_Source_Dirs'Access); end if; Debug_Output ("putting source directories in canonical cases"); declare Current : String_List_Id := Project.Source_Dirs; Element : String_Element; begin while Current /= Nil_String loop Element := Shared.String_Elements.Table (Current); if Element.Value /= No_Name then Element.Value := Name_Id (Canonical_Case_File_Name (Element.Value)); Shared.String_Elements.Table (Current) := Element; end if; Current := Element.Next; end loop; end; end Get_Directories; --------------- -- Get_Mains -- --------------- procedure Get_Mains (Project : Project_Id; Data : in out Tree_Processing_Data) is Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; Mains : constant Variable_Value := GPR.Util.Value_Of (Name_Main, Project.Decl.Attributes, Shared); List : String_List_Id; Elem : String_Element; begin Project.Mains := Mains.Values; -- If no Mains were specified, and if we are an extending project, -- inherit the Mains from the project we are extending. if Mains.Default then if not Project.Library and then Project.Extends /= No_Project then Project.Mains := Project.Extends.Mains; end if; -- In a library project file, Main cannot be specified elsif Project.Library then Error_Msg (Data.Flags, "a library project file cannot have Main specified", Mains.Location, Project); else List := Mains.Values; while List /= Nil_String loop Elem := Shared.String_Elements.Table (List); if Elem.Value = Empty_String then Error_Msg (Data.Flags, "?a main cannot have an empty name", Elem.Location, Project); exit; end if; List := Elem.Next; end loop; end if; end Get_Mains; --------------------------- -- Get_Sources_From_File -- --------------------------- procedure Get_Sources_From_File (Path : String; Location : Source_Ptr; Project : in out Project_Processing_Data; Data : in out Tree_Processing_Data) is File : GPR.Util.Text_File; Line : String (1 .. 250); Last : Natural; Source_Name : File_Name_Type; Name_Loc : Name_Location; begin if Current_Verbosity = High then Debug_Output ("opening """ & Path & '"'); end if; -- Open the file GPR.Util.Open (File, Path); if not GPR.Util.Is_Valid (File) then Error_Msg (Data.Flags, "file does not exist", Location, Project.Project); else -- Read the lines one by one while not GPR.Util.End_Of_File (File) loop GPR.Util.Get_Line (File, Line, Last); -- A non empty, non comment line should contain a file name if Last /= 0 and then (Last = 1 or else Line (1 .. 2) /= "--") then Name_Len := Last; Name_Buffer (1 .. Name_Len) := Line (1 .. Last); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); Source_Name := Name_Find; -- Check that there is no directory information for J in 1 .. Last loop if Is_Directory_Separator (Line (J)) then Error_Msg_File_1 := Source_Name; Error_Msg (Data.Flags, "file name cannot include directory information ({)", Location, Project.Project); exit; end if; end loop; Name_Loc := Source_Names_Htable.Get (Project.Source_Names, Source_Name); if Name_Loc = No_Name_Location then Name_Loc := (Name => Source_Name, Location => Location, Source => No_Source, Listed => True, Found => False); else Name_Loc.Listed := True; end if; Source_Names_Htable.Set (Project.Source_Names, Source_Name, Name_Loc); end if; end loop; GPR.Util.Close (File); end if; end Get_Sources_From_File; ------------------ -- No_Space_Img -- ------------------ function No_Space_Img (N : Natural) return String is Image : constant String := N'Img; begin return Image (2 .. Image'Last); end No_Space_Img; ----------------------- -- Compute_Unit_Name -- ----------------------- procedure Compute_Unit_Name (File_Name : File_Name_Type; Naming : Lang_Naming_Data; Kind : out Source_Kind; Unit : out Name_Id; Project : Project_Processing_Data) is Filename : constant String := Get_Name_String (File_Name); Last : Integer := Filename'Last; Sep_Len : Integer; Body_Len : Integer; Spec_Len : Integer; Unit_Except : Unit_Exception; Masked : Boolean := False; begin Unit := No_Name; Kind := Spec; if Naming.Separate_Suffix = No_File or else Naming.Body_Suffix = No_File or else Naming.Spec_Suffix = No_File then return; end if; if Naming.Dot_Replacement = No_File then Debug_Output ("no dot_replacement specified"); return; end if; Sep_Len := Integer (Length_Of_Name (Naming.Separate_Suffix)); Spec_Len := Integer (Length_Of_Name (Naming.Spec_Suffix)); Body_Len := Integer (Length_Of_Name (Naming.Body_Suffix)); -- Choose the longest suffix that matches. If there are several matches, -- give priority to specs, then bodies, then separates. if Naming.Separate_Suffix /= Naming.Body_Suffix and then Suffix_Matches (Filename, Naming.Separate_Suffix) then Last := Filename'Last - Sep_Len; Kind := Sep; end if; if Filename'Last - Body_Len <= Last and then Suffix_Matches (Filename, Naming.Body_Suffix) then Last := Natural'Min (Last, Filename'Last - Body_Len); Kind := Impl; end if; if Filename'Last - Spec_Len <= Last and then Suffix_Matches (Filename, Naming.Spec_Suffix) then Last := Natural'Min (Last, Filename'Last - Spec_Len); Kind := Spec; end if; if Last = Filename'Last then Debug_Output ("no matching suffix"); return; end if; -- Check that the casing matches. -- The debug flag -du deactivates this. if not Debug.Debug_Flag_U and then File_Names_Case_Sensitive then case Naming.Casing is when All_Lower_Case => for J in Filename'First .. Last loop if Is_Letter (Filename (J)) and then not Is_Lower (Filename (J)) then Debug_Output ("invalid casing"); return; end if; end loop; when All_Upper_Case => for J in Filename'First .. Last loop if Is_Letter (Filename (J)) and then not Is_Upper (Filename (J)) then Debug_Output ("invalid casing"); return; end if; end loop; when Mixed_Case | Unknown => null; end case; end if; -- If Dot_Replacement is not a single dot, then there should not -- be any dot in the name. declare Dot_Repl : constant String := Get_Name_String (Naming.Dot_Replacement); begin if Dot_Repl /= "." then for Index in Filename'First .. Last loop if Filename (Index) = '.' then Debug_Output ("invalid name, contains dot"); return; end if; end loop; Replace_Into_Name_Buffer (Filename (Filename'First .. Last), Dot_Repl, '.'); else Name_Len := Last - Filename'First + 1; Name_Buffer (1 .. Name_Len) := Filename (Filename'First .. Last); Fixed.Translate (Source => Name_Buffer (1 .. Name_Len), Mapping => Lower_Case_Map); end if; end; -- In the standard GNAT naming scheme, check for special cases: children -- or separates of A, G, I or S, and run time sources. if Is_Standard_GNAT_Naming (Naming) and then Name_Len >= 3 then declare S1 : constant Character := Name_Buffer (1); S2 : constant Character := Name_Buffer (2); S3 : constant Character := Name_Buffer (3); begin if S1 = 'a' or else S1 = 'g' or else S1 = 'i' or else S1 = 's' then -- Children or separates of packages A, G, I or S. These names -- are x__ ... or x~... (where x is a, g, i, or s). Both -- versions (x__... and x~...) are allowed in all platforms, -- because it is not possible to know the platform before -- processing of the project files. if S2 = '_' and then S3 = '_' then Name_Buffer (2) := '.'; Name_Buffer (3 .. Name_Len - 1) := Name_Buffer (4 .. Name_Len); Name_Len := Name_Len - 1; elsif S2 = '~' then Name_Buffer (2) := '.'; elsif S2 = '.' then -- If it is potentially a run time source null; end if; end if; end; end if; -- Name_Buffer contains the name of the unit in lower-cases. Check -- that this is a valid unit name. -- The debug flag -du deactivates this. if not Debug.Debug_Flag_U then Check_Unit_Name (Name_Buffer (1 .. Name_Len), Unit); else Unit := Name_Find; end if; -- If there is a naming exception for the same unit, the file is not -- a source for the unit. if Unit /= No_Name then Unit_Except := Unit_Exceptions_Htable.Get (Project.Unit_Exceptions, Unit); if Kind = Spec then Masked := Unit_Except.Spec /= No_File and then Unit_Except.Spec /= File_Name; else Masked := Unit_Except.Impl /= No_File and then Unit_Except.Impl /= File_Name; end if; if Masked then if Current_Verbosity = High then Debug_Indent; Write_Str (" """ & Filename & """ contains the "); if Kind = Spec then Write_Str ("spec of a unit found in """); Write_Str (Get_Name_String (Unit_Except.Spec)); else Write_Str ("body of a unit found in """); Write_Str (Get_Name_String (Unit_Except.Impl)); end if; Write_Line (""" (ignored)"); end if; Unit := No_Name; end if; end if; if Unit /= No_Name and then Current_Verbosity = High then case Kind is when Spec => Debug_Output ("spec of", Unit); when Impl => Debug_Output ("body of", Unit); when Sep => Debug_Output ("sep of", Unit); end case; end if; end Compute_Unit_Name; -------------------------- -- Check_Illegal_Suffix -- -------------------------- procedure Check_Illegal_Suffix (Project : Project_Id; Suffix : File_Name_Type; Dot_Replacement : File_Name_Type; Attribute_Name : String; Location : Source_Ptr; Data : in out Tree_Processing_Data) is Suffix_Str : constant String := Get_Name_String (Suffix); begin if Suffix_Str'Length = 0 then -- Always valid return; elsif Index (Suffix_Str, ".") = 0 then Error_Msg_File_1 := Suffix; Error_Msg (Data.Flags, "{ is illegal for " & Attribute_Name & ": must have a dot", Location, Project); return; end if; -- Case of dot replacement is a single dot, and first character of -- suffix is also a dot. if Dot_Replacement /= No_File and then Get_Name_String (Dot_Replacement) = "." and then Suffix_Str (Suffix_Str'First) = '.' then for Index in Suffix_Str'First + 1 .. Suffix_Str'Last loop -- If there are multiple dots in the name if Suffix_Str (Index) = '.' then -- It is illegal to have a letter following the initial dot if Is_Letter (Suffix_Str (Suffix_Str'First + 1)) then Error_Msg_File_1 := Suffix; Error_Msg (Data.Flags, "{ is illegal for " & Attribute_Name & ": ambiguous prefix when Dot_Replacement is a dot", Location, Project); end if; return; end if; end loop; end if; end Check_Illegal_Suffix; ---------------------- -- Locate_Directory -- ---------------------- procedure Locate_Directory (Project : Project_Id; Name : File_Name_Type; Path : out Path_Information; Dir_Exists : out Boolean; Data : in out Tree_Processing_Data; Create : String := ""; Location : Source_Ptr := No_Location; Must_Exist : Boolean := True; Externally_Built : Boolean := False) is Parent : constant Path_Name_Type := Project.Directory.Display_Name; The_Parent : constant String := Get_Name_String (Parent); The_Parent_Last : constant Natural := Compute_Directory_Last (The_Parent); Full_Name : File_Name_Type; The_Name : File_Name_Type; Is_Relative : Boolean; begin -- Check if we have a root-object dir specified, if so relocate all -- artefact directories to it. if not Externally_Built and then Build_Tree_Dir /= null and then Create /= "" and then not Is_Absolute_Path (Get_Name_String (Name)) then Set_Name_Buffer (Build_Tree_Dir.all); if The_Parent_Last - The_Parent'First + 1 < Root_Dir'Length then Error_Msg_File_1 := Name; Error_Or_Warning (Data.Flags, Error, "{ cannot relocate deeper than " & Create & " directory", No_Location, Project); end if; Add_Str_To_Name_Buffer (Relative_Path (The_Parent (The_Parent'First .. The_Parent_Last), Root_Dir.all)); Get_Name_String_And_Append (Name); else if not Externally_Built and then Build_Tree_Dir /= null and then Create /= "" then -- Issue a warning that we cannot relocate absolute obj dir Error_Msg_File_1 := Name; Error_Or_Warning (Data.Flags, Warning, "{ cannot relocate absolute object directory", No_Location, Project); end if; Get_Name_String (Name); end if; -- Convert '/' to directory separator (for Windows) if Directory_Separator /= '/' then for J in 1 .. Name_Len loop if Name_Buffer (J) = '/' then Name_Buffer (J) := Directory_Separator; end if; end loop; end if; -- Add Subdirs.all if it is a directory that may be created and -- Subdirs is not null; if Create /= "" and then Subdirs /= null then if Name_Buffer (Name_Len) /= Directory_Separator then Add_Char_To_Name_Buffer (Directory_Separator); end if; Add_Str_To_Name_Buffer (Subdirs.all); end if; The_Name := Name_Find; if Current_Verbosity = High then Debug_Indent; Write_Str ("Locate_Directory ("""); Write_Str (Get_Name_String (The_Name)); Write_Str (""", in """); Write_Str (The_Parent); Write_Line (""")"); end if; Path := No_Path_Information; Dir_Exists := False; if Is_Absolute_Path (Get_Name_String (The_Name)) then Is_Relative := False; Full_Name := The_Name; else Is_Relative := True; Set_Name_Buffer (The_Parent (The_Parent'First .. The_Parent_Last)); Get_Name_String_And_Append (The_Name); Full_Name := Name_Find; end if; declare Full_Path_Name : String_Access := new String'(Normalize_Pathname (Get_Name_String (Full_Name), Resolve_Links => False)); begin -- We may proceed with directory creation depending on the value -- of Create_Dirs: if it is set to Create_All_Dirs, or if the dir -- is relative and Create_Dirs is set to Create_Relative_Dirs_Only. if (Create_Dirs = Create_All_Dirs or else (Create_Dirs = Create_Relative_Dirs_Only and then Is_Relative) or else Subdirs /= null) and then Create'Length > 0 and then Project.Qualifier /= Abstract_Project then if not Is_Directory (Full_Path_Name.all) then -- If project is externally built, do not create a subdir, -- use the specified directory, without the subdir. if Externally_Built then if Is_Absolute_Path (Get_Name_String (Name)) then Get_Name_String (Name); else Set_Name_Buffer (The_Parent (The_Parent'First .. The_Parent_Last)); Get_Name_String_And_Append (Name); end if; Free (Full_Path_Name); Full_Path_Name := new String'(Name_Buffer (1 .. Name_Len)); else begin Create_Path (Full_Path_Name.all); if not GPR.Opt.Quiet_Output then if Verbose_Mode then Write_Str (Create); Write_Str (" directory """); Write_Str (Full_Path_Name.all); Write_Str (""" created for project "); Write_Line (Get_Name_String (Project.Display_Name)); else Display (Section => Setup, Command => "mkdir", Argument => Create & " directory for project " & Get_Name_String_Safe (Project.Display_Name)); end if; end if; exception when Ada.Directories.Use_Error => -- Output message with name of directory. Note that we -- use the ~ insertion method here in case the name -- has special characters in it. Error_Msg_Strlen := Full_Path_Name'Length; Error_Msg_String (1 .. Error_Msg_Strlen) := Full_Path_Name.all; Error_Msg (Data.Flags, "could not create " & Create & " directory ~", Location, Project); end; end if; end if; end if; Dir_Exists := Is_Directory (Full_Path_Name.all); if not Must_Exist or Dir_Exists then declare Normed : constant String := Normalize_Pathname (Full_Path_Name.all, Directory => The_Parent (The_Parent'First .. The_Parent_Last), Resolve_Links => False, Case_Sensitive => True); Canonical_Path : constant String := Normalize_Pathname (Normed, Directory => The_Parent (The_Parent'First .. The_Parent_Last), Resolve_Links => Opt.Follow_Links_For_Dirs, Case_Sensitive => False); begin Name_Len := Normed'Length; Name_Buffer (1 .. Name_Len) := Normed; -- Directories should always end with a directory separator if Name_Buffer (Name_Len) /= Directory_Separator then Add_Char_To_Name_Buffer (Directory_Separator); end if; Path.Display_Name := Name_Find; Name_Len := Canonical_Path'Length; Name_Buffer (1 .. Name_Len) := Canonical_Path; if Name_Buffer (Name_Len) /= Directory_Separator then Add_Char_To_Name_Buffer (Directory_Separator); end if; Path.Name := Name_Find; end; end if; Free (Full_Path_Name); end; end Locate_Directory; --------------------------- -- Find_Excluded_Sources -- --------------------------- procedure Find_Excluded_Sources (Project : in out Project_Processing_Data; Data : in out Tree_Processing_Data) is Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; Current : String_List_Id; Element : String_Element; Location : Source_Ptr; Name : File_Name_Type; File : GPR.Util.Text_File; Line : String (1 .. 300); Last : Natural; Locally_Removed : Boolean := False; Proj : Project_Id := Project.Project; begin -- Look for excluded sources in the current project and in all the -- projects that extend it. while Proj /= No_Project loop declare Excluded_Source_List_File : constant Variable_Value := Util.Value_Of (Name_Excluded_Source_List_File, Proj.Decl.Attributes, Shared); Excluded_Sources : Variable_Value := Util.Value_Of (Name_Excluded_Source_Files, Proj.Decl.Attributes, Shared); begin -- If Excluded_Source_Files is not declared, check -- Locally_Removed_Files. if Excluded_Sources.Default then Locally_Removed := True; Excluded_Sources := Util.Value_Of (Name_Locally_Removed_Files, Proj.Decl.Attributes, Shared); end if; -- If there are excluded sources, put them in the table if not Excluded_Sources.Default then if not Excluded_Source_List_File.Default then if Locally_Removed then Error_Msg (Data.Flags, "?both attributes Locally_Removed_Files and " & "Excluded_Source_List_File are present", Excluded_Source_List_File.Location, Proj); else Error_Msg (Data.Flags, "?both attributes Excluded_Source_Files and " & "Excluded_Source_List_File are present", Excluded_Source_List_File.Location, Proj); end if; end if; Current := Excluded_Sources.Values; while Current /= Nil_String loop Element := Shared.String_Elements.Table (Current); Name := Canonical_Case_File_Name (Element.Value); -- If the element has no location, then use the location of -- Excluded_Sources to report possible errors. if Element.Location = No_Location then Location := Excluded_Sources.Location; else Location := Element.Location; end if; Excluded_Sources_Htable.Set (Project.Excluded, Name, (Name, No_File, 0, False, Location, Proj)); Current := Element.Next; end loop; elsif not Excluded_Source_List_File.Default then Location := Excluded_Source_List_File.Location; declare Source_File_Name : constant File_Name_Type := File_Name_Type (Excluded_Source_List_File.Value); Source_File_Line : Natural := 0; Source_File_Path_Name : constant String := Path_Name_Of (Source_File_Name, Proj.Directory.Name); begin if Source_File_Path_Name'Length = 0 then Error_Msg_File_1 := File_Name_Type (Excluded_Source_List_File.Value); Error_Msg (Data.Flags, "file with excluded sources { does not exist", Excluded_Source_List_File.Location, Proj); else -- Open the file GPR.Util.Open (File, Source_File_Path_Name); if not GPR.Util.Is_Valid (File) then Error_Msg (Data.Flags, "file does not exist", Location, Proj); else -- Read the lines one by one while not GPR.Util.End_Of_File (File) loop GPR.Util.Get_Line (File, Line, Last); Source_File_Line := Source_File_Line + 1; -- Non empty, non comment line should contain a -- file name if Last /= 0 and then (Last = 1 or else Line (1 .. 2) /= "--") then Name_Len := Last; Name_Buffer (1 .. Name_Len) := Line (1 .. Last); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); Name := Name_Find; -- Check that there is no directory information for J in 1 .. Last loop if Is_Directory_Separator (Line (J)) then Error_Msg_File_1 := Name; Error_Msg (Data.Flags, "file name cannot include directory" & " information ({)", Location, Proj); exit; end if; end loop; Excluded_Sources_Htable.Set (Project.Excluded, Name, (Name, Source_File_Name, Source_File_Line, False, Location, Proj)); end if; end loop; GPR.Util.Close (File); end if; end if; end; end if; end; Proj := Proj.Extended_By; end loop; end Find_Excluded_Sources; ------------------ -- Find_Sources -- ------------------ procedure Find_Sources (Project : in out Project_Processing_Data; Data : in out Tree_Processing_Data) is Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; Sources : constant Variable_Value := Util.Value_Of (Name_Source_Files, Project.Project.Decl.Attributes, Shared); Source_List_File : constant Variable_Value := Util.Value_Of (Name_Source_List_File, Project.Project.Decl.Attributes, Shared); Name_Loc : Name_Location; Has_Explicit_Sources : Boolean; begin pragma Assert (Sources.Kind = List, "Source_Files is not a list"); pragma Assert (Source_List_File.Kind = Single, "Source_List_File is not a single string"); Project.Source_List_File_Location := Source_List_File.Location; -- If the user has specified a Source_Files attribute if not Sources.Default then if not Source_List_File.Default then Error_Msg (Data.Flags, "?both attributes Source_Files and Source_List_File are" & " present", Source_List_File.Location, Project.Project); end if; -- Sources is a list of file names declare Current : String_List_Id := Sources.Values; Element : String_Element; Location : Source_Ptr; Name : File_Name_Type; begin if Current = Nil_String then -- This project contains no source. For projects that don't -- extend other projects, this also means that there is no -- need for an object directory, if not specified. if Project.Project.Extends = No_Project and then Project.Project.Object_Directory = Project.Project.Directory and then not (Project.Project.Qualifier = Aggregate_Library) then Project.Project.Object_Directory := No_Path_Information; end if; end if; while Current /= Nil_String loop Element := Shared.String_Elements.Table (Current); Name := Canonical_Case_File_Name (Element.Value); Get_Name_String (Element.Value); -- If the element has no location, then use the location of -- Sources to report possible errors. if Element.Location = No_Location then Location := Sources.Location; else Location := Element.Location; end if; -- Check that there is no directory information for J in 1 .. Name_Len loop if Is_Directory_Separator (Name_Buffer (J)) then Error_Msg_File_1 := Name; Error_Msg (Data.Flags, "file name cannot include directory information ({)", Location, Project.Project); exit; end if; end loop; -- Check whether the file is already there: the same file name -- may be in the list. If the source is missing, the error will -- be on the first mention of the source file name. Name_Loc := Source_Names_Htable.Get (Project.Source_Names, Name); if Name_Loc = No_Name_Location then Name_Loc := (Name => Name, Location => Location, Source => No_Source, Listed => True, Found => False); else Name_Loc.Listed := True; end if; Source_Names_Htable.Set (Project.Source_Names, Name, Name_Loc); Current := Element.Next; end loop; Has_Explicit_Sources := True; end; -- If we have no Source_Files attribute, check the Source_List_File -- attribute. elsif not Source_List_File.Default then -- Source_List_File is the name of the file that contains the source -- file names. declare Source_File_Path_Name : constant String := Path_Name_Of (File_Name_Type (Source_List_File.Value), Project.Project. Directory.Display_Name); begin Has_Explicit_Sources := True; if Source_File_Path_Name'Length = 0 then Error_Msg_File_1 := File_Name_Type (Source_List_File.Value); Error_Msg (Data.Flags, "file with sources { does not exist", Source_List_File.Location, Project.Project); else Get_Sources_From_File (Source_File_Path_Name, Source_List_File.Location, Project, Data); end if; end; else -- Neither Source_Files nor Source_List_File has been specified. Find -- all the files that satisfy the naming scheme in all the source -- directories. Has_Explicit_Sources := False; end if; -- Remove any exception that is not in the specified list of sources if Has_Explicit_Sources then declare Source : Source_Id; Iter : Source_Iterator; NL : Name_Location; Again : Boolean; begin Iter_Loop : loop Again := False; Iter := For_Each_Source (Data.Tree, Project.Project); Source_Loop : loop Source := GPR.Element (Iter); exit Source_Loop when Source = No_Source; if Source.Naming_Exception /= No then NL := Source_Names_Htable.Get (Project.Source_Names, Source.File); if NL /= No_Name_Location and then not NL.Listed then -- Remove the exception Source_Names_Htable.Set (Project.Source_Names, Source.File, No_Name_Location); Remove_Source (Data.Tree, Source, No_Source); if Source.Naming_Exception = Yes then Error_Msg_Name_1 := Name_Id (Source.File); Error_Msg (Data.Flags, "? unknown source file %%", NL.Location, Project.Project); end if; Again := True; exit Source_Loop; end if; end if; Next (Iter); end loop Source_Loop; exit Iter_Loop when not Again; end loop Iter_Loop; end; end if; Search_Directories (Project, Data => Data, For_All_Sources => Sources.Default and then Source_List_File.Default); -- Check if all exceptions have been found declare Source : Source_Id; Iter : Source_Iterator; Found : Boolean := False; begin Iter := For_Each_Source (Data.Tree, Project.Project); loop Source := GPR.Element (Iter); exit when Source = No_Source; -- If the full source path is unknown for this source_id, there -- could be several reasons: -- * we simply did not find the file itself, this is an error -- * we have a multi-unit source file. Another Source_Id from -- the same file has received the full path, so we need to -- propagate it. if Source.Path = No_Path_Information then if Source.Naming_Exception = Yes then if Source.Unit /= No_Unit_Index then Found := False; if Source.Index /= 0 then -- Only multi-unit files declare S : Source_Id := Source_Files_Htable.Get (Data.Tree.Source_Files_HT, Source.File); begin while S /= null loop if S.Path /= No_Path_Information then Source.Path := S.Path; Found := True; if Current_Verbosity = High then Debug_Output ("setting full path for " & Get_Name_String_Safe (Source.File) & " at" & Source.Index'Img & " to " & Get_Name_String_Safe (Source.Path.Name)); end if; exit; end if; S := S.Next_With_File_Name; end loop; end; end if; if not Found then Error_Msg_Name_1 := Name_Id (Source.Display_File); Error_Msg_Name_2 := Source.Unit.Name; Error_Or_Warning (Data.Flags, Data.Flags.Missing_Source_Files, "\source file %% for unit %% not found", No_Location, Project.Project); end if; end if; if Source.Path = No_Path_Information then Remove_Source (Data.Tree, Source, No_Source); end if; elsif Source.Naming_Exception = Inherited then Remove_Source (Data.Tree, Source, No_Source); end if; end if; Next (Iter); end loop; end; -- It is an error if a source file name in a source list or in a source -- list file is not found. if Has_Explicit_Sources then declare NL : Name_Location; First_Error : Boolean; begin NL := Source_Names_Htable.Get_First (Project.Source_Names); First_Error := True; while NL /= No_Name_Location loop if not NL.Found then Error_Msg_File_1 := NL.Name; if First_Error then Error_Or_Warning (Data.Flags, Data.Flags.Missing_Source_Files, "source file { not found", NL.Location, Project.Project); First_Error := False; else Error_Or_Warning (Data.Flags, Data.Flags.Missing_Source_Files, "\source file { not found", NL.Location, Project.Project); end if; end if; NL := Source_Names_Htable.Get_Next (Project.Source_Names); end loop; end; end if; end Find_Sources; ---------------- -- Initialize -- ---------------- procedure Initialize (Data : out Tree_Processing_Data; Tree : Project_Tree_Ref; Node_Tree : GPR.Tree.Project_Node_Tree_Ref; Flags : GPR.Processing_Flags) is begin Data.Tree := Tree; Data.Node_Tree := Node_Tree; Data.Flags := Flags; end Initialize; ---------- -- Free -- ---------- procedure Free (Data : in out Tree_Processing_Data) is pragma Unreferenced (Data); begin null; end Free; ---------------- -- Initialize -- ---------------- procedure Initialize (Data : in out Project_Processing_Data; Project : Project_Id) is begin Data.Project := Project; end Initialize; ---------- -- Free -- ---------- procedure Free (Data : in out Project_Processing_Data) is begin Source_Names_Htable.Reset (Data.Source_Names); Unit_Exceptions_Htable.Reset (Data.Unit_Exceptions); Excluded_Sources_Htable.Reset (Data.Excluded); end Free; ------------------------------- -- Check_File_Naming_Schemes -- ------------------------------- procedure Check_File_Naming_Schemes (Project : Project_Processing_Data; File_Name : File_Name_Type; Alternate_Languages : out Language_List; Language : out Language_Ptr; Display_Language_Name : out Name_Id; Unit : out Name_Id; Lang_Kind : out Language_Kind; Kind : out Source_Kind) is Filename : constant String := Get_Name_String (File_Name); Config : Language_Config; Tmp_Lang : Language_Ptr; Header_File : Boolean := False; -- True if we found at least one language for which the file is a header -- In such a case, we search for all possible languages where this is -- also a header (C and C++ for instance), since the file might be used -- for several such languages. procedure Check_File_Based_Lang; -- Does the naming scheme test for file-based languages. For those, -- there is no Unit. Just check if the file name has the implementation -- or, if it is specified, the template suffix of the language. -- -- Returns True if the file belongs to the current language and we -- should stop searching for matching languages. Not that a given header -- file could belong to several languages (C and C++ for instance). Thus -- if we found a header we'll check whether it matches other languages. --------------------------- -- Check_File_Based_Lang -- --------------------------- procedure Check_File_Based_Lang is begin if not Header_File and then Suffix_Matches (Filename, Config.Naming_Data.Body_Suffix) then Unit := No_Name; Kind := Impl; Language := Tmp_Lang; Debug_Output ("implementation of language ", Display_Language_Name); elsif Suffix_Matches (Filename, Config.Naming_Data.Spec_Suffix) then Debug_Output ("header of language ", Display_Language_Name); if Header_File then Alternate_Languages := new Language_List_Element' (Language => Language, Next => Alternate_Languages); else Header_File := True; Kind := Spec; Unit := No_Name; Language := Tmp_Lang; end if; end if; end Check_File_Based_Lang; -- Start of processing for Check_File_Naming_Schemes begin Language := No_Language_Index; Alternate_Languages := null; Display_Language_Name := No_Name; Unit := No_Name; Lang_Kind := File_Based; Kind := Spec; Tmp_Lang := Project.Project.Languages; while Tmp_Lang /= No_Language_Index loop if Current_Verbosity = High then Debug_Output ("testing language " & Get_Name_String_Safe (Tmp_Lang.Name) & " Header_File=" & Header_File'Img); end if; Display_Language_Name := Tmp_Lang.Display_Name; Config := Tmp_Lang.Config; Lang_Kind := Config.Kind; case Config.Kind is when File_Based => Check_File_Based_Lang; exit when Kind = Impl; when Unit_Based => -- We know it belongs to a least a file_based language, no -- need to check unit-based ones. if not Header_File then Compute_Unit_Name (File_Name => File_Name, Naming => Config.Naming_Data, Kind => Kind, Unit => Unit, Project => Project); if Unit /= No_Name then Language := Tmp_Lang; exit; end if; end if; end case; Tmp_Lang := Tmp_Lang.Next; end loop; if Language = No_Language_Index then Debug_Output ("not a source of any language"); end if; end Check_File_Naming_Schemes; ------------------- -- Override_Kind -- ------------------- procedure Override_Kind (Source : Source_Id; Kind : Source_Kind) is begin -- If the file was previously already associated with a unit, change it if Source.Unit /= null and then Source.Kind in Spec_Or_Body and then Source.Unit.File_Names (Source.Kind) /= null then -- If we had another file referencing the same unit (for instance it -- was in an extended project), that source file is in fact invisible -- from now on, and in particular doesn't belong to the same unit. -- If the source is an inherited naming exception, then it may not -- really exist: the source potentially replaced is left untouched. if Source.Unit.File_Names (Source.Kind) /= Source then Source.Unit.File_Names (Source.Kind).Unit := No_Unit_Index; end if; Source.Unit.File_Names (Source.Kind) := null; end if; Source.Kind := Kind; if Current_Verbosity = High and then Source.File /= No_File then Debug_Output ("override kind for " & Get_Name_String_Safe (Source.File) & " idx=" & Source.Index'Img & " kind=" & Source.Kind'Img); end if; if Source.Unit /= null then if Source.Kind = Spec then Source.Unit.File_Names (Spec) := Source; else Source.Unit.File_Names (Impl) := Source; end if; end if; end Override_Kind; ---------------- -- Check_File -- ---------------- procedure Check_File (Project : in out Project_Processing_Data; Data : in out Tree_Processing_Data; Source_Dir_Rank : Natural; Path : Path_Name_Type; Display_Path : Path_Name_Type; File_Name : File_Name_Type; Display_File_Name : File_Name_Type; Locally_Removed : Boolean; For_All_Sources : Boolean) is Name_Loc : Name_Location := Source_Names_Htable.Get (Project.Source_Names, File_Name); Check_Name : Boolean := False; Alternate_Languages : Language_List; Language : Language_Ptr; Source : Source_Id; Src_Ind : Source_File_Index; Unit : Name_Id; Display_Language_Name : Name_Id; Lang_Kind : Language_Kind; Kind : Source_Kind := Spec; begin if Current_Verbosity = High then Debug_Increase_Indent ("checking file (rank=" & Source_Dir_Rank'Img & ")", Name_Id (Display_Path)); end if; if Name_Loc = No_Name_Location then -- Source_Dir_Rank = 0 mean that source file is from directory -- defined in --src-subdir parameter. Check_Name := For_All_Sources or else Source_Dir_Rank = 0; else if Name_Loc.Found then -- Check if it is OK to have the same file name in several -- source directories. if Name_Loc.Source /= No_Source and then Source_Dir_Rank = Name_Loc.Source.Source_Dir_Rank then Error_Msg_File_1 := File_Name; Error_Msg (Data.Flags, "{ is found in several source directories", Name_Loc.Location, Project.Project); end if; else Name_Loc.Found := True; Source_Names_Htable.Set (Project.Source_Names, File_Name, Name_Loc); if Name_Loc.Source = No_Source then Check_Name := True; else -- Set the full path for the source_id (which might have been -- created when parsing the naming exceptions, and therefore -- might not have the full path). -- We only set this for this source_id, but not for other -- source_id in the same file (case of multi-unit source files) -- For the latter, they will be set in Find_Sources when we -- check that all source_id have known full paths. -- Doing this later saves one htable lookup per file in the -- common case where the user is not using multi-unit files. Name_Loc.Source.Path := (Path, Display_Path); Source_Paths_Htable.Set (Data.Tree.Source_Paths_HT, Path, Name_Loc.Source); -- Check if this is a subunit if Name_Loc.Source.Unit /= No_Unit_Index and then Name_Loc.Source.Kind = Impl then Src_Ind := Sinput.Load_File (Get_Name_String (Display_Path)); if Source_File_Is_Subunit (Src_Ind) then Override_Kind (Name_Loc.Source, Sep); end if; end if; -- If this is an inherited naming exception, make sure that -- the naming exception it replaces is no longer a source. if Name_Loc.Source.Naming_Exception = Inherited then declare Proj : Project_Id := Name_Loc.Source.Project.Extends; Iter : Source_Iterator; Src : Source_Id; begin while Proj /= No_Project loop Iter := For_Each_Source (Data.Tree, Proj); Src := GPR.Element (Iter); while Src /= No_Source loop if Src.File = Name_Loc.Source.File then Src.Replaced_By := Name_Loc.Source; exit; end if; Next (Iter); Src := GPR.Element (Iter); end loop; Proj := Proj.Extends; end loop; end; if Name_Loc.Source.Unit /= No_Unit_Index then if Name_Loc.Source.Kind = Spec then Name_Loc.Source.Unit.File_Names (Spec) := Name_Loc.Source; elsif Name_Loc.Source.Kind = Impl then Name_Loc.Source.Unit.File_Names (Impl) := Name_Loc.Source; end if; Units_Htable.Set (Data.Tree.Units_HT, Name_Loc.Source.Unit.Name, Name_Loc.Source.Unit); end if; end if; end if; end if; end if; if Check_Name then Check_File_Naming_Schemes (Project => Project, File_Name => File_Name, Alternate_Languages => Alternate_Languages, Language => Language, Display_Language_Name => Display_Language_Name, Unit => Unit, Lang_Kind => Lang_Kind, Kind => Kind); if Language = No_Language_Index then -- A file name in a list must be a source of a language. if Data.Flags.Error_On_Unknown_Language and then not Languages_Are_Restricted and then Name_Loc.Found then Error_Msg_File_1 := File_Name; Error_Msg (Data.Flags, "language unknown for {", Name_Loc.Location, Project.Project); end if; else Add_Source (Id => Source, Project => Project.Project, Source_Dir_Rank => Source_Dir_Rank, Lang_Id => Language, Kind => Kind, Data => Data, Alternate_Languages => Alternate_Languages, File_Name => File_Name, Display_File => Display_File_Name, Unit => Unit, Locally_Removed => Locally_Removed, Path => (Path, Display_Path)); if Source /= null then Source.In_Src_Subdir := Source_Dir_Rank = 0; end if; -- If it is a source specified in a list, update the entry in -- the Source_Names table. if Name_Loc.Found and then Name_Loc.Source = No_Source then Name_Loc.Source := Source; Source_Names_Htable.Set (Project.Source_Names, File_Name, Name_Loc); end if; end if; end if; Debug_Decrease_Indent; end Check_File; --------------------------------- -- Expand_Subdirectory_Pattern -- --------------------------------- procedure Expand_Subdirectory_Pattern (Project : Project_Id; Data : in out Tree_Processing_Data; Patterns : String_List_Id; Ignore : String_List_Id; Search_For : Search_Type; Resolve_Links : Boolean; Callback : access procedure (Path : Path_Information; Pattern_Index : Natural)) is Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; package Recursive_Dirs renames Path_Name_HTable; -- Hash table stores recursive source directories, to avoid looking -- several times, and to avoid cycles that may be introduced by symbolic -- links. File_Pattern : GNAT.Regexp.Regexp; -- Pattern to use when matching file names Visited : Recursive_Dirs.Instance; procedure Find_Pattern (Pattern_Id : Name_Id; Rank : Natural; Location : Source_Ptr); -- Find a specific pattern function Recursive_Find_Dirs (Path : Path_Information; Rank : Natural) return Boolean; -- Search all the subdirectories (recursively) of Path. -- Return True if at least one file or directory was processed function Subdirectory_Matches (Path : Path_Information; Rank : Natural) return Boolean; -- Called when a matching directory was found. If the user is in fact -- searching for files, we then search for those files matching the -- pattern within the directory. -- Return True if at least one file or directory was processed -------------------------- -- Subdirectory_Matches -- -------------------------- function Subdirectory_Matches (Path : Path_Information; Rank : Natural) return Boolean is Dir : Dir_Type; Name : String (1 .. 250); Last : Natural; Found : Path_Information; Success : Boolean := False; begin case Search_For is when Search_Source_Directories => Callback (Path, Rank); return True; when Search_Project_Files => Open (Dir, Get_Name_String (Path.Display_Name)); loop Read (Dir, Name, Last); exit when Last = 0; if Name (Name'First .. Last) /= "." and then Name (Name'First .. Last) /= ".." and then Match (Name (Name'First .. Last), File_Pattern) then Get_Name_String (Path.Display_Name); Add_Str_To_Name_Buffer (Name (Name'First .. Last)); Found.Display_Name := Name_Find; Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); Found.Name := Name_Find; Callback (Found, Rank); Success := True; end if; end loop; Close (Dir); return Success; end case; exception when Directory_Error => return False; end Subdirectory_Matches; ------------------------- -- Recursive_Find_Dirs -- ------------------------- function Recursive_Find_Dirs (Path : Path_Information; Rank : Natural) return Boolean is Path_Str : constant String := Get_Name_String (Path.Display_Name); Dir : Dir_Type; Name : String (1 .. 250); Last : Natural; Success : Boolean := False; begin Debug_Output ("looking for subdirs of ", Name_Id (Path.Display_Name)); if Recursive_Dirs.Get (Visited, Path.Name) then return Success; end if; Recursive_Dirs.Set (Visited, Path.Name, True); Success := Subdirectory_Matches (Path, Rank) or Success; Open (Dir, Path_Str); loop Read (Dir, Name, Last); exit when Last = 0; if Name (1 .. Last) /= "." and then Name (1 .. Last) /= ".." then declare Path_Name : constant String := Normalize_Pathname (Name => Name (1 .. Last), Directory => Path_Str, Resolve_Links => Resolve_Links) & Directory_Separator; Path2 : Path_Information; OK : Boolean := True; begin if Is_Directory (Path_Name) then if Ignore /= Nil_String then declare Dir_Name : String := Name (1 .. Last); List : String_List_Id := Ignore; begin Canonical_Case_File_Name (Dir_Name); while List /= Nil_String loop Get_Name_String (Shared.String_Elements.Table (List).Value); if Name_Len > 0 then Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); File_Pattern := Compile (Name_Buffer (1 .. Name_Len), Glob => True, Case_Sensitive => File_Names_Case_Sensitive ); OK := not Match (Dir_Name, File_Pattern); exit when not OK; end if; List := Shared.String_Elements.Table (List).Next; end loop; end; end if; if OK then Path2.Display_Name := Get_Path_Name_Id (Path_Name); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); Path2.Name := Name_Find; Success := Recursive_Find_Dirs (Path2, Rank) or Success; end if; end if; end; end if; end loop; Close (Dir); return Success; exception when Directory_Error => return Success; end Recursive_Find_Dirs; ------------------ -- Find_Pattern -- ------------------ procedure Find_Pattern (Pattern_Id : Name_Id; Rank : Natural; Location : Source_Ptr) is Pattern : constant String := Get_Name_String (Pattern_Id); Pattern_End : Natural := Pattern'Last; Recursive : Boolean; Dir : File_Name_Type; Path_Name : Path_Information; Dir_Exists : Boolean; Success : Boolean; Has_Error : Boolean := False; Msg_Mode : Error_Warning; begin Debug_Increase_Indent ("Find_Pattern", Pattern_Id); -- If we are looking for files, find the pattern for the files if Search_For = Search_Project_Files then while Pattern_End >= Pattern'First and then not Is_Directory_Separator (Pattern (Pattern_End)) loop Pattern_End := Pattern_End - 1; end loop; if Pattern_End = Pattern'Last then Error_Msg_File_1 := File_Name_Type (Pattern_Id); Error_Or_Warning (Data.Flags, Data.Flags.Missing_Source_Files, "Missing file name or pattern in {", Location, Project); Debug_Decrease_Indent; return; end if; if Current_Verbosity = High then Debug_Indent; Write_Str ("file_pattern="); Write_Str (Pattern (Pattern_End + 1 .. Pattern'Last)); Write_Str (" dir_pattern="); Write_Line (Pattern (Pattern'First .. Pattern_End)); end if; File_Pattern := Compile (Pattern (Pattern_End + 1 .. Pattern'Last), Glob => True, Case_Sensitive => File_Names_Case_Sensitive); -- If we had just "*.gpr", this is equivalent to "./*.gpr" if Pattern_End > Pattern'First then Pattern_End := Pattern_End - 1; -- Skip directory separator end if; end if; Recursive := Pattern_End - 1 >= Pattern'First and then Pattern (Pattern_End - 1 .. Pattern_End) = "**" and then (Pattern_End - 1 = Pattern'First or else Is_Directory_Separator (Pattern (Pattern_End - 2))); if Recursive then Pattern_End := Pattern_End - 2; if Pattern_End > Pattern'First then Pattern_End := Pattern_End - 1; -- Skip '/' end if; end if; Name_Len := Pattern_End - Pattern'First + 1; Name_Buffer (1 .. Name_Len) := Pattern (Pattern'First .. Pattern_End); Dir := Name_Find; Locate_Directory (Project => Project, Name => Dir, Path => Path_Name, Dir_Exists => Dir_Exists, Data => Data, Must_Exist => False); if not Dir_Exists then Msg_Mode := (case Search_For is when Search_Source_Directories => Data.Flags.Missing_Source_Files, when Search_Project_Files => Data.Flags.Missing_Project_Files); Error_Or_Warning (Data.Flags, Msg_Mode, '"' & Mask_Control_Characters (Get_Name_String (Dir)) & """ is not a valid directory", Location, Project); Has_Error := Msg_Mode = Error; end if; if not Has_Error then -- Links have been resolved if necessary, and Path_Name -- always ends with a directory separator. if Recursive then Success := Recursive_Find_Dirs (Path_Name, Rank); else Success := Subdirectory_Matches (Path_Name, Rank); end if; if not Success then case Search_For is when Search_Source_Directories => null; -- Error can't occur when Search_Project_Files => Error_Or_Warning (Data.Flags, Data.Flags.Missing_Project_Files, "file """ & Mask_Control_Characters (Get_Name_String (Pattern_Id)) & """ not found", Location, Project); end case; end if; end if; Debug_Decrease_Indent ("done Find_Pattern"); end Find_Pattern; -- Local variables Pattern_Id : String_List_Id := Patterns; Element : String_Element; Rank : Natural := 1; -- Start of processing for Expand_Subdirectory_Pattern begin while Pattern_Id /= Nil_String loop Element := Shared.String_Elements.Table (Pattern_Id); if Element.Value /= No_Name then Find_Pattern (Element.Value, Rank, Element.Location); end if; Rank := Rank + 1; Pattern_Id := Element.Next; end loop; Recursive_Dirs.Reset (Visited); end Expand_Subdirectory_Pattern; ------------------------ -- Search_Directories -- ------------------------ procedure Search_Directories (Project : in out Project_Processing_Data; Data : in out Tree_Processing_Data; For_All_Sources : Boolean) is Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared; Source_Dir : String_List_Id; Element : String_Element; Src_Dir_Rank : Number_List_Index; Num_Nod : Number_Node; Dir : Dir_Type; Name : String (1 .. 1_000); Last : Natural; File_Name : File_Name_Type; Display_File_Name : File_Name_Type; begin Debug_Increase_Indent ("looking for sources of", Project.Project.Name); -- Loop through subdirectories Src_Dir_Rank := Project.Project.Source_Dir_Ranks; Source_Dir := Project.Project.Source_Dirs; while Source_Dir /= Nil_String loop begin Num_Nod := Shared.Number_Lists.Table (Src_Dir_Rank); Element := Shared.String_Elements.Table (Source_Dir); -- Use Element.Value in this test, not Display_Value, because we -- want the symbolic links to be resolved when appropriate. if Element.Value /= No_Name then declare Source_Directory : constant String := Get_Name_String (Element.Value) & Directory_Separator; Dir_Last : constant Natural := Compute_Directory_Last (Source_Directory); Display_Source_Directory : constant String := Get_Name_String (Element.Display_Value) & Directory_Separator; -- Display_Source_Directory is to allow us to open a UTF-8 -- encoded directory on Windows. begin if Current_Verbosity = High then Debug_Increase_Indent ("Source_Dir (node=" & Num_Nod.Number'Img & ") """ & Source_Directory (Source_Directory'First .. Dir_Last) & '"'); end if; -- We look to every entry in the source directory Open (Dir, Display_Source_Directory); loop Read (Dir, Name, Last); exit when Last = 0; -- In fast project loading mode (without -eL), the user -- guarantees that no directory has a name which is a -- valid source name, so we can avoid doing a system call -- here. This provides a very significant speed up on -- slow file systems (remote files for instance). if not Opt.Follow_Links_For_Files or else Is_Regular_File (Display_Source_Directory & Name (1 .. Last)) then Name_Len := Last; Name_Buffer (1 .. Name_Len) := Name (1 .. Last); Display_File_Name := Name_Find; if Osint.File_Names_Case_Sensitive then File_Name := Display_File_Name; else Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); File_Name := Name_Find; end if; declare Path_Name : constant String := Normalize_Pathname (Name (1 .. Last), Directory => Source_Directory (Source_Directory'First .. Dir_Last), Resolve_Links => Opt.Follow_Links_For_Files, Case_Sensitive => True); Path : Path_Name_Type; FF : File_Found := Excluded_Sources_Htable.Get (Project.Excluded, File_Name); To_Remove : Boolean := False; begin Name_Len := Path_Name'Length; Name_Buffer (1 .. Name_Len) := Path_Name; if Osint.File_Names_Case_Sensitive then Path := Name_Find; else Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); Path := Name_Find; end if; if FF /= No_File_Found then if not FF.Found then FF.Found := True; Excluded_Sources_Htable.Set (Project.Excluded, File_Name, FF); Debug_Output ("excluded source ", Name_Id (Display_File_Name)); -- Will mark the file as removed, but we -- still need to add it to the list: if we -- don't, the file will not appear in the -- mapping file and will cause the compiler -- to fail. To_Remove := True; end if; end if; -- Preserve the user's original casing and use of -- links. The display_value (a directory) already -- ends with a directory separator by construction, -- so no need to add one. Get_Name_String (Element.Display_Value); Get_Name_String_And_Append (Name_Id (Display_File_Name)); Check_File (Project => Project, Source_Dir_Rank => Num_Nod.Number, Data => Data, Path => Path, Display_Path => Name_Find, File_Name => File_Name, Locally_Removed => To_Remove, Display_File_Name => Display_File_Name, For_All_Sources => For_All_Sources); end; else if Current_Verbosity = High then Debug_Output ("ignore " & Name (1 .. Last)); end if; end if; end loop; Debug_Decrease_Indent; Close (Dir); end; end if; exception when Directory_Error => null; end; Source_Dir := Element.Next; Src_Dir_Rank := Num_Nod.Next; end loop; Debug_Decrease_Indent ("end looking for sources."); end Search_Directories; ---------------------------- -- Load_Naming_Exceptions -- ---------------------------- procedure Load_Naming_Exceptions (Project : in out Project_Processing_Data; Data : in out Tree_Processing_Data) is Source : Source_Id; Iter : Source_Iterator; begin Iter := For_Each_Source (Data.Tree, Project.Project); loop Source := GPR.Element (Iter); exit when Source = No_Source; -- An excluded file cannot also be an exception file name if Excluded_Sources_Htable.Get (Project.Excluded, Source.File) /= No_File_Found then Error_Msg_File_1 := Source.File; Error_Msg (Data.Flags, "\{ cannot be both excluded and an exception file name", No_Location, Project.Project); end if; Debug_Output ("naming exception: adding source file to source_Names: ", Name_Id (Source.File)); Source_Names_Htable.Set (Project.Source_Names, K => Source.File, E => Name_Location' (Name => Source.File, Location => Source.Location, Source => Source, Listed => False, Found => False)); -- If this is an Ada exception, record in table Unit_Exceptions if Source.Unit /= No_Unit_Index then declare Unit_Except : Unit_Exception := Unit_Exceptions_Htable.Get (Project.Unit_Exceptions, Source.Unit.Name); begin Unit_Except.Name := Source.Unit.Name; if Source.Kind = Spec then Unit_Except.Spec := Source.File; else Unit_Except.Impl := Source.File; end if; Unit_Exceptions_Htable.Set (Project.Unit_Exceptions, Source.Unit.Name, Unit_Except); end; end if; Next (Iter); end loop; end Load_Naming_Exceptions; ---------------------- -- Look_For_Sources -- ---------------------- procedure Look_For_Sources (Project : in out Project_Processing_Data; Data : in out Tree_Processing_Data) is Object_Files : Object_File_Names_Htable.Instance; Iter : Source_Iterator; Src : Source_Id; procedure Check_Object (Src : Source_Id); -- Check if object file name of Src is already used in the project tree, -- and report an error if so. procedure Check_Object_Files; -- Check that no two sources of this project have the same object file procedure Mark_Excluded_Sources; -- Mark as such the sources that are declared as excluded procedure Check_Missing_Sources; -- Check whether one of the languages has no sources, and report an -- error when appropriate procedure Get_Sources_From_Source_Info; -- Get the source information from the tables that were created when a -- source info file was read. --------------------------- -- Check_Missing_Sources -- --------------------------- procedure Check_Missing_Sources is Extending : constant Boolean := Project.Project.Extends /= No_Project; Language : Language_Ptr; Source : Source_Id; Alt_Lang : Language_List; Continuation : Boolean := False; Iter : Source_Iterator; begin if not Project.Project.Externally_Built and then not Extending then Language := Project.Project.Languages; while Language /= No_Language_Index loop if Is_Allowed_Language (Language.Name) then -- If there are no sources for this language, check if there -- are sources for which this is an alternate language. if Language.First_Source = No_Source and then (Data.Flags.Require_Sources_Other_Lang or else Language.Name = Name_Ada) then Iter := For_Each_Source (In_Tree => Data.Tree, Project => Project.Project); Source_Loop : loop Source := Element (Iter); exit Source_Loop when Source = No_Source or else Source.Language = Language; Alt_Lang := Source.Alternate_Languages; while Alt_Lang /= null loop exit Source_Loop when Alt_Lang.Language = Language; Alt_Lang := Alt_Lang.Next; end loop; Next (Iter); end loop Source_Loop; if Source = No_Source then Report_No_Sources (Project.Project, Get_Name_String (Language.Display_Name), Data, Project.Source_List_File_Location, Continuation); Continuation := True; end if; end if; end if; Language := Language.Next; end loop; end if; end Check_Missing_Sources; ------------------ -- Check_Object -- ------------------ procedure Check_Object (Src : Source_Id) is Source : Source_Id; begin Source := Object_File_Names_Htable.Get (Object_Files, Src.Object); -- We cannot just check on "Source /= Src", since we might have -- two different entries for the same file (and since that's -- the same file it is expected that it has the same object) if Source /= No_Source and then Source.Replaced_By = No_Source and then Source.Path /= Src.Path and then Source.Index = 0 and then Src.Index = 0 and then Is_Extending (Src.Project, Source.Project) then Error_Msg_File_1 := Src.File; Error_Msg_File_2 := Source.File; Error_Msg (Data.Flags, "\{ and { have the same object file name", No_Location, Project.Project); else Object_File_Names_Htable.Set (Object_Files, Src.Object, Src); end if; end Check_Object; --------------------------- -- Mark_Excluded_Sources -- --------------------------- procedure Mark_Excluded_Sources is Source : Source_Id := No_Source; Excluded : File_Found; Proj : Project_Id; begin -- Minor optimization: if there are no excluded files, no need to -- traverse the list of sources. We cannot however also check whether -- the existing exceptions have ".Found" set to True (indicating we -- found them before) because we need to do some final processing on -- them in any case. if Excluded_Sources_Htable.Get_First (Project.Excluded) /= No_File_Found then -- The excluded files are not only those declared in the current -- project, but also those declared in the projects that extend -- the current project, if there are any. Proj := Project.Project; while Proj /= No_Project loop Iter := For_Each_Source (Data.Tree, Proj); while GPR.Element (Iter) /= No_Source loop Source := GPR.Element (Iter); Excluded := Excluded_Sources_Htable.Get (Project.Excluded, Source.File); if Excluded /= No_File_Found then Source.In_Interfaces := False; Source.Locally_Removed := True; if Proj = Project.Project then Source.Suppressed := True; end if; if Current_Verbosity = High then Debug_Indent; Write_Str ("removing file "); Write_Line (Get_Name_String_Safe (Excluded.File) & " " & Get_Name_String_Safe (Source.Project.Name)); end if; Excluded_Sources_Htable.Remove (Project.Excluded, Source.File); end if; Next (Iter); end loop; Proj := Proj.Extends; end loop; end if; -- If we have any excluded element left, that means we did not find -- the source file Excluded := Excluded_Sources_Htable.Get_First (Project.Excluded); while Excluded /= No_File_Found loop if not Excluded.Found then -- Check if the file belongs to another imported project to -- provide a better error message. Src := GPR.Find_Source (In_Tree => Data.Tree, Project => Project.Project, In_Imported_Only => True, Base_Name => Excluded.File); if (Src = No_Source and then Excluded.Project = Project.Project) or else Src /= No_Source then Error_Msg_File_1 := Excluded.File; Error_Msg (Data.Flags, (if Excluded.Excl_File = No_File then "" else "in " & Get_Name_String_Safe (Excluded.Excl_File) & ':' & No_Space_Img (Excluded.Excl_Line) & ": ") & (if Src = No_Source then "unknown file {" else "cannot remove a source from an imported project" & ": {"), Excluded.Location, Project.Project); end if; end if; Excluded := Excluded_Sources_Htable.Get_Next (Project.Excluded); end loop; end Mark_Excluded_Sources; ------------------------ -- Check_Object_Files -- ------------------------ procedure Check_Object_Files is Iter : Source_Iterator; Src_Id : Source_Id; Src_Ind : Source_File_Index; begin Iter := For_Each_Source (Data.Tree); loop Src_Id := GPR.Element (Iter); exit when Src_Id = No_Source; if Is_Compilable (Src_Id) and then Src_Id.Language.Config.Object_Generated and then Is_Extending (Project.Project, Src_Id.Project) then if Src_Id.Unit = No_Unit_Index then if Src_Id.Kind = Impl then Check_Object (Src_Id); end if; else case Src_Id.Kind is when Spec => if Other_Part (Src_Id) = No_Source then Check_Object (Src_Id); end if; when Sep => null; when Impl => if Other_Part (Src_Id) /= No_Source then Check_Object (Src_Id); else -- Check if it is a subunit Src_Ind := Sinput.Load_File (Get_Name_String (Src_Id.Path.Display_Name)); if Source_File_Is_Subunit (Src_Ind) then Override_Kind (Src_Id, Sep); else Check_Object (Src_Id); end if; end if; end case; end if; end if; Next (Iter); end loop; end Check_Object_Files; ---------------------------------- -- Get_Sources_From_Source_Info -- ---------------------------------- procedure Get_Sources_From_Source_Info is Iter : Source_Info_Iterator; Src : Source_Info; Id : Source_Id; Lang_Id : Language_Ptr; begin Initialize (Iter, Project.Project.Name); loop Src := Source_Info_Of (Iter); exit when Src = No_Source_Info; Id := new Source_Data; Id.Project := Project.Project; Lang_Id := Project.Project.Languages; while Lang_Id /= No_Language_Index and then Lang_Id.Name /= Src.Language loop Lang_Id := Lang_Id.Next; end loop; if Lang_Id = No_Language_Index then GPR.Com.Fail ("unknown language " & Get_Name_String (Src.Language) & " for project " & Get_Name_String (Src.Project) & " in source info file"); end if; Id.Language := Lang_Id; Id.Kind := Src.Kind; Id.Index := Src.Index; Id.Path := (Display_Name => Path_Name_Type (Src.Display_Path_Name), Name => Path_Name_Type (Src.Path_Name)); Id.File := Get_File_Name_Id (Directories.Simple_Name (Get_Name_String (Src.Path_Name))); Id.Next_With_File_Name := Source_Files_Htable.Get (Data.Tree.Source_Files_HT, Id.File); Source_Files_Htable.Set (Data.Tree.Source_Files_HT, Id.File, Id); Id.Display_File := Get_File_Name_Id (Directories.Simple_Name (Get_Name_String (Src.Display_Path_Name))); Id.Dep_Name := Dependency_Name (Id.File, Id.Language.Config.Dependency_Kind); Id.Naming_Exception := Src.Naming_Exception; Id.Object := Object_Name (Id.File, Id.Language.Config.Object_File_Suffix); Id.Switches := Switches_Name (Id.File); -- Add the source id to the Unit_Sources_HT hash table, if the -- unit name is not null. if Src.Unit_Name /= No_Name then declare UData : Unit_Index := Units_Htable.Get (Data.Tree.Units_HT, Src.Unit_Name); begin if UData = No_Unit_Index then UData := new Unit_Data; UData.Name := Src.Unit_Name; Units_Htable.Set (Data.Tree.Units_HT, Src.Unit_Name, UData); end if; Id.Unit := UData; end; -- Note that this updates Unit information as well Override_Kind (Id, Id.Kind); end if; if Src.Index /= 0 then Project.Project.Has_Multi_Unit_Sources := True; end if; -- Add the source to the language list Id.Next_In_Lang := Id.Language.First_Source; Id.Language.First_Source := Id; Next (Iter); end loop; end Get_Sources_From_Source_Info; -- Start of processing for Look_For_Sources begin if Data.Tree.Source_Info_File_Exists then Get_Sources_From_Source_Info; else if Project.Project.Source_Dirs /= Nil_String then Find_Excluded_Sources (Project, Data); if Project.Project.Languages /= No_Language_Index then Load_Naming_Exceptions (Project, Data); Find_Sources (Project, Data); Mark_Excluded_Sources; Check_Object_Files; Check_Missing_Sources; end if; end if; Object_File_Names_Htable.Reset (Object_Files); end if; end Look_For_Sources; ------------------ -- Path_Name_Of -- ------------------ function Path_Name_Of (File_Name : File_Name_Type; Directory : Path_Name_Type) return String is Result : String_Access; The_Directory : constant String := Get_Name_String (Directory); begin Debug_Output ("Path_Name_Of file name=", Name_Id (File_Name)); Debug_Output ("Path_Name_Of directory=", Name_Id (Directory)); Get_Name_String (File_Name); Result := Locate_Regular_File (File_Name => Name_Buffer (1 .. Name_Len), Path => The_Directory); if Result = null then return ""; else declare R : constant String := Result.all; begin Free (Result); return R; end; end if; end Path_Name_Of; ------------------- -- Remove_Source -- ------------------- procedure Remove_Source (Tree : Project_Tree_Ref; Id : Source_Id; Replaced_By : Source_Id) is Source : Source_Id; begin if Current_Verbosity = High then Debug_Indent; Write_Str ("removing source "); Write_Str (Get_Name_String (Id.File)); if Id.Index /= 0 then Write_Str (" at" & Id.Index'Img); end if; Write_Eol; end if; if Replaced_By /= No_Source then Id.Replaced_By := Replaced_By; Replaced_By.Declared_In_Interfaces := Id.Declared_In_Interfaces; if Id.File /= Replaced_By.File then declare Replacement : constant File_Name_Type := Replaced_Source_HTable.Get (Tree.Replaced_Sources, Id.File); begin Replaced_Source_HTable.Set (Tree.Replaced_Sources, Id.File, Replaced_By.File); if Replacement = No_File then Tree.Replaced_Source_Number := Tree.Replaced_Source_Number + 1; end if; end; end if; end if; Id.In_Interfaces := False; Id.Locally_Removed := True; -- ??? Should we remove the source from the unit ? The file is not used, -- so probably should not be referenced from the unit. On the other hand -- it might give useful additional info -- if Id.Unit /= null then -- Id.Unit.File_Names (Id.Kind) := null; -- end if; Source := Id.Language.First_Source; if Source = Id then Id.Language.First_Source := Id.Next_In_Lang; else -- Do not crash if the source cannot be found while Source /= No_Source and then Source.Next_In_Lang /= Id loop Source := Source.Next_In_Lang; end loop; if Source /= No_Source then Source.Next_In_Lang := Id.Next_In_Lang; end if; end if; end Remove_Source; ----------------------- -- Report_No_Sources -- ----------------------- procedure Report_No_Sources (Project : Project_Id; Lang_Name : String; Data : Tree_Processing_Data; Location : Source_Ptr; Continuation : Boolean := False) is Language_Name : String (1 .. Lang_Name'Length * 2); Language_Last : Natural := 0; begin -- Make sure that the language name will be displayed as is in the -- error message and not modified, for example if it is in capital -- letters. for J in Lang_Name'Range loop Language_Last := Language_Last + 1; Language_Name (Language_Last) := '''; Language_Last := Language_Last + 1; Language_Name (Language_Last) := Lang_Name (J); end loop; case Data.Flags.When_No_Sources is when Silent | Decide_Later => null; when Warning | Error => Error_Msg_Warn := Data.Flags.When_No_Sources = Warning; Error_Msg (Data.Flags, (if Continuation then "\" else "") & " Get_Object_Directory (Project, Data); Check_Aggregated; if Project.Object_Directory = No_Path_Information then Project.Object_Directory := Project.Directory; end if; when others => Get_Directories (Project, Data, No_Sources); Check_Programming_Languages (Project, Data); if Current_Verbosity = High then Show_Source_Dirs (Project, Shared); end if; if Project.Qualifier = Abstract_Project then Check_Abstract_Project (Project, Data); end if; end case; -- Check configuration. Check_Configuration (Project, Data); if not Data.Flags.Check_Configuration_Only then if Project.Qualifier /= Aggregate then -- Externally built projects are allowed to be library projects -- even when they have no sources. No_Sources := No_Sources and then not Project.Externally_Built; -- A project with no sources cannot be a library project if No_Sources and then Project.Qualifier = Library then Error_Msg (Data.Flags, "a project with no sources cannot be a library project", Project.Location, Project); else Check_Library_Attributes (Project, No_Sources, Data); end if; Check_Package_Naming (Project, Data); -- An aggregate library has no source, no need to look for them if Project.Qualifier /= Aggregate_Library then Look_For_Sources (Prj_Data, Data); end if; Check_Interfaces (Project, Data); -- If this library is part of an aggregated library don't check -- it as it has no sources by itself and so interface won't be -- found. if Project.Library and not In_Aggregate_Lib then Check_Stand_Alone_Library (Project, Data); end if; Get_Mains (Project, Data); end if; Free (Prj_Data); end if; Debug_Decrease_Indent ("done check"); end Check; --------------------- -- Recursive_Check -- --------------------- procedure Recursive_Check (Project : Project_Id; Prj_Tree : Project_Tree_Ref; Context : Project_Context; Data : in out Tree_Processing_Data) is begin if Current_Verbosity = High then Debug_Increase_Indent ("Processing_Naming_Scheme for project", Project.Name); end if; Data.Tree := Prj_Tree; Data.In_Aggregate_Lib := Context.In_Aggregate_Lib; Check (Project, Context.In_Aggregate_Lib, Data); if Current_Verbosity = High then Debug_Decrease_Indent ("done Processing_Naming_Scheme"); end if; end Recursive_Check; procedure Check_All_Projects is new For_Every_Project_Imported_Context (Tree_Processing_Data, Recursive_Check); -- Comment required??? -- Local Variables Data : Tree_Processing_Data; -- Start of processing for Process_Naming_Scheme begin Lib_Data_Table.Init; Initialize (Data, Tree => Tree, Node_Tree => Node_Tree, Flags => Flags); Check_All_Projects (Root_Project, Tree, Data, Imported_First => True); Free (Data); -- Adjust language configs for projects that are extended declare List : Project_List; Proj : Project_Id; Exte : Project_Id; Lang : Language_Ptr; Elng : Language_Ptr; begin List := Tree.Projects; while List /= null loop Proj := List.Project; Exte := Proj; while Exte.Extended_By /= No_Project loop Exte := Exte.Extended_By; end loop; if Exte /= Proj then Lang := Proj.Languages; if Lang /= No_Language_Index then loop Elng := Get_Language_From_Name (Exte, Get_Name_String (Lang.Name)); exit when Elng /= No_Language_Index; Exte := Exte.Extends; end loop; if Elng /= Lang then Lang.Config := Elng.Config; end if; end if; end if; List := List.Next; end loop; end; end Process_Naming_Scheme; end GPR.Nmsc; gprbuild-25.0.0/gpr/src/gpr-nmsc.ads000066400000000000000000000064631470075373400172270ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2000-2021, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- Find source dirs and source files for a project with GPR.Tree; private package GPR.Nmsc is procedure Process_Naming_Scheme (Tree : Project_Tree_Ref; Root_Project : Project_Id; Node_Tree : GPR.Tree.Project_Node_Tree_Ref; Flags : Processing_Flags); -- Perform consistency and semantic checks on all the projects in the tree. -- This procedure interprets the various case statements in the project -- based on the current external references. After checking the validity of -- the naming scheme, it searches for all the source files of the project. -- The result of this procedure is a filled-in data structure for -- Project_Id which contains all the information about the project. This -- information is only valid while the external references are preserved. procedure Process_Aggregated_Projects (Tree : Project_Tree_Ref; Project : Project_Id; Node_Tree : GPR.Tree.Project_Node_Tree_Ref; Flags : Processing_Flags); -- Assuming Project is an aggregate project, find out (based on the -- current external references) what are the projects it aggregates. -- This has to be done in phase 1 of the processing, so that we know the -- full list of languages required for root_project and its aggregated -- projects. As a result, it cannot be done as part of -- Process_Naming_Scheme. procedure Messages_Decision (Kind : Decided_Message); -- Decide what to do with messages issued with Decide_Later kind end GPR.Nmsc; gprbuild-25.0.0/gpr/src/gpr-opt.ads000066400000000000000000000316461470075373400170720ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2021, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ pragma Warnings (Off); with System.WCh_Con; use System.WCh_Con; pragma Warnings (On); package GPR.Opt is Brief_Output : Boolean := False; -- Force brief error messages to standard error, even if verbose mode is -- set (so that main error messages go to standard output). ---------------------- -- Checksum Control -- ---------------------- -- Checksums are computed for sources to check for sources being the same -- from a compilation point of view (e.g. spelling of identifiers and -- white space layout do not count in this computation). -- The way the checksum is computed has evolved across the various versions -- of GNAT. When gprbuild is called with -m, the checksums must be computed -- the same way in gprbuild as it was in the GNAT version of the compiler. -- The different ways are -- Version 6.4 and later: -- The Accumulate_Token_Checksum procedure is called after each numeric -- literal and each identifier/keyword. For keywords, Tok_Identifier is -- used in the call to Accumulate_Token_Checksum. -- Versions 5.04 to 6.3: -- For keywords, the token value were used in the call to procedure -- Accumulate_Token_Checksum. Type Token_Type did not include Tok_Some. -- Versions 5.03: -- For keywords, the token value were used in the call to -- Accumulate_Token_Checksum. Type Token_Type did not include -- Tok_Interface, Tok_Overriding, Tok_Synchronized and Tok_Some. -- Versions 5.02 and before: -- No calls to procedure Accumulate_Token_Checksum (the checksum -- mechanism was introduced in version 5.03). -- To signal to the scanner whether Accumulate_Token_Checksum needs to be -- called and what versions to call, the following Boolean flags are used: Checksum_Accumulate_Token_Checksum : Boolean := True; -- Set to False by gprbuild when the version of GNAT is 5.02 or before. If -- this switch is False, then we do not call Accumulate_Token_Checksum, so -- the setting of the following two flags is irrelevant. Checksum_GNAT_6_3 : Boolean := False; -- Set to True by gprbuild when the version of GNAT is 6.3 or before. Checksum_GNAT_5_03 : Boolean := False; -- Set to True by gprbuild when the version of GNAT is 5.03 or before. Compile_Only : Boolean := False; -- GPBUILD: -- set True to skip bind and link steps (except when Bind_Only is True) -- GPRCLEAN: -- set True to delete only the files produced by the compiler but not the -- library files or the executable files. Bind_Only : Boolean := False; -- Set to True to skip compile and link steps -- (except when Compile_Only and/or Link_Only are True). Check_Switches : Boolean := False; -- Set to True to check compiler options during the make process CodePeer_Mode : Boolean := False; -- Enable full CodePeer mode (SCIL generation, disable switches that -- interact badly with it, etc...). This is turned on by -gnatC. Directories_Must_Exist_In_Projects : Boolean := True; -- Set to False with switch -f of gnatclean and gprclean Display_Compilation_Progress : Boolean := False; -- Set True (-d switch) to display information on progress while compiling -- files. Internal flag to be used in conjunction with an IDE (e.g GPS). Follow_Links_For_Files : Boolean := False; -- Set to True (-eL) to process the project files in trusted mode. If -- Follow_Links is False, it is assumed that the project doesn't contain -- any file duplicated through symbolic links (although the latter are -- still valid if they point to a file which is outside of the project), -- and that no directory has a name which is a valid source name. Follow_Links_For_Dirs : Boolean := False; -- Set to True if directories can be links in this project, and therefore -- additional system calls must be performed to ensure that we always see -- the same full name for each directory. Force_Compilations : Boolean := False; -- Set to force recompilations even when the objects are up-to-date. Full_Path_Name_For_Brief_Errors : Boolean := False; -- When True, in Brief_Output mode, each error message line will start with -- the full path name of the source. When False, only the file name without -- directory information is used. GnatProve_Mode : Boolean := False; -- Enable GnatProve mode: the .ali files are copied to the lib dir even -- when only compilation is performed. Ignore_Predefined_Units : Boolean := False; -- Ignore predefined Ada units in gprname. -- Set by switch --ignore-predefined-units. Ignore_Duplicate_Files : Boolean := False; -- Ignore filenames with the same basename and only keep the first one. -- Set by switch --ignore-duplicate-files. Implicit_With : String_Access; -- Add the given project as a dependency on all loaded projects Keep_Going : Boolean := False; -- When True signals to ignore compilation errors and keep processing -- sources until there is no more work. Keep_Temporary_Files : Boolean := False; -- When True the temporary files are not deleted. Set by switches -dn or -- --keep-temp-files. Link_Only : Boolean := False; -- Set to True to skip compile and bind steps (except when Bind_Only is -- set to True). Maximum_Compilers : aliased Positive := 1; -- Maximum number of processes that should be spawned to carry out -- compilations. Maximum_Binders : aliased Positive := 1; -- Maximum number of processes that should be spawned to carry out -- bindings. Maximum_Linkers : aliased Positive := 1; -- Maximum number of processes that should be spawned to carry out -- linkings. Use_GNU_Make_Jobserver : Boolean := False; -- Set to True if GPRbuild should use GNU make Jobserver for sharing job -- slots. Autodetect_Jobserver : Boolean := False; -- Set to True if GPRbuild should attempt to connect to GNU make Jobserver Minimal_Recompilation : Boolean := False; -- Set to True if minimal recompilation mode requested Checksum_Recompilation : Boolean := False; -- Set to True if checksum-based recompilation mode requested No_Backup : Boolean := False; -- Do not create backup copies of project files in gprname. -- Set by switch --no-backup. No_Main_Subprogram : Boolean := False; -- Set to True if compilation/binding of a program without main -- subprogram requested. No_Split_Units : Boolean := False; -- Set to True with switch --no-split-units. When True, unit sources, spec, -- body and subunits, must all be in the same project. This is checked -- after each compilation. One_Compilation_Per_Obj_Dir : Boolean := False; -- Set to True with switch --single-compile-per-obj-dir. When True, there -- cannot be simultaneous compilations with the object files in the same -- object directory, if project files are used. Quiet_Output : Boolean := False; -- Set to True if the tool should not have any output if there are no -- errors or warnings. Run_Path_Option : Boolean := True; -- Set to False when no run_path_option should be issued to the linker type Dir_Creation_Mode is (Create_All_Dirs, -- Indicate that the Project Manager needs to creates -- non existing object, library and exec directories. -- (Command line option "-p") Create_Relative_Dirs_Only, -- The Project Manager should create only directories that are -- relative to the project directory. This is the desirable value -- for tools whose primary vocation is to generate artefacts in these -- directories. Never_Create_Dirs -- Never create directories. ); Create_Dirs : Dir_Creation_Mode := Never_Create_Dirs; -- Which directories we can create type Origin_Of_Target is (Unknown, Default, Specified); Target_Origin : Origin_Of_Target := Unknown; -- Indicates the origin of attribute Target in project files Target_Value : String_Access := null; -- Indicates the value of attribute Target in project files Target_Value_Canonical : String_Access := null; -- Canonical value of specified target Unchecked_Shared_Lib_Imports : Boolean := False; -- Set to True when shared library projects are allowed to import projects -- that are not shared library projects. Set on by use of the switch -- --unchecked-shared-lib-imports. Use_Include_Path_File : Boolean := False; -- When True, create a source search path file, even when a mapping file -- is used. Verbose_Mode : Boolean := False; -- Set to True to get verbose mode (full error message text and location -- information sent to standard output, also header, copyright and summary) type Verbosity_Level_Type is (None, Low, Medium, High); pragma Ordered (Verbosity_Level_Type); Verbosity_Level : Verbosity_Level_Type := None; -- Modified by gnatmake or gprmake switches -v, -vl, -vm, -vh. Indicates -- the level of verbosity of informational messages: -- -- In Low Verbosity, the reasons why a source is recompiled, the name -- of the executable and the reason it must be rebuilt is output. -- -- In Medium Verbosity, additional lines are output for each ALI file -- that is checked. -- -- In High Verbosity, additional lines are output when the ALI file -- is part of an Ada library, is read-only or is part of the runtime. No_Exit_Message : Boolean := False; -- Set with switch --no-exit-message. When True, if there are compilation -- failures, the builder does not issue an exit error message. type Warning_Mode_Type is (Suppress, Normal, Treat_As_Error); Warning_Mode : 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, warning messages are -- generated and are treated as errors. Note that Warning_Mode = Suppress -- causes pragma Warnings to be ignored (except for legality checks), -- unless we are in GNATprove_Mode, which requires pragma Warnings to -- be stored for the formal verification backend. Wide_Character_Encoding_Method : WC_Encoding_Method := WCEM_Brackets; -- Method used for encoding wide characters in the source program. See -- description of type in unit System.WCh_Con for a list of the methods -- that are currently supported. Note that brackets notation is always -- recognized in source programs regardless of the setting of this -- variable. The default setting causes only the brackets notation to be -- recognized. If this is the main unit, this setting also controls the -- output of the W=? parameter in the ALI file, which is used to provide -- the default for encoding [Wide_[Wide_]]Text_IO files. For the binder, -- the value set here overrides this main unit default. Wide_Character_Encoding_Method_Specified : Boolean := False; -- Set True if the value in Wide_Character_Encoding_Method was set as -- a result of an explicit -gnatW? or -W? switch. False otherwise. end GPR.Opt; gprbuild-25.0.0/gpr/src/gpr-osint.adb000066400000000000000000000437441470075373400174050ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2022, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; use Ada.Command_Line; with Ada.Directories; use Ada.Directories; with Ada.Unchecked_Conversion; with System.CRTL; with System.OS_Constants; with GNAT.Case_Util; use GNAT.Case_Util; with GPR.Names; use GPR.Names; with GPR.Output; use GPR.Output; package body GPR.Osint is Current_Full_Lib_Name : File_Name_Type := No_File; function File_Length (Name : C_File_Name; Attr : access File_Attributes) return Long_Integer; -- Return the length (number of bytes) of the file procedure Find_File (N : File_Name_Type; Found : out File_Name_Type; Attr : access File_Attributes); function Is_Regular_File (Name : C_File_Name; Attr : access File_Attributes) return Boolean; function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type; -- Convert OS format time to GNAT format time stamp. If T is Invalid_Time, -- then returns Empty_Time_Stamp. -- Round to even seconds on Windows before conversion. -- Windows ALI files had timestamps rounded to even seconds historically. -- The rounding was originally done in GM_Split. Now that GM_Split no -- longer does it, we are rounding it here only for ALI files. ------------------------------ -- Canonical_Case_File_Name -- ------------------------------ procedure Canonical_Case_File_Name (S : in out String) is begin if not File_Names_Case_Sensitive then To_Lower (S); end if; end Canonical_Case_File_Name; ------------------------------ -- Canonical_Case_File_Name -- ------------------------------ function Canonical_Case_File_Name (S : String) return String is begin return Result : String := S do Canonical_Case_File_Name (Result); end return; end Canonical_Case_File_Name; --------------------------------- -- Canonical_Case_Env_Var_Name -- --------------------------------- procedure Canonical_Case_Env_Var_Name (S : in out String) is begin if not Env_Vars_Case_Sensitive then To_Lower (S); end if; end Canonical_Case_Env_Var_Name; --------------------- -- Executable_Name -- --------------------- function Executable_Name (Name : File_Name_Type; Only_If_No_Suffix : Boolean := False) return File_Name_Type is Exec_Suffix : String_Access; Add_Suffix : Boolean; begin if Name = No_File then return No_File; end if; if Executable_Extension_On_Target = No_Name then Exec_Suffix := Get_Target_Executable_Suffix; else Get_Name_String (Executable_Extension_On_Target); Exec_Suffix := new String'(Name_Buffer (1 .. Name_Len)); end if; if Exec_Suffix'Length /= 0 then Get_Name_String (Name); Add_Suffix := True; if Only_If_No_Suffix then for J in reverse 1 .. Name_Len loop if Name_Buffer (J) = '.' then Add_Suffix := False; exit; end if; exit when Is_Directory_Separator (Name_Buffer (J)); end loop; end if; if Add_Suffix then declare Buffer : String := Name_Buffer (1 .. Name_Len); begin -- Get the file name in canonical case to accept as is. Names -- end with ".EXE" on Windows. Canonical_Case_File_Name (Buffer); -- If Executable doesn't end with the executable suffix, add it if Buffer'Length <= Exec_Suffix'Length or else Buffer (Buffer'Last - Exec_Suffix'Length + 1 .. Buffer'Last) /= Exec_Suffix.all then Name_Buffer (Name_Len + 1 .. Name_Len + Exec_Suffix'Length) := Exec_Suffix.all; Name_Len := Name_Len + Exec_Suffix'Length; Free (Exec_Suffix); return Name_Find; end if; end; end if; end if; Free (Exec_Suffix); return Name; end Executable_Name; ------------------ -- Exit_Program -- ------------------ procedure Exit_Program (Exit_Code : Exit_Code_Type) is begin -- Some exit codes can't be used because they have special meaning: -- exit code 2 means that the program was terminated by SIGINT signal; -- exit code 3 means that it was terminated by abort on Windows or by -- SIGQUIT on Linux; -- exit code 6 means that it was terminated by SIGABRT signal. OS_Exit (case Exit_Code is when E_Success => 0, when E_General => 1, when E_Subtool => 4, when E_Project => 5, when E_Fatal => 7); end Exit_Program; ---------- -- Fail -- ---------- procedure Fail (S : String) is Fatal_Exit : constant := 4; begin Set_Standard_Error; Write_Str (Simple_Name (Command_Name)); Write_Str (": "); Write_Line (S); OS_Exit (Fatal_Exit); end Fail; ----------------- -- File_Length -- ----------------- function File_Length (Name : C_File_Name; Attr : access File_Attributes) return Long_Integer is function Internal (F : Integer; N : C_File_Name; A : System.Address) return System.CRTL.int64; pragma Import (C, Internal, "__gnat_file_length_attr"); begin -- The conversion from int64 to Long_Integer is ok here as this -- routine is only to be used by the compiler and we do not expect -- a unit to be larger than a 32bit integer. return Long_Integer (Internal (-1, Name, Attr.all'Address)); end File_Length; ---------------- -- File_Stamp -- ---------------- function File_Stamp (Name : String) return Time_Stamp_Type is begin -- File_Time_Stamp will always return Invalid_Time if the file does -- not exist, and OS_Time_To_GNAT_Time will convert this value to -- Empty_Time_Stamp. Therefore we do not need to first test whether -- the file actually exists, which saves a system call. return OS_Time_To_GNAT_Time (File_Time_Stamp (Name)); end File_Stamp; function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type is begin if Name = No_File then return Empty_Time_Stamp; end if; return File_Stamp (Get_Name_String (Name)); end File_Stamp; function File_Stamp (Name : Path_Name_Type) return Time_Stamp_Type is begin return File_Stamp (File_Name_Type (Name)); end File_Stamp; --------------------- -- File_Time_Stamp -- --------------------- function File_Time_Stamp (Name : C_File_Name; Attr : access File_Attributes) return OS_Time is function Internal (N : C_File_Name; A : System.Address) return OS_Time; pragma Import (C, Internal, "__gnat_file_time_name_attr"); begin return Internal (Name, Attr.all'Address); end File_Time_Stamp; function File_Time_Stamp (Name : Path_Name_Type; Attr : access File_Attributes) return Time_Stamp_Type is begin if Name = No_Path then return Empty_Time_Stamp; end if; Get_Name_String (Name); Name_Buffer (Name_Len + 1) := ASCII.NUL; return OS_Time_To_GNAT_Time (File_Time_Stamp (Name_Buffer'Address, Attr)); end File_Time_Stamp; --------------------- -- File_Time_Stamp -- --------------------- function File_Time_Stamp (Name : String) return Ada.Calendar.Time is FN : aliased constant String := Name & ASCII.NUL; begin -- Do not use Ada.Directories.Modification_Time directly because it -- raises an exception on an absent file. return File_Time_Stamp (FN'Address); end File_Time_Stamp; --------------- -- Find_File -- --------------- procedure Find_File (N : File_Name_Type; Found : out File_Name_Type; Attr : access File_Attributes) is begin Attr.all := Unknown_Attributes; Get_Name_String (N); Name_Buffer (Name_Len + 1) := ASCII.NUL; if not Is_Regular_File (Name_Buffer (1)'Address, Attr) then Found := No_File; Attr.all := Unknown_Attributes; else Found := N; end if; end Find_File; ------------------- -- Get_Directory -- ------------------- function Get_Directory (Name : File_Name_Type) return File_Name_Type is begin Get_Name_String (Name); for J in reverse 1 .. Name_Len loop if Is_Directory_Separator (Name_Buffer (J)) then Name_Len := J; return Name_Find; end if; end loop; Name_Len := 2; Name_Buffer (1) := '.'; Name_Buffer (2) := Directory_Separator; return Name_Find; end Get_Directory; ---------------------------- -- Is_Directory_Separator -- ---------------------------- function Is_Directory_Separator (C : Character) return Boolean is begin return C in Directory_Separator | '/'; end Is_Directory_Separator; ------------------- -- Is_File_Empty -- ------------------- function Is_File_Empty (Name : Path_Name_Type) return Boolean is begin return (Size (Get_Name_String (Name)) = 0); end Is_File_Empty; --------------------- -- Is_Regular_File -- --------------------- function Is_Regular_File (Name : C_File_Name; Attr : access File_Attributes) return Boolean is function Internal (N : C_File_Name; A : System.Address) return Integer; pragma Import (C, Internal, "__gnat_is_regular_file_attr"); begin return Internal (Name, Attr.all'Address) /= 0; end Is_Regular_File; -------------------------- -- OS_Time_To_GNAT_Time -- -------------------------- function OS_Time_To_GNAT_Time (T : OS_Time) return Time_Stamp_Type is use System.OS_Constants; type Int_Time is range -(2 ** (size_t'Size - Integer'(1))) .. +(2 ** (size_t'Size - Integer'(1)) - 1); function To_C is new Ada.Unchecked_Conversion (OS_Time, Int_Time); function To_Ada is new Ada.Unchecked_Conversion (Int_Time, OS_Time); -- We need these routines to stay compatible with GNAT Community which -- doesn't yet have GNAT.OS_Lib.To_C/To_Ada routines. TS : Time_Stamp_Type; Y : Year_Type; Mo : Month_Type; D : Day_Type; H : Hour_Type; Mn : Minute_Type; S : Second_Type; Z : constant := Character'Pos ('0'); function Even_T return OS_Time with Inline; -- If T is odd integer increase it by one and return. -- See OS_Time_To_GNAT_Time declaration comment for details. ------------ -- Even_T -- ------------ function Even_T return OS_Time is TI : constant Int_Time := To_C (T); begin return To_Ada (if TI mod 2 > 0 then TI + 1 else TI); end Even_T; -- Start of processing for OS_Time_To_GNAT_Time begin if T = GNAT.OS_Lib.Invalid_Time then return Empty_Time_Stamp; end if; GM_Split ((if Target_OS = Windows then Even_T else T), Y, Mo, D, H, Mn, S); TS (01) := Character'Val (Z + Y / 1000); TS (02) := Character'Val (Z + (Y / 100) mod 10); TS (03) := Character'Val (Z + (Y / 10) mod 10); TS (04) := Character'Val (Z + Y mod 10); TS (05) := Character'Val (Z + Mo / 10); TS (06) := Character'Val (Z + Mo mod 10); TS (07) := Character'Val (Z + D / 10); TS (08) := Character'Val (Z + D mod 10); TS (09) := Character'Val (Z + H / 10); TS (10) := Character'Val (Z + H mod 10); TS (11) := Character'Val (Z + Mn / 10); TS (12) := Character'Val (Z + Mn mod 10); TS (13) := Character'Val (Z + S / 10); TS (14) := Character'Val (Z + S mod 10); return TS; end OS_Time_To_GNAT_Time; ----------------------- -- Read_Library_Info -- ----------------------- function Read_Library_Info (Lib_File : File_Name_Type; Fatal_Err : Boolean := False) return Text_Buffer_Ptr is File : File_Name_Type; Attr : aliased File_Attributes; begin Find_File (Lib_File, File, Attr'Access); return Read_Library_Info_From_Full (Full_Lib_File => File, Lib_File_Attr => Attr'Access, Fatal_Err => Fatal_Err); end Read_Library_Info; --------------------------------- -- Read_Library_Info_From_Full -- --------------------------------- function Read_Library_Info_From_Full (Full_Lib_File : File_Name_Type; Lib_File_Attr : access File_Attributes; Fatal_Err : Boolean := False) return Text_Buffer_Ptr is Lib_FD : File_Descriptor; -- The file descriptor for the current library file. A negative value -- indicates a failure to open the specified source file. Len : Integer; -- Length of source file text (ALI). If it doesn't fit in an integer -- we're probably stuck anyway (>2 gigs of source seems a lot, and -- there are other places in the compiler that make this assumption). Text : Text_Buffer_Ptr; -- Allocated text buffer Status : Boolean; pragma Warnings (Off, Status); -- For the calls to Close begin Current_Full_Lib_Name := Full_Lib_File; if Current_Full_Lib_Name = No_File then if Fatal_Err then Fail ("Cannot find: " & Name_Buffer (1 .. Name_Len)); else return null; end if; end if; Get_Name_String (Current_Full_Lib_Name); Name_Buffer (Name_Len + 1) := ASCII.NUL; -- Open the library FD, note that we open in binary mode, because as -- documented in the spec, the caller is expected to handle either -- DOS or Unix mode files, and there is no point in wasting time on -- text translation when it is not required. Lib_FD := Open_Read (Name_Buffer'Address, Binary); if Lib_FD = Invalid_FD then if Fatal_Err then Fail ("Cannot open: " & Name_Buffer (1 .. Name_Len)); else return null; end if; end if; -- Compute the length of the file (potentially also preparing other data -- like the timestamp and whether the file is read-only, for future use) Len := Integer (File_Length (Name_Buffer'Address, Lib_File_Attr)); -- Read data from the file declare Actual_Len : Integer := 0; Lo : constant Text_Ptr := 0; -- Low bound for allocated text buffer Hi : Text_Ptr := Text_Ptr (Len); -- High bound for allocated text buffer. Note length is Len + 1 -- which allows for extra EOF character at the end of the buffer. begin -- Allocate text buffer. Note extra character at end for EOF Text := new Text_Buffer (Lo .. Hi); -- Some systems have file types that require one read per line, -- so read until we get the Len bytes or until there are no more -- characters. Hi := Lo; loop Actual_Len := Read (Lib_FD, Text (Hi)'Address, Len); Hi := Hi + Text_Ptr (Actual_Len); exit when Actual_Len = Len or else Actual_Len <= 0; end loop; Text (Hi) := EOF; end; -- Read is complete, close file and we are done Close (Lib_FD, Status); -- The status should never be False. But, if it is, what can we do? -- So, we don't test it. return Text; end Read_Library_Info_From_Full; ------------------ -- Strip_Suffix -- ------------------ function Strip_Suffix (Name : File_Name_Type) return File_Name_Type is begin Get_Name_String (Name); for J in reverse 2 .. Name_Len loop -- If we found the last '.', return part of Name that precedes it if Name_Buffer (J) = '.' then Name_Len := J - 1; return File_Name_Type (Name_Enter); end if; end loop; return Name; end Strip_Suffix; ---------------------------- -- Package Initialization -- ---------------------------- procedure Reset_File_Attributes (Attr : System.Address); pragma Import (C, Reset_File_Attributes, "__gnat_reset_attributes"); begin Reset_File_Attributes (Unknown_Attributes'Address); end GPR.Osint; gprbuild-25.0.0/gpr/src/gpr-osint.ads000066400000000000000000000275321470075373400174230ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2022, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package contains low level, operating system routines with Ada.Calendar; with Ada.Unchecked_Deallocation; package GPR.Osint is ----------------------------------------- -- Types Used for Text Buffer Handling -- ----------------------------------------- -- We can not use type String for text buffers, since we must use the -- standard 32-bit integer as an index value, since we count on all -- index values being the same size. subtype Text_Ptr is Source_Ptr; -- Type used for subscripts in text buffer type Text_Buffer is array (Text_Ptr range <>) of Character; -- Text buffer used to hold source file or library information file type Text_Buffer_Ptr is access all Text_Buffer; -- Text buffers for input files are allocated dynamically and this type -- is used to reference these text buffers. procedure Free is new Ada.Unchecked_Deallocation (Text_Buffer, Text_Buffer_Ptr); -- Procedure for freeing dynamically allocated text buffers ------------------------------------------ -- Types Used for Source Input Handling -- ------------------------------------------ type Line_Number is range 0 .. Int'Last; for Line_Number'Size use 32; No_Line_Number : constant Line_Number := 0; -- Special value used to indicate no line number type Column_Number is range 0 .. 32767; for Column_Number'Size use 16; -- Column number (assume that 2**15 - 1 is large enough). The range for -- this type is used to compute Hostparm.Max_Line_Length. See also the -- processing for -gnatyM in Stylesw). No_Column_Number : constant Column_Number := 0; -- Special value used to indicate no column number Source_Align : constant := 2 ** 12; -- Alignment requirement for source buffers (by keeping source buffers -- aligned, we can optimize the implementation of Get_Source_File_Index. -- See this routine in Sinput for details. subtype Source_Buffer is Text_Buffer; -- Type used to store text of a source file. The buffer for the main source -- (the source specified on the command line) has a lower bound starting -- at zero. Subsequent subsidiary sources have lower bounds which are -- one greater than the previous upper bound, rounded up to a multiple -- of Source_Align. subtype Big_Source_Buffer is Text_Buffer (0 .. Text_Ptr'Last); -- This is a virtual type used as the designated type of the access type -- Source_Buffer_Ptr, see Osint.Read_Source_File for details. type Source_Buffer_Ptr is access all Big_Source_Buffer; -- Pointer to source buffer. We use virtual origin addressing for source -- buffers, with thin pointers. The pointer points to a virtual instance -- of type Big_Source_Buffer, where the actual type is in fact of type -- Source_Buffer. The address is adjusted so that the virtual origin -- addressing works correctly. See Osint.Read_Source_Buffer for further -- details. Again, as for Big_String_Ptr, we should never allocate using -- this type, but we don't give a storage size clause of zero, since we -- may end up doing deallocations of instances allocated manually. function Is_Directory_Separator (C : Character) return Boolean with Inline; -- Return True iff C is a directory separator inj a path function Get_Directory (Name : File_Name_Type) return File_Name_Type; -- Get the prefix directory name (if any) from Name. The last separator -- is preserved. Return the normalized current directory if there is no -- directory part in the name. function Executable_Name (Name : File_Name_Type; Only_If_No_Suffix : Boolean := False) return File_Name_Type; -- Given a file name it adds the appropriate suffix at the end so that -- it becomes the name of the executable on the system at end. For -- instance under DOS it adds the ".exe" suffix, whereas under UNIX no -- suffix is added. function Strip_Suffix (Name : File_Name_Type) return File_Name_Type; -- Strips the suffix (the last '.' and whatever comes after it) from -- Name. Returns the stripped name. function Read_Library_Info (Lib_File : File_Name_Type; Fatal_Err : Boolean := False) return Text_Buffer_Ptr; -- Allocates a Text_Buffer of appropriate length and reads in the entire -- source of the library information from the library information file -- whose name is given by the parameter Name. -- -- See description of Read_Source_File for details on the format of the -- returned text buffer (the format is identical). The lower bound of -- the Text_Buffer is always zero -- -- If the specified file cannot be opened, then the action depends on -- Fatal_Err. If Fatal_Err is True, an error message is given and the -- compilation is abandoned. Otherwise if Fatal_Err is False, then null -- is returned. Note that the Lib_File is a simple name which does not -- include any directory information. The implementation is responsible -- for searching for the file in appropriate directories. -- -- If Opt.Check_Object_Consistency is set to True then this routine -- checks whether the object file corresponding to the Lib_File is -- consistent with it. The object file is inconsistent if the object -- does not exist or if it has an older time stamp than Lib_File. This -- check is not performed when the Lib_File is "locked" (i.e. read/only) -- because in this case the object file may be buried in a library. In -- case of inconsistencies Read_Library_Info behaves as if it did not -- find Lib_File (namely if Fatal_Err is False, null is returned). function Read_Library_Info_From_Full (Full_Lib_File : File_Name_Type; Lib_File_Attr : access File_Attributes; Fatal_Err : Boolean := False) return Text_Buffer_Ptr; procedure Fail (S : String); pragma No_Return (Fail); -- Outputs error message S preceded by the name of the executing program -- and exits with E_Fatal. The output goes to standard error, except if -- special output is in effect (see Output). function Get_File_Names_Case_Sensitive return Int; pragma Import (C, Get_File_Names_Case_Sensitive, "__gnat_get_file_names_case_sensitive"); File_Names_Case_Sensitive : constant Boolean := Get_File_Names_Case_Sensitive /= 0; -- Set to indicate whether the operating system convention is for file -- names to be case sensitive (e.g., in Unix, set True), or non case -- sensitive (e.g., in Windows, set False). function Get_Env_Vars_Case_Sensitive return Int; pragma Import (C, Get_Env_Vars_Case_Sensitive, "__gnat_get_env_vars_case_sensitive"); Env_Vars_Case_Sensitive : constant Boolean := Get_Env_Vars_Case_Sensitive /= 0; -- Set to indicate whether the operating system convention is for -- environment variable names to be case sensitive (e.g., in Unix, set -- True), or non case sensitive (e.g., in Windows, set False). procedure Canonical_Case_File_Name (S : in out String); -- Given a file name, converts it to canonical case form. For systems -- where file names are case sensitive, this procedure has no effect. -- If file names are not case sensitive (i.e. for example if you have -- the file "xyz.adb", you can refer to it as XYZ.adb or XyZ.AdB), then -- this call converts the given string to canonical all lower case form, -- so that two file names compare equal if they refer to the same file. function Canonical_Case_File_Name (S : String) return String; -- Idem, but function procedure Canonical_Case_Env_Var_Name (S : in out String); -- Given an environment variable name, converts it to canonical -- case form. For systems where environment variable names are case -- sensitive, this procedure has no effect. If environment variable -- names are not case sensitive, then this call converts the given -- string to canonical all lower case form, so that two environment -- variable names compare equal if they refer to the same environment -- variable. function File_Time_Stamp (Name : C_File_Name; Attr : access File_Attributes) return OS_Time; function File_Time_Stamp (Name : Path_Name_Type; Attr : access File_Attributes) return Time_Stamp_Type; -- Return the time stamp of the file Invalid_Time : constant Ada.Calendar.Time; function File_Time_Stamp (Name : String) return Ada.Calendar.Time; -- Returns file last modification time with nanoseconds precision. -- Returns Invalid_Time on error. function File_Stamp (Name : File_Name_Type) return Time_Stamp_Type; -- Returns the time stamp of file Name. Name should include relative -- path information in order to locate it. If the source file cannot be -- opened, or Name = No_File, and all blank time stamp is returned (this -- is not an error situation). function File_Stamp (Name : Path_Name_Type) return Time_Stamp_Type; -- Same as above for a path name function File_Stamp (Name : String) return Time_Stamp_Type; -- Same as above for a string filename function Is_File_Empty (Name : Path_Name_Type) return Boolean; -- Returns true if the file size is 0, returns false otherwise type Exit_Code_Type is (E_Success, -- No errors (but there may be warnings) E_General, -- General tool error (invalid option, missing file, etc) E_Subtool, -- Underlying tool error E_Project, -- Project parsing error E_Fatal); -- Critical tool error (defensive code failures and the like) procedure Exit_Program (Exit_Code : Exit_Code_Type); pragma No_Return (Exit_Program); -- A call to Exit_Program terminates execution with the given status. -- A status of zero indicates normal completion, a non-zero status -- indicates abnormal termination. private function File_Time_Stamp (N : C_File_Name) return Ada.Calendar.Time with Import, Convention => C, External_Name => "__gnat_file_time"; Invalid_Time : constant Ada.Calendar.Time := File_Time_Stamp (System.Null_Address); end GPR.Osint; gprbuild-25.0.0/gpr/src/gpr-output.adb000066400000000000000000000177361470075373400176130ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2015, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ package body GPR.Output is Buffer_Max : constant := 32767; Buffer : String (1 .. Buffer_Max + 1) := (others => '*'); for Buffer'Alignment use 4; -- Buffer used to build output line. Next_Col : Positive range 1 .. Buffer'Length + 1 := 1; -- Column about to be written Current_FD : File_Descriptor := Standout; -- File descriptor for current output Special_Output_Proc : Output_Proc := null; -- Record argument to last call to Set_Special_Output. If this is -- non-null, then we are in special output mode. ----------------------- -- Local_Subprograms -- ----------------------- procedure Flush_Buffer; -- Flush buffer if non-empty and reset column counter procedure Set_Output (FD : File_Descriptor); -- Sets subsequent output to appear on the given file descriptor when no -- special output is in effect. When a special output is in effect, the -- output will appear on the given file descriptor only after special -- output has been cancelled. --------------------------- -- Cancel_Special_Output -- --------------------------- procedure Cancel_Special_Output is begin Special_Output_Proc := null; end Cancel_Special_Output; ------------ -- Column -- ------------ function Column return Pos is begin return Pos (Next_Col); end Column; ------------------ -- Flush_Buffer -- ------------------ procedure Flush_Buffer is Write_Error : exception; -- Raised if Write fails ------------------ -- Write_Buffer -- ------------------ procedure Write_Buffer (Buf : String); -- Write out Buf, either using Special_Output_Proc, or the normal way -- using Write. Raise Write_Error if Write fails (presumably due to disk -- full). Write_Error is not used in the case of Special_Output_Proc. procedure Write_Buffer (Buf : String) is begin -- If Special_Output_Proc has been set, then use it if Special_Output_Proc /= null then Special_Output_Proc.all (Buf); -- If output is not set, then output to either standard output -- or standard error. elsif Write (Current_FD, Buf'Address, Buf'Length) /= Buf'Length then raise Write_Error; end if; end Write_Buffer; Len : constant Natural := Next_Col - 1; -- Start of processing for Flush_Buffer begin if Len /= 0 then begin -- If line is too long or if it's a blank line, just write the -- buffer. if Len > Buffer_Max or else Buffer (1 .. Len) = (1 => ASCII.LF) then Write_Buffer (Buffer (1 .. Len)); -- Otherwise, construct a new buffer with preceding spaces, and -- write that. else Write_Buffer (Buffer (1 .. Len)); end if; exception when Write_Error => -- If there are errors with standard error just quit. Otherwise -- set the output to standard error before reporting a failure -- and quitting. if Current_FD /= Standerr then Current_FD := Standerr; Next_Col := 1; Write_Line ("fatal error: disk full"); end if; OS_Exit (2); end; -- Buffer is now empty Next_Col := 1; end if; end Flush_Buffer; ------------------------ -- Set_Special_Output -- ------------------------ procedure Set_Special_Output (P : Output_Proc) is begin Special_Output_Proc := P; end Set_Special_Output; ---------------- -- Set_Output -- ---------------- procedure Set_Output (FD : File_Descriptor) is begin if Special_Output_Proc = null then Flush_Buffer; end if; Current_FD := FD; end Set_Output; ------------------------ -- Set_Standard_Error -- ------------------------ procedure Set_Standard_Error is begin Set_Output (Standerr); end Set_Standard_Error; ------------------------- -- Set_Standard_Output -- ------------------------- procedure Set_Standard_Output is begin Set_Output (Standout); end Set_Standard_Output; ---------------- -- Write_Char -- ---------------- procedure Write_Char (C : Character) is begin pragma Assert (Next_Col in Buffer'Range); if Next_Col = Buffer'Length then Write_Eol; end if; if C = ASCII.LF then Write_Eol; else Buffer (Next_Col) := C; Next_Col := Next_Col + 1; end if; end Write_Char; --------------- -- Write_Eol -- --------------- procedure Write_Eol is begin -- Remove any trailing spaces while Next_Col > 1 and then Buffer (Next_Col - 1) = ' ' loop Next_Col := Next_Col - 1; end loop; Buffer (Next_Col) := ASCII.LF; Next_Col := Next_Col + 1; Flush_Buffer; end Write_Eol; --------------- -- Write_Int -- --------------- procedure Write_Int (Val : Int) is -- Type Int has one extra negative number (i.e. two's complement), so we -- work with negative numbers here. Otherwise, negating Int'First will -- overflow. subtype Nonpositive is Int range Int'First .. 0; procedure Write_Abs (Val : Nonpositive); -- Write out the absolute value of Val procedure Write_Abs (Val : Nonpositive) is begin if Val < -9 then Write_Abs (Val / 10); -- Recursively write higher digits end if; Write_Char (Character'Val (-(Val rem 10) + Character'Pos ('0'))); end Write_Abs; begin if Val < 0 then Write_Char ('-'); Write_Abs (Val); else Write_Abs (-Val); end if; end Write_Int; ---------------- -- Write_Line -- ---------------- procedure Write_Line (S : String) is begin Write_Str (S); Write_Eol; end Write_Line; --------------- -- Write_Str -- --------------- procedure Write_Str (S : String) is begin for J in S'Range loop Write_Char (S (J)); end loop; end Write_Str; end GPR.Output; gprbuild-25.0.0/gpr/src/gpr-output.ads000066400000000000000000000130301470075373400176130ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2015, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package contains low level output routines for writing error messages -- and informational output. pragma Warnings (Off); -- This package is used also by GNATCOLL.Projects with System.OS_Lib; use System.OS_Lib; pragma Warnings (On); package GPR.Output is pragma Elaborate_Body; type Output_Proc is access procedure (S : String); -- This type is used for the Set_Special_Output procedure. If Output_Proc -- is called, then instead of lines being written to standard error or -- standard output, a call is made to the given procedure for each line, -- passing the line with an end of line character (which is a single -- ASCII.LF character, even in systems which normally use CR/LF or some -- other sequence for line end). ----------------- -- Subprograms -- ----------------- procedure Set_Special_Output (P : Output_Proc); -- Sets subsequent output to call procedure P. If P is null, then the call -- cancels the effect of a previous call, reverting the output to standard -- error or standard output depending on the mode at the time of previous -- call. Any exception generated by calls to P is simply propagated to -- the caller of the routine causing the write operation. procedure Cancel_Special_Output; -- Cancels the effect of a call to Set_Special_Output, if any. The output -- is then directed to standard error or standard output depending on the -- last call to Set_Standard_Error or Set_Standard_Output. It is never an -- error to call Cancel_Special_Output. It has the same effect as calling -- Set_Special_Output (null). procedure Set_Standard_Error; -- Sets subsequent output to appear on the standard error file (whatever -- that might mean for the host operating system, if anything) when -- no special output is in effect. When a special output is in effect, -- the output will appear on standard error only after special output -- has been cancelled. procedure Set_Standard_Output; -- Sets subsequent output to appear on the standard output file (whatever -- that might mean for the host operating system, if anything) when no -- special output is in effect. When a special output is in effect, the -- output will appear on standard output only after special output has been -- cancelled. Output to standard output is the default mode before any call -- to either of the Set procedures. function Column return Pos; pragma Inline (Column); -- Returns the number of the column about to be written (e.g. a value of 1 -- means the current line is empty). procedure Write_Char (C : Character); -- Write one character to the standard output file. If the character is LF, -- this is equivalent to Write_Eol. procedure Write_Eol; -- Write an end of line (whatever is required by the system in use, e.g. -- CR/LF for DOS, or LF for Unix) to the standard output file. This routine -- also empties the line buffer, actually writing it to the file. Note that -- Write_Eol is the only routine that causes any actual output to be -- written. Trailing spaces are removed. procedure Write_Int (Val : Int); -- Write an integer value with no leading blanks or zeroes. Negative values -- are preceded by a minus sign). procedure Write_Str (S : String); -- Write a string of characters to the standard output file. Note that -- end of line is normally handled separately using WRITE_EOL, but it is -- allowable for the string to contain LF (but not CR) characters, which -- are properly interpreted as end of line characters. The string may also -- contain horizontal tab characters. procedure Write_Line (S : String); -- Equivalent to Write_Str (S) followed by Write_Eol; end GPR.Output; gprbuild-25.0.0/gpr/src/gpr-part.adb000066400000000000000000002402621470075373400172110ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2022, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Directories; with Ada.Exceptions; use Ada.Exceptions; with GNAT.Directory_Operations; with GNAT.HTable; use GNAT.HTable; with GNAT.Table; with GPR.Opt; use GPR.Opt; with GPR.Com; use GPR.Com; with GPR.Dect; with GPR.Env; use GPR.Env; with GPR.Err; use GPR.Err; with GPR.Erroutc; use GPR.Erroutc; with GPR.Names; use GPR.Names; with GPR.Osint; use GPR.Osint; with GPR.Output; use GPR.Output; with GPR.Scans; use GPR.Scans; with GPR.Sinput; use GPR.Sinput; with GPR.Snames; with GPR.Util; use GPR.Util; package body GPR.Part is Buffer : String_Access; Buffer_Last : Natural := 0; Dir_Sep : Character renames GNAT.OS_Lib.Directory_Separator; ------------------------------------ -- Local Packages and Subprograms -- ------------------------------------ type With_Id is new Nat; No_With : constant With_Id := 0; type With_Record is record Path : Path_Name_Type; Location : Source_Ptr; Limited_With : Boolean; Node : Project_Node_Id; Next : With_Id; end record; -- Information about an imported project, to be put in table Withs below package Withs is new GNAT.Table (Table_Component_Type => With_Record, Table_Index_Type => With_Id, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 100); -- Table used to store temporarily paths and locations of imported -- projects. These imported projects will be effectively parsed later: just -- before parsing the current project for the non limited withed projects, -- after getting its name; after complete parsing of the current project -- for the limited withed projects. type Names_And_Id is record Path_Name : Path_Name_Type; Canonical_Path_Name : Path_Name_Type; Id : Project_Node_Id; Limited_With : Boolean; end record; package Project_Stack is new GNAT.Table (Table_Component_Type => Names_And_Id, Table_Index_Type => Nat, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 100); -- This table is used to detect circular dependencies -- for imported and extended projects and to get the project ids of -- limited imported projects when there is a circularity with at least -- one limited imported project file. package Virtual_Hash is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, Element => Project_Node_Id, No_Element => Project_Node_High_Bound, Key => Project_Node_Id, Hash => GPR.Tree.Hash, Equal => "="); -- Hash table to store the node ids of projects for which a virtual -- extending project need to be created. The corresponding value is the -- head of a list of WITH clauses corresponding to the context of the -- enclosing EXTEND ALL projects. Note: Default_Element is Project_Node_ -- High_Bound because we want Empty_Node to be a possible value. package Processed_Hash is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, Element => Boolean, No_Element => False, Key => Project_Node_Id, Hash => GPR.Tree.Hash, Equal => "="); -- Hash table to store the project process when looking for project that -- need to have a virtual extending project, to avoid processing the same -- project twice. package Resolved_Paths is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, Element => Path_Name_Type, No_Element => No_Path, Key => Path_Name_Type, Hash => GPR.Hash, Equal => "="); type Name_And_Path is record Name : Name_Id := No_Name; Path : Path_Name_Type := No_Path; end record; package Extended_Projects is new GNAT.Table (Table_Component_Type => Name_And_Path, Table_Index_Type => Nat, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 100); -- A table to record projects with their path in a chain of extending -- projects to detect two different projects with the same names in the -- chain, as this is a error. function Has_Circular_Dependencies (Flags : Processing_Flags; Normed_Path_Name : Path_Name_Type; Canonical_Path_Name : Path_Name_Type) return Boolean; -- Check for a circular dependency in the loaded project. -- Generates an error message in such a case. procedure Read_Project_Qualifier (Flags : Processing_Flags; In_Tree : Project_Node_Tree_Ref; Is_Config_File : Boolean; Qualifier_Location : out Source_Ptr; Project : Project_Node_Id); -- Check if there is a qualifier before the reserved word "project" -- Hash table to cache project path to avoid looking for them on the path procedure Check_Extending_All_Imports (Flags : Processing_Flags; In_Tree : Project_Node_Tree_Ref; Project : Project_Node_Id); -- Check that a non extending-all project does not import an -- extending-all project. procedure Check_Aggregate_Imports (Flags : Processing_Flags; In_Tree : Project_Node_Tree_Ref; Project : Project_Node_Id); -- Check that an aggregate project only imports abstract projects procedure Check_Import_Aggregate (Flags : Processing_Flags; In_Tree : Project_Node_Tree_Ref; Project : Project_Node_Id); -- Check that a non aggregate project does not import an aggregate project procedure Create_Virtual_Extending_Project (For_Project : Project_Node_Id; Main_Project : Project_Node_Id; Extension_Withs : Project_Node_Id; In_Tree : Project_Node_Tree_Ref); -- Create a virtual extending project of For_Project. Main_Project is -- the extending all project. Extension_Withs is the head of a WITH clause -- list to be added to the created virtual project. -- -- The String_Value_Of is not set for the automatically added with -- clause and keeps the default value of No_Name. This enables Prj.PP -- to skip these automatically added with clauses to be processed. procedure Look_For_Virtual_Projects_For (Proj : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; Potentially_Virtual : Boolean); -- Look for projects that need to have a virtual extending project. -- This procedure is recursive. If called with Potentially_Virtual set to -- True, then Proj may need an virtual extending project; otherwise it -- does not (because it is already extended), but other projects that it -- imports may need to be virtually extended. type Extension_Origin is (None, Extending_Simple, Extending_All); -- Type of parameter From_Extended for procedures Parse_Single_Project and -- Post_Parse_Context_Clause. Extending_All means that we are parsing the -- tree rooted at an extending all project. procedure Parse_Single_Project (In_Tree : Project_Node_Tree_Ref; Project : out Project_Node_Id; Extends_All : out Boolean; Path_Name_Id : Path_Name_Type; Extended : Boolean; From_Extended : Extension_Origin; In_Limited : Boolean; Packages_To_Check : String_List_Access; Depth : Natural; Current_Dir : String; Is_Config_File : Boolean; Env : in out Environment; Implicit_Project : Boolean := False); -- Parse a project file. This is a recursive procedure: it calls itself for -- imported and extended projects. When From_Extended is not None, if the -- project has already been parsed and is an extended project A, return the -- ultimate (not extended) project that extends A. When In_Limited is True, -- the importing path includes at least one "limited with". When parsing -- configuration projects, do not allow a depth > 1. -- -- Is_Config_File should be set to True if the project represents a config -- file (.cgpr) since some specific checks apply. -- -- If Implicit_Project is True, change the Directory of the project node -- to be the Current_Dir. Recursive calls to Parse_Single_Project are -- always done with the default False value for Implicit_Project. procedure Pre_Parse_Context_Clause (In_Tree : Project_Node_Tree_Ref; Context_Clause : out With_Id; Is_Config_File : Boolean; Add_Implicit_With : Boolean; Flags : Processing_Flags); -- Parse the context clause of a project. Store the paths and locations of -- the imported projects in table Withs. Does nothing if there is no -- context clause (if the current token is not "with" or "limited" followed -- by "with"). -- Is_Config_File should be set to True if the project represents a config -- file (.cgpr) since some specific checks apply. -- When Add_Implicit_With is True, add the --implicit-with dependency. procedure Post_Parse_Context_Clause (Context_Clause : With_Id; In_Tree : Project_Node_Tree_Ref; In_Limited : Boolean; Limited_Withs : Boolean; Imported_Projects : in out Project_Node_Id; Project_Directory : Path_Name_Type; From_Extended : Extension_Origin; Packages_To_Check : String_List_Access; Depth : Natural; Current_Dir : String; Is_Config_File : Boolean; Env : in out Environment); -- Parse the imported projects that have been stored in table Withs, if -- any. From_Extended is used for the call to Parse_Single_Project below. -- -- When In_Limited is True, the importing path includes at least one -- "limited with". When Limited_Withs is False, only non limited withed -- projects are parsed. When Limited_Withs is True, only limited withed -- projects are parsed. -- -- Is_Config_File should be set to True if the project represents a config -- file (.cgpr) since some specific checks apply. function Project_Name_From (Path_Name : String; Is_Config_File : Boolean) return Name_Id; -- Returns the name of the project that corresponds to its path name. -- Returns No_Name if the path name is invalid, because the corresponding -- project name does not have the syntax of an ada identifier. function Copy_With_Clause (With_Clause : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; Next_Clause : Project_Node_Id) return Project_Node_Id; -- Return a copy of With_Clause in In_Tree, whose Next_With_Clause is the -- indicated one. procedure Ultimate_Extending (Prj : in out Project_Node_Id; In_Tree : Project_Node_Tree_Ref); -- Loop through extending projects to find the ultimate extending project, -- that is the one that is not extended. For an abstract project, as it can -- be extended several times, there is no extending project registered, so -- the loop does not execute and the resulting project is the abstract -- project. ---------------------- -- Copy_With_Clause -- ---------------------- function Copy_With_Clause (With_Clause : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; Next_Clause : Project_Node_Id) return Project_Node_Id is New_With_Clause : constant Project_Node_Id := Default_Project_Node (In_Tree, N_With_Clause); begin Set_Name_Of (New_With_Clause, In_Tree, Name_Of (With_Clause, In_Tree)); Set_Path_Name_Of (New_With_Clause, In_Tree, Path_Name_Of (With_Clause, In_Tree)); Set_Project_Node_Of (New_With_Clause, In_Tree, Project_Node_Of (With_Clause, In_Tree)); Set_Next_With_Clause_Of (New_With_Clause, In_Tree, Next_Clause); return New_With_Clause; end Copy_With_Clause; -------------------------------------- -- Create_Virtual_Extending_Project -- -------------------------------------- procedure Create_Virtual_Extending_Project (For_Project : Project_Node_Id; Main_Project : Project_Node_Id; Extension_Withs : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) is Virtual_Name : constant String := Virtual_Prefix & Get_Name_String (Name_Of (For_Project, In_Tree)); -- The name of the virtual extending project Virtual_Name_Id : Name_Id; -- Virtual extending project name id Virtual_Path_Id : Path_Name_Type; -- Fake path name of the virtual extending project. The directory is -- the same directory as the extending all project. -- The source of the virtual extending project is something like: -- project V$ extends is -- for Source_Dirs use (); -- end V$; -- The project directory cannot be specified during parsing; it will be -- put directly in the virtual extending project data during processing. -- Nodes that made up the virtual extending project Virtual_Project : Project_Node_Id; With_Clause : constant Project_Node_Id := Default_Project_Node (In_Tree, N_With_Clause); Project_Declaration : Project_Node_Id; Source_Dirs_Declaration : constant Project_Node_Id := Default_Project_Node (In_Tree, N_Declarative_Item); Source_Dirs_Attribute : constant Project_Node_Id := Default_Project_Node (In_Tree, N_Attribute_Declaration, List); Source_Dirs_Expression : constant Project_Node_Id := Default_Project_Node (In_Tree, N_Expression, List); Source_Dirs_Term : constant Project_Node_Id := Default_Project_Node (In_Tree, N_Term, List); Source_Dirs_List : constant Project_Node_Id := Default_Project_Node (In_Tree, N_Literal_String_List, List); begin -- Get the virtual path name Get_Name_String (Path_Name_Of (Main_Project, In_Tree)); while Name_Len > 0 and then not Is_Directory_Separator (Name_Buffer (Name_Len)) loop Name_Len := Name_Len - 1; end loop; Name_Buffer (Name_Len + 1 .. Name_Len + Virtual_Name'Length) := Virtual_Name; Name_Len := Name_Len + Virtual_Name'Length; Virtual_Path_Id := Name_Find; -- Get the virtual name id Name_Len := Virtual_Name'Length; Name_Buffer (1 .. Name_Len) := Virtual_Name; Virtual_Name_Id := Name_Find; Virtual_Project := Create_Project (In_Tree => In_Tree, Name => Virtual_Name_Id, Full_Path => Virtual_Path_Id, Is_Config_File => False); Project_Declaration := Project_Declaration_Of (Virtual_Project, In_Tree); -- Add a WITH clause to the main project to import the newly created -- virtual extending project. Set_Name_Of (With_Clause, In_Tree, Virtual_Name_Id); Set_Path_Name_Of (With_Clause, In_Tree, Virtual_Path_Id); Set_Project_Node_Of (With_Clause, In_Tree, Virtual_Project); Set_Next_With_Clause_Of (With_Clause, In_Tree, First_With_Clause_Of (Main_Project, In_Tree)); Set_First_With_Clause_Of (Main_Project, In_Tree, With_Clause); -- Copy with clauses for projects imported by the extending-all project declare Org_With_Clause : Project_Node_Id := Extension_Withs; New_With_Clause : Project_Node_Id := Empty_Project_Node; begin while Present (Org_With_Clause) loop New_With_Clause := Copy_With_Clause (Org_With_Clause, In_Tree, New_With_Clause); Org_With_Clause := Next_With_Clause_Of (Org_With_Clause, In_Tree); end loop; Set_First_With_Clause_Of (Virtual_Project, In_Tree, New_With_Clause); end; -- Virtual project node Set_Location_Of (Virtual_Project, In_Tree, Location_Of (Main_Project, In_Tree)); Set_Extended_Project_Path_Of (Virtual_Project, In_Tree, Path_Name_Of (For_Project, In_Tree)); -- Project declaration Set_First_Declarative_Item_Of (Project_Declaration, In_Tree, Source_Dirs_Declaration); Set_Extended_Project_Of (Project_Declaration, In_Tree, For_Project); -- Source_Dirs declaration Set_Current_Item_Node (Source_Dirs_Declaration, In_Tree, Source_Dirs_Attribute); -- Source_Dirs attribute Set_Name_Of (Source_Dirs_Attribute, In_Tree, Snames.Name_Source_Dirs); Set_Expression_Of (Source_Dirs_Attribute, In_Tree, Source_Dirs_Expression); -- Source_Dirs expression Set_First_Term (Source_Dirs_Expression, In_Tree, Source_Dirs_Term); -- Source_Dirs term Set_Current_Term (Source_Dirs_Term, In_Tree, Source_Dirs_List); -- Source_Dirs empty list: nothing to do end Create_Virtual_Extending_Project; ----------------------------------- -- Look_For_Virtual_Projects_For -- ----------------------------------- Extension_Withs : Project_Node_Id; -- Head of the current EXTENDS ALL imports list. When creating virtual -- projects for an EXTENDS ALL, we import in each virtual project all -- of the projects that appear in WITH clauses of the extending projects. -- This ensures that virtual projects share a consistent environment (in -- particular if a project imported by one of the extending projects -- replaces some runtime units). procedure Look_For_Virtual_Projects_For (Proj : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; Potentially_Virtual : Boolean) is Declaration : Project_Node_Id := Empty_Project_Node; -- Node for the project declaration of Proj With_Clause : Project_Node_Id := Empty_Project_Node; -- Node for a with clause of Proj Imported : Project_Node_Id := Empty_Project_Node; -- Node for a project imported by Proj Extended : Project_Node_Id := Empty_Project_Node; -- Node for the eventual project extended by Proj Extends_All : Boolean := False; -- Set True if Proj is an EXTENDS ALL project Saved_Extension_Withs : constant Project_Node_Id := Extension_Withs; begin -- Nothing to do if Proj is undefined or has already been processed if Present (Proj) and then not Processed_Hash.Get (Proj) then -- Make sure the project will not be processed again Processed_Hash.Set (Proj, True); Declaration := Project_Declaration_Of (Proj, In_Tree); if Present (Declaration) then Extended := Extended_Project_Of (Declaration, In_Tree); Extends_All := Is_Extending_All (Proj, In_Tree); end if; -- If this is a project that may need a virtual extending project -- and it is not itself an extending project, put it in the list. if Potentially_Virtual and then No (Extended) then Virtual_Hash.Set (Proj, Extension_Withs); end if; -- Now check the projects it imports With_Clause := First_With_Clause_Of (Proj, In_Tree); while Present (With_Clause) loop Imported := Project_Node_Of (With_Clause, In_Tree); if Present (Imported) then Look_For_Virtual_Projects_For (Imported, In_Tree, Potentially_Virtual => True); end if; if Extends_All then -- This is an EXTENDS ALL project: prepend each of its WITH -- clauses to the currently active list of extension deps. Extension_Withs := Copy_With_Clause (With_Clause, In_Tree, Extension_Withs); end if; With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); end loop; -- Check also the eventual project extended by Proj. As this project -- is already extended, call recursively with Potentially_Virtual -- being False. Look_For_Virtual_Projects_For (Extended, In_Tree, Potentially_Virtual => False); Extension_Withs := Saved_Extension_Withs; end if; end Look_For_Virtual_Projects_For; ----------- -- Parse -- ----------- procedure Parse (In_Tree : Project_Node_Tree_Ref; Project : out Project_Node_Id; Project_File_Name : String; Errout_Handling : Errout_Mode := Always_Finalize; Packages_To_Check : String_List_Access; Store_Comments : Boolean := False; Current_Directory : String := ""; Is_Config_File : Boolean; Env : in out GPR.Tree.Environment; Target_Name : String := ""; Implicit_Project : Boolean := False) is Dummy : Boolean; pragma Warnings (Off, Dummy); Path_Name_Id : Path_Name_Type; begin In_Tree.Incomplete_With := False; Project_Stack.Init; Tree_Private_Part.Projects_Htable.Reset (In_Tree.Projects_HT); if not Is_Initialized (Env.Project_Path) then GPR.Env.Initialize_Default_Project_Path (Env.Project_Path, Target_Name); end if; Project := Empty_Project_Node; Find_Project (Env.Project_Path, Project_File_Name => Project_File_Name, Directory => Current_Directory, Path => Path_Name_Id); if Errout_Handling /= Never_Finalize then GPR.Err.Initialize; end if; GPR.Err.Scanner.Set_Comment_As_Token (Store_Comments); GPR.Err.Scanner.Set_End_Of_Line_As_Token (Store_Comments); if Path_Name_Id = No_Path then GPR.Com.Fail ("project file """ & Project_File_Name & """ not found in " & Get_Path (Env.Project_Path)); Project := Empty_Project_Node; return; end if; -- Set default Root_Dir if not Is_Config_File and then Build_Tree_Dir /= null and then Root_Dir = null then Root_Dir := new String' (Ada.Directories.Containing_Directory (Get_Name_String (Path_Name_Id)) & GNAT.Directory_Operations.Dir_Separator); end if; -- Parse the main project file begin Parse_Single_Project (In_Tree => In_Tree, Project => Project, Extends_All => Dummy, Path_Name_Id => Path_Name_Id, Extended => False, From_Extended => None, In_Limited => False, Packages_To_Check => Packages_To_Check, Depth => 0, Current_Dir => Current_Directory, Is_Config_File => Is_Config_File, Env => Env, Implicit_Project => Implicit_Project); exception when Unrecoverable_Error => -- Unrecoverable_Error is raised when a line is too long. -- A meaningful error message will be displayed later. Project := Empty_Project_Node; end; -- If Project is an extending-all project, create the eventual -- virtual extending projects and check that there are no illegally -- imported projects. if Present (Project) and then Is_Extending_All (Project, In_Tree) then -- First look for projects that potentially need a virtual -- extending project. Virtual_Hash.Reset; Processed_Hash.Reset; -- Mark the extending all project as processed, to avoid checking -- the imported projects in case of a "limited with" on this -- extending all project. Processed_Hash.Set (Project, True); Extension_Withs := First_With_Clause_Of (Project, In_Tree); Look_For_Virtual_Projects_For (Extended_Project_Of (Project_Declaration_Of (Project, In_Tree), In_Tree), In_Tree, Potentially_Virtual => False); -- Now, check the projects directly imported by the main project. -- Remove from the potentially virtual any project extended by one -- of these imported projects. declare With_Clause : Project_Node_Id; Imported : Project_Node_Id := Empty_Project_Node; Declaration : Project_Node_Id := Empty_Project_Node; begin With_Clause := First_With_Clause_Of (Project, In_Tree); while Present (With_Clause) loop Imported := Project_Node_Of (With_Clause, In_Tree); if Present (Imported) then Declaration := Project_Declaration_Of (Imported, In_Tree); if Present (Extended_Project_Of (Declaration, In_Tree)) then loop Imported := Extended_Project_Of (Declaration, In_Tree); exit when No (Imported); Virtual_Hash.Remove (Imported); Declaration := Project_Declaration_Of (Imported, In_Tree); end loop; end if; end if; With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); end loop; end; -- Now create all the virtual extending projects declare Proj : Project_Node_Id := Empty_Project_Node; Withs : Project_Node_Id; begin Virtual_Hash.Get_First (Proj, Withs); while Withs /= Project_Node_High_Bound loop Create_Virtual_Extending_Project (Proj, Project, Withs, In_Tree); Virtual_Hash.Get_Next (Proj, Withs); end loop; end; end if; -- If there were any kind of error during the parsing, serious -- or not, then the parsing fails. if Total_Errors_Detected > 0 then Project := Empty_Project_Node; end if; case Errout_Handling is when Always_Finalize => GPR.Err.Finalize; -- Reinitialize to avoid duplicate warnings later on GPR.Err.Initialize; when Finalize_If_Error => if No (Project) then GPR.Err.Finalize; GPR.Err.Initialize; end if; when Never_Finalize => null; end case; exception when X : others => -- Internal error Write_Line (Exception_Information (X)); Write_Str ("Exception "); Write_Str (Exception_Name (X)); Write_Line (" raised, while processing project file"); Project := Empty_Project_Node; end Parse; ------------------------------ -- Pre_Parse_Context_Clause -- ------------------------------ procedure Pre_Parse_Context_Clause (In_Tree : Project_Node_Tree_Ref; Context_Clause : out With_Id; Is_Config_File : Boolean; Add_Implicit_With : Boolean; Flags : Processing_Flags) is Current_With_Clause : With_Id := No_With; Limited_With : Boolean := False; Current_With : With_Record; Current_With_Node : Project_Node_Id := Empty_Project_Node; Start_Token : constant Source_Ptr := Token_Ptr; procedure Append_Current_With; -- Append Current_With to Withs ------------------------- -- Append_Current_With -- ------------------------- procedure Append_Current_With is begin Withs.Increment_Last; Withs.Table (Withs.Last) := Current_With; if Current_With_Clause = No_With then Context_Clause := Withs.Last; else Withs.Table (Current_With_Clause).Next := Withs.Last; end if; Current_With_Clause := Withs.Last; end Append_Current_With; begin -- Assume no context clause Context_Clause := No_With; With_Loop : -- If Token is not WITH or LIMITED, there is no context clause, or we -- have exhausted the with clauses. while Token = Tok_With or else Token = Tok_Limited loop Current_With_Node := Default_Project_Node (Of_Kind => N_With_Clause, In_Tree => In_Tree); Limited_With := Token = Tok_Limited; if Is_Config_File then Error_Msg (Flags, "configuration project cannot import " & "other configuration projects", Token_Ptr); end if; if Limited_With then Scan (In_Tree); -- past LIMITED Expect (Tok_With, "WITH"); exit With_Loop when Token /= Tok_With; end if; Comma_Loop : loop Scan (In_Tree); -- past WITH or "," Expect (Tok_String_Literal, "literal string"); if Token /= Tok_String_Literal then return; end if; -- Store path and location in table Withs Current_With := (Path => Path_Name_Type (Token_Name), Location => Token_Ptr, Limited_With => Limited_With, Node => Current_With_Node, Next => No_With); Append_Current_With; Scan (In_Tree); if Token = Tok_Semicolon then Set_End_Of_Line (Current_With_Node); Set_Previous_Line_Node (Current_With_Node); -- End of (possibly multiple) with clause; Scan (In_Tree); -- past semicolon exit Comma_Loop; elsif Token = Tok_Comma then Set_Is_Not_Last_In_List (Current_With_Node, In_Tree); else Error_Msg (Flags, "expected comma or semi colon", Token_Ptr); exit Comma_Loop; end if; Current_With_Node := Default_Project_Node (Of_Kind => N_With_Clause, In_Tree => In_Tree); end loop Comma_Loop; end loop With_Loop; if Add_Implicit_With then Current_With_Node := Default_Project_Node (In_Tree, Of_Kind => N_With_Clause); Current_With := (Path => Get_Path_Name_Id (Implicit_With.all), Location => Start_Token, Limited_With => True, Node => Current_With_Node, Next => No_With); Append_Current_With; end if; end Pre_Parse_Context_Clause; ------------------------------- -- Post_Parse_Context_Clause -- ------------------------------- procedure Post_Parse_Context_Clause (Context_Clause : With_Id; In_Tree : Project_Node_Tree_Ref; In_Limited : Boolean; Limited_Withs : Boolean; Imported_Projects : in out Project_Node_Id; Project_Directory : Path_Name_Type; From_Extended : Extension_Origin; Packages_To_Check : String_List_Access; Depth : Natural; Current_Dir : String; Is_Config_File : Boolean; Env : in out Environment) is Current_With_Clause : With_Id := Context_Clause; Current_Project : Project_Node_Id := Imported_Projects; Previous_Project : Project_Node_Id := Empty_Project_Node; Next_Project : Project_Node_Id := Empty_Project_Node; Project_Directory_Path : constant String := Get_Name_String (Project_Directory); Current_With : With_Record; Extends_All : Boolean := False; Imported_Path_Name_Id : Path_Name_Type; begin -- Set Current_Project to the last project in the current list, if the -- list is not empty. if Present (Current_Project) then while Present (Next_With_Clause_Of (Current_Project, In_Tree)) loop Current_Project := Next_With_Clause_Of (Current_Project, In_Tree); end loop; end if; while Current_With_Clause /= No_With loop Current_With := Withs.Table (Current_With_Clause); Current_With_Clause := Current_With.Next; if Limited_Withs = Current_With.Limited_With then Find_Project (Env.Project_Path, Project_File_Name => Get_Name_String (Current_With.Path), Directory => Project_Directory_Path, Path => Imported_Path_Name_Id); if Imported_Path_Name_Id = No_Path then if Env.Flags.Ignore_Missing_With then In_Tree.Incomplete_With := True; Env.Flags.Incomplete_Withs := True; else -- The project file cannot be found Error_Msg_File_1 := File_Name_Type (Current_With.Path); Error_Msg (Env.Flags, "imported project file { not found", Current_With.Location); -- If this is not imported by the main project file, display -- the import path. if Project_Stack.Last > 1 then for Index in reverse 1 .. Project_Stack.Last loop Error_Msg_File_1 := File_Name_Type (Project_Stack.Table (Index).Path_Name); Error_Msg (Env.Flags, "\imported by {", Current_With.Location); end loop; end if; end if; else -- New with clause declare Resolved_Path : constant String := Normalize_Pathname (Get_Name_String (Imported_Path_Name_Id), Directory => Current_Dir, Resolve_Links => Opt.Follow_Links_For_Files, Case_Sensitive => True); Withed_Project : Project_Node_Id := Empty_Project_Node; begin Previous_Project := Current_Project; if No (Current_Project) then -- First with clause of the context clause Current_Project := Current_With.Node; Imported_Projects := Current_Project; else Next_Project := Current_With.Node; Set_Next_With_Clause_Of (Current_Project, In_Tree, Next_Project); Current_Project := Next_Project; end if; Set_String_Value_Of (Current_Project, In_Tree, Name_Id (Current_With.Path)); Set_Location_Of (Current_Project, In_Tree, Current_With.Location); -- If it is a limited with, check if we have a circularity. -- If we have one, get the project id of the limited -- imported project file, and do not parse it. if (In_Limited or Limited_Withs) and then Project_Stack.Last > 1 then declare Canonical_Path_Name : Path_Name_Type; begin Name_Len := Resolved_Path'Length; Name_Buffer (1 .. Name_Len) := Resolved_Path; Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); Canonical_Path_Name := Name_Find; for Index in 1 .. Project_Stack.Last loop if Project_Stack.Table (Index).Canonical_Path_Name = Canonical_Path_Name then -- We have found the limited imported project, -- get its project id, and do not parse it. Withed_Project := Project_Stack.Table (Index).Id; exit; end if; end loop; end; end if; -- Parse the imported project if its project id is unknown if No (Withed_Project) then Parse_Single_Project (In_Tree => In_Tree, Project => Withed_Project, Extends_All => Extends_All, Path_Name_Id => Imported_Path_Name_Id, Extended => False, From_Extended => From_Extended, In_Limited => In_Limited or Limited_Withs, Packages_To_Check => Packages_To_Check, Depth => Depth, Current_Dir => Current_Dir, Is_Config_File => Is_Config_File, Env => Env); else Extends_All := Is_Extending_All (Withed_Project, In_Tree); end if; if No (Withed_Project) then -- If parsing unsuccessful, remove the context clause Current_Project := Previous_Project; if No (Current_Project) then Imported_Projects := Empty_Project_Node; else Set_Next_With_Clause_Of (Current_Project, In_Tree, Empty_Project_Node); end if; else -- If parsing was successful, record project name and -- path name in with clause Set_Project_Node_Of (Node => Current_Project, In_Tree => In_Tree, To => Withed_Project, Limited_With => Current_With.Limited_With); Set_Name_Of (Current_Project, In_Tree, Name_Of (Withed_Project, In_Tree)); Name_Len := Resolved_Path'Length; Name_Buffer (1 .. Name_Len) := Resolved_Path; Set_Path_Name_Of (Current_Project, In_Tree, Name_Find); if Extends_All then Set_Is_Extending_All (Current_Project, In_Tree); end if; end if; end; end if; end if; end loop; end Post_Parse_Context_Clause; --------------------------------- -- Check_Extending_All_Imports -- --------------------------------- procedure Check_Extending_All_Imports (Flags : Processing_Flags; In_Tree : Project_Node_Tree_Ref; Project : Project_Node_Id) is With_Clause : Project_Node_Id; Imported : Project_Node_Id; begin if not Is_Extending_All (Project, In_Tree) then With_Clause := First_With_Clause_Of (Project, In_Tree); while Present (With_Clause) loop Imported := Project_Node_Of (With_Clause, In_Tree); if Is_Extending_All (With_Clause, In_Tree) then Error_Msg_Name_1 := Name_Of (Imported, In_Tree); Error_Msg (Flags, "cannot import extending-all project %%", Token_Ptr); exit; end if; With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); end loop; end if; end Check_Extending_All_Imports; ----------------------------- -- Check_Aggregate_Imports -- ----------------------------- procedure Check_Aggregate_Imports (Flags : Processing_Flags; In_Tree : Project_Node_Tree_Ref; Project : Project_Node_Id) is With_Clause, Imported : Project_Node_Id; begin if Project_Qualifier_Of (Project, In_Tree) = Aggregate then With_Clause := First_With_Clause_Of (Project, In_Tree); while Present (With_Clause) loop Imported := Project_Node_Of (With_Clause, In_Tree); if Project_Qualifier_Of (Imported, In_Tree) /= Abstract_Project then Error_Msg_Name_1 := Name_Id (Path_Name_Of (Imported, In_Tree)); Error_Msg (Flags, "can only import abstract projects, not %%", Token_Ptr); exit; end if; With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); end loop; end if; end Check_Aggregate_Imports; ---------------------------- -- Check_Import_Aggregate -- ---------------------------- procedure Check_Import_Aggregate (Flags : Processing_Flags; In_Tree : Project_Node_Tree_Ref; Project : Project_Node_Id) is With_Clause : Project_Node_Id; Imported : Project_Node_Id; begin if Project_Qualifier_Of (Project, In_Tree) /= Aggregate then With_Clause := First_With_Clause_Of (Project, In_Tree); while Present (With_Clause) loop Imported := Project_Node_Of (With_Clause, In_Tree); if Project_Qualifier_Of (Imported, In_Tree) = Aggregate then Error_Msg_Name_1 := Name_Id (Path_Name_Of (Imported, In_Tree)); Error_Msg (Flags, "cannot import aggregate project %%", Token_Ptr); exit; end if; With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); end loop; end if; end Check_Import_Aggregate; ---------------------------- -- Read_Project_Qualifier -- ---------------------------- procedure Read_Project_Qualifier (Flags : Processing_Flags; In_Tree : Project_Node_Tree_Ref; Is_Config_File : Boolean; Qualifier_Location : out Source_Ptr; Project : Project_Node_Id) is Proj_Qualifier : Project_Qualifier := Unspecified; begin Qualifier_Location := Token_Ptr; if Token = Tok_Abstract then Proj_Qualifier := Abstract_Project; Scan (In_Tree); elsif Token = Tok_Identifier then if Token_Name = Snames.Name_Standard then Proj_Qualifier := Standard; Scan (In_Tree); elsif Token_Name = Snames.Name_Aggregate then Proj_Qualifier := Aggregate; Scan (In_Tree); if Token = Tok_Identifier and then Token_Name = Snames.Name_Library then Proj_Qualifier := Aggregate_Library; Scan (In_Tree); end if; elsif Token_Name = Snames.Name_Library then Proj_Qualifier := Library; Scan (In_Tree); elsif Token_Name = Snames.Name_Configuration then if not Is_Config_File then Error_Msg (Flags, "configuration projects cannot belong to a user" & " project tree", Token_Ptr); end if; Proj_Qualifier := Configuration; Scan (In_Tree); end if; end if; if Is_Config_File and then Proj_Qualifier = Unspecified then -- Set the qualifier to Configuration, even if the token doesn't -- exist in the source file itself, so that we can differentiate -- project files and configuration files later on. Proj_Qualifier := Configuration; end if; if Proj_Qualifier /= Unspecified then if Is_Config_File and then Proj_Qualifier /= Configuration then Error_Msg (Flags, "a configuration project cannot be qualified except " & "as configuration project", Qualifier_Location); end if; Set_Project_Qualifier_Of (Project, In_Tree, Proj_Qualifier); end if; end Read_Project_Qualifier; ------------------------------- -- Has_Circular_Dependencies -- ------------------------------- function Has_Circular_Dependencies (Flags : Processing_Flags; Normed_Path_Name : Path_Name_Type; Canonical_Path_Name : Path_Name_Type) return Boolean is begin for Index in reverse 1 .. Project_Stack.Last loop exit when Project_Stack.Table (Index).Limited_With; if Canonical_Path_Name = Project_Stack.Table (Index).Canonical_Path_Name then Error_Msg (Flags, "circular dependency detected", Token_Ptr); Error_Msg_Name_1 := Name_Id (Normed_Path_Name); Error_Msg (Flags, "\ %% is imported by", Token_Ptr); for Current in reverse 1 .. Project_Stack.Last loop Error_Msg_Name_1 := Name_Id (Project_Stack.Table (Current).Path_Name); if Project_Stack.Table (Current).Canonical_Path_Name /= Canonical_Path_Name then Error_Msg (Flags, "\ %% which itself is imported by", Token_Ptr); else Error_Msg (Flags, "\ %%", Token_Ptr); exit; end if; end loop; return True; end if; end loop; return False; end Has_Circular_Dependencies; -------------------------- -- Parse_Single_Project -- -------------------------- procedure Parse_Single_Project (In_Tree : Project_Node_Tree_Ref; Project : out Project_Node_Id; Extends_All : out Boolean; Path_Name_Id : Path_Name_Type; Extended : Boolean; From_Extended : Extension_Origin; In_Limited : Boolean; Packages_To_Check : String_List_Access; Depth : Natural; Current_Dir : String; Is_Config_File : Boolean; Env : in out Environment; Implicit_Project : Boolean := False) is Path_Name : constant String := Get_Name_String (Path_Name_Id); Normed_Path_Name : Path_Name_Type; Canonical_Path_Name : Path_Name_Type; Resolved_Path_Name : Path_Name_Type; Project_Directory : Path_Name_Type; Project_Scan_State : Saved_Project_Scan_State; Source_Index : Source_File_Index; Normed_Path : constant String := Normalize_Pathname (Path_Name, Directory => Current_Dir, Resolve_Links => False, Case_Sensitive => True); Extending : Boolean := False; Extended_Project : Project_Node_Id := Empty_Project_Node; A_Project_Name_And_Node : Tree_Private_Part.Project_Name_And_Node := Tree_Private_Part.Projects_Htable.Get_First (In_Tree.Projects_HT); Name_From_Path : constant Name_Id := Project_Name_From (Path_Name, Is_Config_File => Is_Config_File); Name_Of_Project : Name_Id := No_Name; Duplicated : Boolean := False; First_With : With_Id; Imported_Projects : Project_Node_Id := Empty_Project_Node; use Tree_Private_Part; Project_Comment_State : Tree.Comment_State; Qualifier_Location : Source_Ptr; begin Extends_All := False; declare Canonical_Path : constant String := Normalize_Pathname (Normed_Path, Directory => Current_Dir, Resolve_Links => Opt.Follow_Links_For_Files, Case_Sensitive => False); begin Name_Len := Normed_Path'Length; Name_Buffer (1 .. Name_Len) := Normed_Path; Normed_Path_Name := Name_Find; Name_Len := Canonical_Path'Length; Name_Buffer (1 .. Name_Len) := Canonical_Path; Canonical_Path_Name := Name_Find; if Opt.Follow_Links_For_Files then Resolved_Path_Name := Canonical_Path_Name; else Resolved_Path_Name := Resolved_Paths.Get (Canonical_Path_Name); if Resolved_Path_Name = No_Path then Resolved_Path_Name := Get_Path_Name_Id (Normalize_Pathname (Canonical_Path, Resolve_Links => True, Case_Sensitive => False)); Resolved_Paths.Set (Canonical_Path_Name, Resolved_Path_Name); end if; end if; end; if Has_Circular_Dependencies (Env.Flags, Normed_Path_Name, Canonical_Path_Name) then Project := Empty_Project_Node; return; end if; -- Check if a different project with the same name is already in the -- chain of extending projects. Report an error if such a project is -- found. for J in 1 .. Extended_Projects.Last loop declare NP : constant Name_And_Path := Extended_Projects.Table (J); begin if NP.Name = Name_From_Path and then NP.Path /= Resolved_Path_Name then Error_Msg (Env.Flags, "cannot extend a project with the same name", Token_Ptr); Project := Empty_Project_Node; return; end if; end; end loop; -- Put the new path name on the stack Project_Stack.Append ((Path_Name => Normed_Path_Name, Canonical_Path_Name => Canonical_Path_Name, Id => Empty_Project_Node, Limited_With => In_Limited)); -- Check if the project file has already been parsed while A_Project_Name_And_Node /= Tree_Private_Part.No_Project_Name_And_Node loop if A_Project_Name_And_Node.Resolved_Path = Resolved_Path_Name then if Extended then if A_Project_Name_And_Node.Extended then if A_Project_Name_And_Node.Proj_Qualifier /= Abstract_Project then Error_Msg (Env.Flags, "cannot extend the same project file several times", Token_Ptr); end if; elsif not A_Project_Name_And_Node.From_Extended then Error_Msg (Env.Flags, "cannot extend an already imported project file", Token_Ptr); else -- Register this project as being extended A_Project_Name_And_Node.Extended := True; Tree_Private_Part.Projects_Htable.Set (In_Tree.Projects_HT, A_Project_Name_And_Node.Name, A_Project_Name_And_Node); end if; elsif A_Project_Name_And_Node.Extended then Extends_All := Is_Extending_All (A_Project_Name_And_Node.Node, In_Tree); -- If the imported project is an extended project A, and we are -- in an extended project, replace A with the ultimate project -- extending A. if From_Extended /= None then Ultimate_Extending (A_Project_Name_And_Node.Node, In_Tree); else Error_Msg (Env.Flags, "cannot import an already extended project file", Token_Ptr); end if; elsif From_Extended /= Extending_All and then A_Project_Name_And_Node.From_Extended then -- This project is now imported from a non extending project. -- Indicate this in hash table Projects.HT. A_Project_Name_And_Node.From_Extended := False; Tree_Private_Part.Projects_Htable.Set (In_Tree.Projects_HT, A_Project_Name_And_Node.Name, A_Project_Name_And_Node); end if; Project := A_Project_Name_And_Node.Node; Project_Stack.Decrement_Last; return; end if; A_Project_Name_And_Node := Tree_Private_Part.Projects_Htable.Get_Next (In_Tree.Projects_HT); end loop; -- We never encountered this project file. Save the scan state, load the -- project file and start to scan it. Save_Project_Scan_State (Project_Scan_State); Source_Index := Load_File (Path_Name); Tree.Save (Project_Comment_State); -- If we cannot find it, we stop if Source_Index = No_Source_File then Project := Empty_Project_Node; Project_Stack.Decrement_Last; return; end if; Scanner.Initialize_Scanner (Source_Index, Scanner.Project); Tree.Reset_State; Scan (In_Tree); if not Is_Config_File and then Name_From_Path = No_Name and then not Implicit_Project then -- The project file name is not correct (no or bad extension, or not -- following Ada identifier's syntax). Error_Msg_File_1 := File_Name_Type (Canonical_Path_Name); Error_Msg (Env.Flags, "?{ is not a valid path name for a project file", Token_Ptr); end if; if Current_Verbosity >= Medium then Debug_Increase_Indent ("Parsing """ & Path_Name & '"'); end if; Project_Directory := Path_Name_Type (Get_Directory (File_Name_Type (Normed_Path_Name))); -- Is there any imported project? Pre_Parse_Context_Clause (In_Tree => In_Tree, Is_Config_File => Is_Config_File, Context_Clause => First_With, Flags => Env.Flags, Add_Implicit_With => Implicit_With /= null and then not Is_Config_File and then Name_From_Path /= No_Name and then Project_Name_From (Implicit_With.all, False) /= Name_From_Path); Project := Default_Project_Node (Of_Kind => N_Project, In_Tree => In_Tree); Project_Stack.Table (Project_Stack.Last).Id := Project; Set_Directory_Of (Project, In_Tree, Project_Directory); Set_Path_Name_Of (Project, In_Tree, Normed_Path_Name); Read_Project_Qualifier (Env.Flags, In_Tree, Is_Config_File, Qualifier_Location, Project); Set_Location_Of (Project, In_Tree, Token_Ptr); Expect (Tok_Project, "PROJECT"); -- Mark location of PROJECT token if present if Token = Tok_Project then Scan (In_Tree); -- past PROJECT Set_Location_Of (Project, In_Tree, Token_Ptr); end if; -- Clear the Buffer Buffer_Last := 0; loop Expect (Tok_Identifier, "identifier"); -- If the token is not an identifier, clear the buffer before -- exiting to indicate that the name of the project is ill-formed. if Token /= Tok_Identifier then Buffer_Last := 0; exit; end if; -- Add the identifier name to the buffer Get_Name_String (Token_Name); Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last); -- Scan past the identifier Scan (In_Tree); -- If we have a dot, add a dot to the Buffer and look for the next -- identifier. exit when Token /= Tok_Dot; Add_To_Buffer (".", Buffer, Buffer_Last); -- Scan past the dot Scan (In_Tree); end loop; -- See if this is an extending project if Token = Tok_Extends then if Is_Config_File then Error_Msg (Env.Flags, "extending configuration project not allowed", Token_Ptr); end if; -- We are extending another project Extending := True; Scan (In_Tree); -- past EXTENDS if Token = Tok_All then Extends_All := True; Set_Is_Extending_All (Project, In_Tree); Scan (In_Tree); -- scan past ALL end if; end if; -- If the name is well formed, Buffer_Last is > 0 if Buffer_Last > 0 then -- The Buffer contains the name of the project Name_Len := Buffer_Last; Name_Buffer (1 .. Name_Len) := Buffer (1 .. Buffer_Last); Name_Of_Project := Name_Find; Set_Name_Of (Project, In_Tree, Name_Of_Project); -- To get expected name of the project file, replace dots by dashes for Index in 1 .. Name_Len loop if Name_Buffer (Index) = '.' then Name_Buffer (Index) := '-'; end if; end loop; Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); declare Expected_Name : constant Name_Id := Name_Find; Extension : String_Access; begin -- Output a warning if the actual name is not the expected name if not Is_Config_File and then Name_From_Path /= No_Name and then Expected_Name /= Name_From_Path then Error_Msg_Name_1 := Expected_Name; if Is_Config_File then Extension := new String'(Config_Project_File_Extension); else Extension := new String'(Project_File_Extension); end if; Error_Msg (Env.Flags, "?file name does not match project name, should be `%%" & Extension.all & "`", Token_Ptr); end if; end; -- Read the original casing of the project name and put it in the -- project node. declare Loc : Source_Ptr; begin Loc := Location_Of (Project, In_Tree); for J in 1 .. Name_Len loop Name_Buffer (J) := Sinput.Source (Loc); Loc := Loc + 1; end loop; Set_Display_Name_Of (Project, In_Tree, Name_Find); end; declare From_Ext : Extension_Origin := None; begin -- Extending_All is always propagated if From_Extended = Extending_All or else Extends_All then From_Ext := Extending_All; -- Otherwise, From_Extended is set to Extending_Single if the -- current project is an extending project. elsif Extended then From_Ext := Extending_Simple; end if; Post_Parse_Context_Clause (In_Tree => In_Tree, Context_Clause => First_With, In_Limited => In_Limited, Limited_Withs => False, Imported_Projects => Imported_Projects, Project_Directory => Project_Directory, From_Extended => From_Ext, Packages_To_Check => Packages_To_Check, Depth => Depth + 1, Current_Dir => Current_Dir, Is_Config_File => Is_Config_File, Env => Env); Set_First_With_Clause_Of (Project, In_Tree, Imported_Projects); end; if not Is_Config_File then declare Name_And_Node : Tree_Private_Part.Project_Name_And_Node := Tree_Private_Part.Projects_Htable.Get_First (In_Tree.Projects_HT); Project_Name : Name_Id := Name_And_Node.Name; begin -- Check if we already have a project with this name while Project_Name /= No_Name and then Project_Name /= Name_Of_Project loop Name_And_Node := Tree_Private_Part.Projects_Htable.Get_Next (In_Tree.Projects_HT); Project_Name := Name_And_Node.Name; end loop; -- Report an error if we already have a project with this name if Project_Name /= No_Name then Duplicated := True; Error_Msg_Name_1 := Project_Name; Error_Msg (Env.Flags, "duplicate project name %%", Location_Of (Project, In_Tree)); Error_Msg_Name_1 := Name_Id (Path_Name_Of (Name_And_Node.Node, In_Tree)); Error_Msg (Env.Flags, "\already in %%", Location_Of (Project, In_Tree)); end if; end; end if; end if; if Extending then Expect (Tok_String_Literal, "literal string"); if Token = Tok_String_Literal then Set_Extended_Project_Path_Of (Project, In_Tree, Path_Name_Type (Token_Name)); declare Original_Path_Name : constant String := Get_Name_String (Token_Name); Extended_Project_Path_Name_Id : Path_Name_Type; begin Find_Project (Env.Project_Path, Project_File_Name => Original_Path_Name, Directory => Get_Name_String (Project_Directory), Path => Extended_Project_Path_Name_Id); if Extended_Project_Path_Name_Id = No_Path then if Env.Flags.Ignore_Missing_With then In_Tree.Incomplete_With := True; Env.Flags.Incomplete_Withs := True; else -- We could not find the project file to extend Error_Msg_Name_1 := Token_Name; Error_Msg (Env.Flags, "extended project file %% not found", Token_Ptr); -- If not in the main project file, display the import -- path. if Project_Stack.Last > 1 then Error_Msg_Name_1 := Name_Id (Project_Stack.Table (Project_Stack.Last).Path_Name); Error_Msg (Env.Flags, "\extended by %%", Token_Ptr); for Index in reverse 1 .. Project_Stack.Last - 1 loop Error_Msg_Name_1 := Name_Id (Project_Stack.Table (Index).Path_Name); Error_Msg (Env.Flags, "\imported by %%", Token_Ptr); end loop; end if; end if; else declare From_Ext : Extension_Origin := None; begin if From_Extended = Extending_All or else Extends_All then From_Ext := Extending_All; end if; Extended_Projects.Append ((Name => Name_From_Path, Path => Resolved_Path_Name)); Parse_Single_Project (In_Tree => In_Tree, Project => Extended_Project, Extends_All => Extends_All, Path_Name_Id => Extended_Project_Path_Name_Id, Extended => True, From_Extended => From_Ext, In_Limited => In_Limited, Packages_To_Check => Packages_To_Check, Depth => Depth + 1, Current_Dir => Current_Dir, Is_Config_File => Is_Config_File, Env => Env); -- The chain of extending projects has ended, empty the -- table. Extended_Projects.Set_Last (0); end; if Present (Extended_Project) then if Project_Qualifier_Of (Extended_Project, In_Tree) = Aggregate then Error_Msg_Name_1 := Name_Id (Path_Name_Of (Extended_Project, In_Tree)); Error_Msg (Env.Flags, "cannot extend aggregate project %%", Location_Of (Project, In_Tree)); end if; -- A project that extends an extending-all project is -- also an extending-all project. if Is_Extending_All (Extended_Project, In_Tree) then Set_Is_Extending_All (Project, In_Tree); end if; -- An abstract project can only extend an abstract -- project. Otherwise we may have an abstract project -- with sources if it inherits sources from the project -- it extends. if Project_Qualifier_Of (Project, In_Tree) = Abstract_Project and then Project_Qualifier_Of (Extended_Project, In_Tree) /= Abstract_Project then Error_Msg (Env.Flags, "an abstract project can only extend " & "another abstract project", Qualifier_Location); end if; end if; end if; end; Scan (In_Tree); -- past the extended project path end if; end if; Check_Extending_All_Imports (Env.Flags, In_Tree, Project); Check_Aggregate_Imports (Env.Flags, In_Tree, Project); Check_Import_Aggregate (Env.Flags, In_Tree, Project); -- Check that a project with a name including a dot either imports -- or extends the project whose name precedes the last dot. if Name_Of_Project /= No_Name then Get_Name_String (Name_Of_Project); else Name_Len := 0; end if; -- Look for the last dot while Name_Len > 0 and then Name_Buffer (Name_Len) /= '.' loop Name_Len := Name_Len - 1; end loop; -- If a dot was found, check if parent project is imported or extended if Name_Len > 0 then Name_Len := Name_Len - 1; declare Parent_Name : constant Name_Id := Name_Find; Parent_Found : Boolean := False; Parent_Node : Project_Node_Id := Empty_Project_Node; With_Clause : Project_Node_Id := First_With_Clause_Of (Project, In_Tree); Imp_Proj_Name : Name_Id; begin -- If there is an extended project, check its name if Present (Extended_Project) then Parent_Node := Extended_Project; Parent_Found := Name_Of (Extended_Project, In_Tree) = Parent_Name; end if; -- If the parent project is not the extended project, -- check each imported project until we find the parent project. Imported_Loop : while not Parent_Found and then Present (With_Clause) loop Parent_Node := Project_Node_Of (With_Clause, In_Tree); Extension_Loop : while Present (Parent_Node) loop Imp_Proj_Name := Name_Of (Parent_Node, In_Tree); Parent_Found := Imp_Proj_Name = Parent_Name; exit Imported_Loop when Parent_Found; Parent_Node := Extended_Project_Of (Project_Declaration_Of (Parent_Node, In_Tree), In_Tree); end loop Extension_Loop; With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); end loop Imported_Loop; if Parent_Found then Set_Parent_Project_Of (Project, In_Tree, To => Parent_Node); else -- If the parent project was not found, report an error Error_Msg_Name_1 := Name_Of_Project; Error_Msg_Name_2 := Parent_Name; Error_Msg (Env.Flags, "project %% does not import or extend project %%", Location_Of (Project, In_Tree)); end if; end; end if; Expect (Tok_Is, "IS"); Set_End_Of_Line (Project); Set_Previous_Line_Node (Project); Set_Next_End_Node (Project); declare Project_Declaration : Project_Node_Id := Empty_Project_Node; begin -- No need to Scan past "is", GPR.Dect.Parse will do it GPR.Dect.Parse (In_Tree => In_Tree, Declarations => Project_Declaration, Current_Project => Project, Extends => Extended_Project, Packages_To_Check => Packages_To_Check, Is_Config_File => Is_Config_File, Flags => Env.Flags); Set_Project_Declaration_Of (Project, In_Tree, Project_Declaration); if Present (Extended_Project) and then Project_Qualifier_Of (Extended_Project, In_Tree) /= Abstract_Project then Set_Extending_Project_Of (Project_Declaration_Of (Extended_Project, In_Tree), In_Tree, To => Project); end if; end; Expect (Tok_End, "END"); Remove_Next_End_Node; -- Skip "end" if present if Token = Tok_End then Scan (In_Tree); end if; -- Clear the Buffer Buffer_Last := 0; -- Store the name following "end" in the Buffer. The name may be made of -- several simple names. loop Expect (Tok_Identifier, "identifier"); -- If we don't have an identifier, clear the buffer before exiting to -- avoid checking the name. if Token /= Tok_Identifier then Buffer_Last := 0; exit; end if; -- Add the identifier to the Buffer Get_Name_String (Token_Name); Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last); -- Scan past the identifier Scan (In_Tree); exit when Token /= Tok_Dot; Add_To_Buffer (".", Buffer, Buffer_Last); Scan (In_Tree); end loop; -- If we have a valid name, check if it is the name of the project if Name_Of_Project /= No_Name and then Buffer_Last > 0 then if To_Lower (Buffer (1 .. Buffer_Last)) /= Get_Name_String (Name_Of (Project, In_Tree)) then -- Invalid name: report an error Error_Msg (Env.Flags, "expected """ & Get_Name_String (Name_Of (Project, In_Tree)) & """", Token_Ptr); end if; end if; Expect (Tok_Semicolon, "`;`"); -- Check that there is no more text following the end of the project -- source. if Token = Tok_Semicolon then Set_Previous_End_Node (Project); Scan (In_Tree); if Token /= Tok_EOF then Error_Msg (Env.Flags, "unexpected text following end of project", Token_Ptr); end if; end if; if not Duplicated and then Name_Of_Project /= No_Name then -- Add the name of the project to the hash table, so that we can -- check that no other subsequent project will have the same name. Tree_Private_Part.Projects_Htable.Set (T => In_Tree.Projects_HT, K => Name_Of_Project, E => (Name => Name_Of_Project, Node => Project, Resolved_Path => Resolved_Path_Name, Extended => Extended, From_Extended => From_Extended /= None, Proj_Qualifier => Project_Qualifier_Of (Project, In_Tree))); In_Tree.Project_Nodes.Table (Project).Checksum := Scans.Checksum; end if; declare From_Ext : Extension_Origin := None; begin -- Extending_All is always propagated if From_Extended = Extending_All or else Extends_All then From_Ext := Extending_All; -- Otherwise, From_Extended is set to Extending_Single if the -- current project is an extending project. elsif Extended then From_Ext := Extending_Simple; end if; Post_Parse_Context_Clause (In_Tree => In_Tree, Context_Clause => First_With, In_Limited => In_Limited, Limited_Withs => True, Imported_Projects => Imported_Projects, Project_Directory => Project_Directory, From_Extended => From_Ext, Packages_To_Check => Packages_To_Check, Depth => Depth + 1, Current_Dir => Current_Dir, Is_Config_File => Is_Config_File, Env => Env); Set_First_With_Clause_Of (Project, In_Tree, Imported_Projects); end; -- Restore the scan state, in case we are not the main project Restore_Project_Scan_State (Project_Scan_State); -- And remove the project from the project stack Project_Stack.Decrement_Last; -- Indicate if there are unkept comments Tree.Set_Project_File_Includes_Unkept_Comments (Node => Project, In_Tree => In_Tree, To => Tree.There_Are_Unkept_Comments); -- And restore the comment state that was saved Tree.Restore_And_Free (Project_Comment_State); Debug_Decrease_Indent; if Implicit_Project then Set_Name_Buffer (Current_Dir); Add_Char_To_Name_Buffer (Dir_Sep); In_Tree.Project_Nodes.Table (Project).Directory := Name_Find; end if; end Parse_Single_Project; ----------------------- -- Project_Name_From -- ----------------------- function Project_Name_From (Path_Name : String; Is_Config_File : Boolean) return Name_Id is Canonical : String (1 .. Path_Name'Length) := Path_Name; First : Natural := Canonical'Last; Last : Natural := First; Index : Positive; begin if Current_Verbosity = High then Debug_Output ("Project_Name_From (""" & Canonical & """)"); end if; -- If the path name is empty, return No_Name to indicate failure if First = 0 then return No_Name; end if; Canonical_Case_File_Name (Canonical); -- Look for the last dot in the path name while First > 0 and then Canonical (First) /= '.' loop First := First - 1; end loop; -- If we have a dot, check that it is followed by the correct extension if First > 0 and then Canonical (First) = '.' then if (not Is_Config_File and then Canonical (First .. Last) = Project_File_Extension and then First /= 1) or else (Is_Config_File and then Canonical (First .. Last) = Config_Project_File_Extension and then First /= 1) then -- Look for the last directory separator, if any First := First - 1; Last := First; while First > 0 and then Canonical (First) /= '/' and then Canonical (First) /= Dir_Sep loop First := First - 1; end loop; else -- Not the correct extension, return No_Name to indicate failure return No_Name; end if; -- If no dot in the path name, return No_Name to indicate failure else return No_Name; end if; First := First + 1; -- If the extension is the file name, return No_Name to indicate failure if First > Last then return No_Name; end if; -- Put the name in lower case into Name_Buffer Name_Len := Last - First + 1; Name_Buffer (1 .. Name_Len) := To_Lower (Canonical (First .. Last)); Index := 1; -- Check if it is a well formed project name. Return No_Name if it is -- ill formed. loop if not Is_Letter (Name_Buffer (Index)) then return No_Name; else loop Index := Index + 1; exit when Index >= Name_Len; if Name_Buffer (Index) = '_' then if Name_Buffer (Index + 1) = '_' then return No_Name; end if; end if; exit when Name_Buffer (Index) = '-'; if Name_Buffer (Index) /= '_' and then not Is_Alphanumeric (Name_Buffer (Index)) then return No_Name; end if; end loop; end if; if Index >= Name_Len then if Is_Alphanumeric (Name_Buffer (Name_Len)) then -- All checks have succeeded. Return name in Name_Buffer return Name_Find; else return No_Name; end if; elsif Name_Buffer (Index) = '-' then Index := Index + 1; end if; end loop; end Project_Name_From; ------------------------ -- Ultimate_Extending -- ------------------------ procedure Ultimate_Extending (Prj : in out Project_Node_Id; In_Tree : Project_Node_Tree_Ref) is Next : Project_Node_Id; begin loop Next := Extending_Project_Of (Project_Declaration_Of (Prj, In_Tree), In_Tree); exit when Next = Empty_Project_Node; Prj := Next; end loop; end Ultimate_Extending; end GPR.Part; gprbuild-25.0.0/gpr/src/gpr-part.ads000066400000000000000000000101111470075373400172160ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2000-2015, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- Implements the parsing of project files into a tree with GPR.Tree; use GPR.Tree; package GPR.Part is type Errout_Mode is (Always_Finalize, Finalize_If_Error, Never_Finalize); -- Whether Parse should call Errout.Finalize (which prints the error -- messages on stdout). When Never_Finalize is used, Errout is not reset -- either at the beginning of Parse. procedure Parse (In_Tree : Project_Node_Tree_Ref; Project : out Project_Node_Id; Project_File_Name : String; Errout_Handling : Errout_Mode := Always_Finalize; Packages_To_Check : String_List_Access; Store_Comments : Boolean := False; Current_Directory : String := ""; Is_Config_File : Boolean; Env : in out GPR.Tree.Environment; Target_Name : String := ""; Implicit_Project : Boolean := False); -- Parse project file and all its imported project files and create a tree. -- Return the node for the project (or Empty_Node if parsing failed). If -- Always_Errout_Finalize is True, Errout.Finalize is called in all cases, -- Otherwise, Errout.Finalize is only called if there are errors (but not -- if there are only warnings). Packages_To_Check indicates the packages -- where any unknown attribute produces an error. For other packages, an -- unknown attribute produces a warning. When Store_Comments is True, -- comments are stored in the parse tree. -- -- Current_Directory is used for optimization purposes only, avoiding extra -- system calls. -- -- Is_Config_File should be set to True if the project represents a config -- file (.cgpr) since some specific checks apply. -- -- Target_Name will be used to initialize the default project path, unless -- In_Tree.Project_Path has already been initialized (which is the -- recommended use). -- -- If Implicit_Project is True, the main project file being parsed is -- deemed to be in the current working directory, even if it is not the -- case. Implicit_Project is set to True when a tool such as gprbuild is -- invoked without a project file and is using an implicit project file -- that is virtually in the current working directory, but is physically -- in another directory. end GPR.Part; gprbuild-25.0.0/gpr/src/gpr-pp.adb000066400000000000000000001154131470075373400166610ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2020, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; use Ada.Characters.Handling; with GPR.Names; use GPR.Names; with GPR.Output; use GPR.Output; with GPR.Snames; package body GPR.PP is use GPR.Tree; Not_Tested : array (Project_Node_Kind) of Boolean := (others => True); procedure Indicate_Tested (Kind : Project_Node_Kind); -- Set the corresponding component of array Not_Tested to False. Only -- called by Debug pragmas. procedure Write_Char_Default (C : Character); procedure Write_Str_Default (S : String); procedure Write_Eol_Default; --------------------- -- Indicate_Tested -- --------------------- procedure Indicate_Tested (Kind : Project_Node_Kind) is begin Not_Tested (Kind) := False; end Indicate_Tested; ------------------ -- Pretty_Print -- ------------------ procedure Pretty_Print (Project : GPR.Project_Node_Id; In_Tree : GPR.Tree.Project_Node_Tree_Ref; Increment : Positive := 3; Eliminate_Empty_Case_Constructions : Boolean := False; Minimize_Empty_Lines : Boolean := False; W_Char : Write_Char_Ap := null; W_Eol : Write_Eol_Ap := null; W_Str : Write_Str_Ap := null; Backward_Compatibility : Boolean; Id : GPR.Project_Id := GPR.No_Project; Max_Line_Length : Max_Length_Of_Line := Max_Length_Of_Line'Last; Initial_Indent : Natural := 0) is procedure Print (Node : Project_Node_Id; Indent : Natural); -- A recursive procedure that traverses a project file tree and outputs -- its source. Current_Prj is the project that we are printing. This -- is used when printing attributes, since in nested packages they -- need to use a fully qualified name. procedure Output_Attribute_Name (Name : Name_Id; Indent : Natural); -- Outputs an attribute name, taking into account the value of -- Backward_Compatibility. procedure Output_Name (Name : Name_Id; Indent : Natural; Capitalize : Boolean := True); -- Outputs a name procedure Start_Line (Indent : Natural); -- Outputs the indentation at the beginning of the line procedure Output_Project_File (S : Name_Id); -- Output a project file name in one single string literal procedure Output_String (S : Name_Id; Indent : Natural; Single_Line : Boolean := False); -- Outputs a string using the default output procedures. If Single_Line -- is True, do not split the string on several lines. procedure Write_Empty_Line (Always : Boolean := False); -- Outputs an empty line, only if the previous line was not empty -- already and either Always is True or Minimize_Empty_Lines is False. procedure Write_Line (S : String); -- Outputs S followed by a new line procedure Write_String (S : String; Indent : Natural; Truncated : Boolean := False); -- Outputs S using Write_Str, starting a new line if line would become -- too long, when Truncated = False. When Truncated = True, only the -- part of the string that can fit on the line is output. procedure Write_End_Of_Line_Comment (Node : Project_Node_Id); -- Needs comment??? Write_Char : Write_Char_Ap := Write_Char_Default'Access; Write_Eol : Write_Eol_Ap := Write_Eol_Default'Access; Write_Str : Write_Str_Ap := Write_Str_Default'Access; -- These three access to procedure values are used for the output Last_Line_Is_Empty : Boolean := False; -- Used to avoid two consecutive empty lines Column : Natural := 0; -- Column number of the last character in the line. Used to avoid -- outputting lines longer than Max_Line_Length. First_With_In_List : Boolean := True; -- Indicate that the next with clause is first in a list such as -- with "A", "B"; -- First_With_In_List will be True for "A", but not for "B". --------------------------- -- Output_Attribute_Name -- --------------------------- procedure Output_Attribute_Name (Name : Name_Id; Indent : Natural) is begin if Backward_Compatibility then if Name = Snames.Name_Spec then Output_Name (Snames.Name_Specification, Indent); elsif Name = Snames.Name_Spec_Suffix then Output_Name (Snames.Name_Specification_Suffix, Indent); elsif Name = Snames.Name_Body then Output_Name (Snames.Name_Implementation, Indent); elsif Name = Snames.Name_Body_Suffix then Output_Name (Snames.Name_Implementation_Suffix, Indent); else Output_Name (Name, Indent); end if; else Output_Name (Name, Indent); end if; end Output_Attribute_Name; ----------------- -- Output_Name -- ----------------- procedure Output_Name (Name : Name_Id; Indent : Natural; Capitalize : Boolean := True) is Capital : Boolean := Capitalize; begin if Column = 0 and then Indent /= 0 then Start_Line (Indent + Increment); end if; Get_Name_String (Name); -- If line would become too long, create new line if Column + Name_Len > Max_Line_Length then Write_Eol.all; Column := 0; if Indent /= 0 then Start_Line (Indent + Increment); end if; end if; for J in 1 .. Name_Len loop if Capital then Write_Char (To_Upper (Name_Buffer (J))); else Write_Char (Name_Buffer (J)); end if; if Capitalize then Capital := Name_Buffer (J) = '_' or else Is_Digit (Name_Buffer (J)); end if; end loop; Column := Column + Name_Len; end Output_Name; ------------------------- -- Output_Project_File -- ------------------------- procedure Output_Project_File (S : Name_Id) is File_Name : constant String := Get_Name_String (S); begin Write_Char ('"'); for J in File_Name'Range loop if File_Name (J) = '"' then Write_Char ('"'); Write_Char ('"'); else Write_Char (File_Name (J)); end if; end loop; Write_Char ('"'); end Output_Project_File; ------------------- -- Output_String -- ------------------- procedure Output_String (S : Name_Id; Indent : Natural; Single_Line : Boolean := False) is begin if Column = 0 and then Indent /= 0 then Start_Line (Indent + Increment); end if; Get_Name_String (S); -- If line could become too long, create new line. Note that the -- number of characters on the line could be twice the number of -- character in the string (if every character is a '"') plus two -- (the initial and final '"'). if Column + Name_Len + Name_Len + 2 > Max_Line_Length then Write_Eol.all; Column := 0; if Indent /= 0 then Start_Line (Indent + Increment); end if; end if; Write_Char ('"'); Column := Column + 1; Get_Name_String (S); for J in 1 .. Name_Len loop if Name_Buffer (J) = '"' then Write_Char ('"'); Write_Char ('"'); Column := Column + 2; else Write_Char (Name_Buffer (J)); Column := Column + 1; end if; -- If the string does not fit on one line, cut it in parts and -- concatenate. if not Single_Line and then J < Name_Len and then Column >= Max_Line_Length then Write_Str (""" &"); Write_Eol.all; Column := 0; Start_Line (Indent + Increment); Write_Char ('"'); Column := Column + 1; end if; end loop; Write_Char ('"'); Column := Column + 1; end Output_String; ---------------- -- Start_Line -- ---------------- procedure Start_Line (Indent : Natural) is begin if not Minimize_Empty_Lines then Write_Str ((1 .. Indent => ' ')); Column := Column + Indent; end if; end Start_Line; ---------------------- -- Write_Empty_Line -- ---------------------- procedure Write_Empty_Line (Always : Boolean := False) is begin if (Always or else not Minimize_Empty_Lines) and then not Last_Line_Is_Empty then Write_Eol.all; Column := 0; Last_Line_Is_Empty := True; end if; end Write_Empty_Line; ------------------------------- -- Write_End_Of_Line_Comment -- ------------------------------- procedure Write_End_Of_Line_Comment (Node : Project_Node_Id) is Value : constant Name_Id := End_Of_Line_Comment (Node, In_Tree); begin if Value /= No_Name then Write_String (" --", 0); Write_String (Get_Name_String (Value), 0, Truncated => True); end if; Write_Line (""); end Write_End_Of_Line_Comment; ---------------- -- Write_Line -- ---------------- procedure Write_Line (S : String) is begin Write_String (S, 0); Last_Line_Is_Empty := False; Write_Eol.all; Column := 0; end Write_Line; ------------------ -- Write_String -- ------------------ procedure Write_String (S : String; Indent : Natural; Truncated : Boolean := False) is Length : Natural := S'Length; begin if Column = 0 and then Indent /= 0 then Start_Line (Indent + Increment); end if; -- If the string would not fit on the line, start a new line if Column + Length > Max_Line_Length then if Truncated then Length := Max_Line_Length - Column; else Write_Eol.all; Column := 0; if Indent /= 0 then Start_Line (Indent + Increment); end if; end if; end if; Write_Str (S (S'First .. S'First + Length - 1)); Column := Column + Length; end Write_String; ----------- -- Print -- ----------- procedure Print (Node : Project_Node_Id; Indent : Natural) is begin if Present (Node) then case Kind_Of (Node, In_Tree) is when N_Project => pragma Debug (Indicate_Tested (N_Project)); if Present (First_With_Clause_Of (Node, In_Tree)) then -- with clause(s) First_With_In_List := True; Print (First_With_Clause_Of (Node, In_Tree), Indent); Write_Empty_Line (Always => True); end if; Print (First_Comment_Before (Node, In_Tree), Indent); Start_Line (Indent); case Project_Qualifier_Of (Node, In_Tree) is when Unspecified | Standard => null; when Aggregate => Write_String ("aggregate ", Indent); when Aggregate_Library => Write_String ("aggregate library ", Indent); when Library => Write_String ("library ", Indent); when Configuration => Write_String ("configuration ", Indent); when Abstract_Project => Write_String ("abstract ", Indent); end case; Write_String ("project ", Indent); if Id /= GPR.No_Project then Output_Name (Id.Display_Name, Indent); else Output_Name (Name_Of (Node, In_Tree), Indent); end if; -- Check if this project extends another project if Extended_Project_Path_Of (Node, In_Tree) /= No_Path then Write_String (" extends ", Indent); if Is_Extending_All (Node, In_Tree) then Write_String ("all ", Indent); end if; Output_Project_File (Name_Id (Extended_Project_Path_Of (Node, In_Tree))); end if; Write_String (" is", Indent); Write_End_Of_Line_Comment (Node); Print (First_Comment_After (Node, In_Tree), Indent + Increment); Write_Empty_Line (Always => True); -- Output all of the declarations in the project Print (Project_Declaration_Of (Node, In_Tree), Indent); Print (First_Comment_Before_End (Node, In_Tree), Indent + Increment); Start_Line (Indent); Write_String ("end ", Indent); if Id /= GPR.No_Project then Output_Name (Id.Display_Name, Indent); else Output_Name (Name_Of (Node, In_Tree), Indent); end if; Write_Line (";"); Print (First_Comment_After_End (Node, In_Tree), Indent); when N_With_Clause => pragma Debug (Indicate_Tested (N_With_Clause)); -- The with clause will sometimes contain an invalid name -- when we are importing a virtual project from an extending -- all project. Do not output anything in this case. if Name_Of (Node, In_Tree) /= No_Name and then String_Value_Of (Node, In_Tree) /= No_Name then if First_With_In_List then Print (First_Comment_Before (Node, In_Tree), Indent); Start_Line (Indent); if No (Non_Limited_Project_Node_Of (Node, In_Tree)) then Write_String ("limited ", Indent); end if; Write_String ("with ", Indent); end if; -- Output the project name without concatenation, even if -- the line is too long. Output_Project_File (String_Value_Of (Node, In_Tree)); if Is_Not_Last_In_List (Node, In_Tree) then Write_String (", ", Indent); First_With_In_List := False; else Write_String (";", Indent); Write_End_Of_Line_Comment (Node); Print (First_Comment_After (Node, In_Tree), Indent); First_With_In_List := True; end if; end if; Print (Next_With_Clause_Of (Node, In_Tree), Indent); when N_Project_Declaration => pragma Debug (Indicate_Tested (N_Project_Declaration)); if Present (First_Declarative_Item_Of (Node, In_Tree)) then Print (First_Declarative_Item_Of (Node, In_Tree), Indent + Increment); Write_Empty_Line (Always => True); end if; when N_Declarative_Item => pragma Debug (Indicate_Tested (N_Declarative_Item)); Print (Current_Item_Node (Node, In_Tree), Indent); Print (Next_Declarative_Item (Node, In_Tree), Indent); when N_Package_Declaration => pragma Debug (Indicate_Tested (N_Package_Declaration)); Write_Empty_Line (Always => True); Print (First_Comment_Before (Node, In_Tree), Indent); Start_Line (Indent); Write_String ("package ", Indent); Output_Name (Name_Of (Node, In_Tree), Indent); if Present (Project_Of_Renamed_Package_Of (Node, In_Tree)) then if No (First_Declarative_Item_Of (Node, In_Tree)) then Write_String (" renames ", Indent); else Write_String (" extends ", Indent); end if; Output_Name (Name_Of (Project_Of_Renamed_Package_Of (Node, In_Tree), In_Tree), Indent); Write_String (".", Indent); Output_Name (Name_Of (Node, In_Tree), Indent); end if; if Present (Project_Of_Renamed_Package_Of (Node, In_Tree)) and then No (First_Declarative_Item_Of (Node, In_Tree)) then Write_String (";", Indent); Write_End_Of_Line_Comment (Node); Print (First_Comment_After_End (Node, In_Tree), Indent); else Write_String (" is", Indent); Write_End_Of_Line_Comment (Node); Print (First_Comment_After (Node, In_Tree), Indent + Increment); if Present (First_Declarative_Item_Of (Node, In_Tree)) then Print (First_Declarative_Item_Of (Node, In_Tree), Indent + Increment); end if; Print (First_Comment_Before_End (Node, In_Tree), Indent + Increment); Start_Line (Indent); Write_String ("end ", Indent); Output_Name (Name_Of (Node, In_Tree), Indent); Write_Line (";"); Print (First_Comment_After_End (Node, In_Tree), Indent); Write_Empty_Line; end if; when N_String_Type_Declaration => pragma Debug (Indicate_Tested (N_String_Type_Declaration)); Print (First_Comment_Before (Node, In_Tree), Indent); Start_Line (Indent); Write_String ("type ", Indent); Output_Name (Name_Of (Node, In_Tree), Indent); Write_Line (" is"); Start_Line (Indent + Increment); Write_String ("(", Indent); declare String_Node : Project_Node_Id := First_Literal_String (Node, In_Tree); begin while Present (String_Node) loop Output_String (String_Value_Of (String_Node, In_Tree), Indent, Single_Line => True); String_Node := Next_Literal_String (String_Node, In_Tree); if Present (String_Node) then Write_String (", ", Indent); end if; end loop; end; Write_String (");", Indent); Write_End_Of_Line_Comment (Node); Print (First_Comment_After (Node, In_Tree), Indent); when N_Literal_String => pragma Debug (Indicate_Tested (N_Literal_String)); Output_String (String_Value_Of (Node, In_Tree), Indent); if Source_Index_Of (Node, In_Tree) /= 0 then Write_String (" at", Indent); Write_String (Source_Index_Of (Node, In_Tree)'Img, Indent); end if; when N_Attribute_Declaration => pragma Debug (Indicate_Tested (N_Attribute_Declaration)); Print (First_Comment_Before (Node, In_Tree), Indent); Start_Line (Indent); Write_String ("for ", Indent); Output_Attribute_Name (Name_Of (Node, In_Tree), Indent); if Associative_Array_Index_Of (Node, In_Tree) /= No_Name then Write_String (" (", Indent); Output_String (Associative_Array_Index_Of (Node, In_Tree), Indent, Single_Line => True); if Source_Index_Of (Node, In_Tree) /= 0 then Write_String (" at", Indent); Write_String (Source_Index_Of (Node, In_Tree)'Img, Indent); end if; Write_String (")", Indent); end if; Write_String (" use ", Indent); if Present (Expression_Of (Node, In_Tree)) then Print (Expression_Of (Node, In_Tree), Indent); else -- Full associative array declaration if Present (Associative_Project_Of (Node, In_Tree)) then Output_Name (Name_Of (Associative_Project_Of (Node, In_Tree), In_Tree), Indent); if Present (Associative_Package_Of (Node, In_Tree)) then Write_String (".", Indent); Output_Name (Name_Of (Associative_Package_Of (Node, In_Tree), In_Tree), Indent); end if; elsif Present (Associative_Package_Of (Node, In_Tree)) then Output_Name (Name_Of (Associative_Package_Of (Node, In_Tree), In_Tree), Indent); end if; Write_String ("'", Indent); Output_Attribute_Name (Name_Of (Node, In_Tree), Indent); end if; Write_String (";", Indent); Write_End_Of_Line_Comment (Node); Print (First_Comment_After (Node, In_Tree), Indent); when N_Typed_Variable_Declaration => declare Type_Node : constant Project_Node_Id := String_Type_Of (Node, In_Tree); Type_Project : constant Project_Node_Id := Project_Node_Of (Type_Node, In_Tree); begin pragma Debug (Indicate_Tested (N_Typed_Variable_Declaration)); Print (First_Comment_Before (Node, In_Tree), Indent); Start_Line (Indent); Output_Name (Name_Of (Node, In_Tree), Indent); Write_String (" : ", Indent); if Present (Project_Node_Of (Node, In_Tree)) and then Project_Node_Of (Node, In_Tree) /= Type_Project then Output_Name (Name_Of (Type_Project, In_Tree), Indent); Write_Char ('.'); end if; Output_Name (Name_Of (Type_Node, In_Tree), Indent); Write_String (" := ", Indent); Print (Expression_Of (Node, In_Tree), Indent); Write_String (";", Indent); Write_End_Of_Line_Comment (Node); Print (First_Comment_After (Node, In_Tree), Indent); end; when N_Variable_Declaration => pragma Debug (Indicate_Tested (N_Variable_Declaration)); Print (First_Comment_Before (Node, In_Tree), Indent); Start_Line (Indent); Output_Name (Name_Of (Node, In_Tree), Indent); Write_String (" := ", Indent); Print (Expression_Of (Node, In_Tree), Indent); Write_String (";", Indent); Write_End_Of_Line_Comment (Node); Print (First_Comment_After (Node, In_Tree), Indent); when N_Expression => pragma Debug (Indicate_Tested (N_Expression)); declare Term : Project_Node_Id := First_Term (Node, In_Tree); begin while Present (Term) loop Print (Term, Indent); Term := Next_Term (Term, In_Tree); if Present (Term) then Write_String (" & ", Indent); end if; end loop; end; when N_Term => pragma Debug (Indicate_Tested (N_Term)); Print (Current_Term (Node, In_Tree), Indent); when N_Literal_String_List => pragma Debug (Indicate_Tested (N_Literal_String_List)); Write_String ("(", Indent); declare Expression : Project_Node_Id := First_Expression_In_List (Node, In_Tree); begin while Present (Expression) loop Print (Expression, Indent); Expression := Next_Expression_In_List (Expression, In_Tree); if Present (Expression) then Write_String (", ", Indent); end if; end loop; end; Write_String (")", Indent); when N_Variable_Reference => pragma Debug (Indicate_Tested (N_Variable_Reference)); if Present (Project_Node_Of (Node, In_Tree)) then Output_Name (Name_Of (Project_Node_Of (Node, In_Tree), In_Tree), Indent); Write_String (".", Indent); end if; if Present (Package_Node_Of (Node, In_Tree)) then Output_Name (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree), Indent); Write_String (".", Indent); end if; Output_Name (Name_Of (Node, In_Tree), Indent); when N_External_Value => pragma Debug (Indicate_Tested (N_External_Value)); if Expression_Kind_Of (Node, In_Tree) = List then Write_String ("external_as_list (", Indent); else Write_String ("external (", Indent); end if; Print (External_Reference_Of (Node, In_Tree), Indent); if Present (External_Default_Of (Node, In_Tree)) then Write_String (", ", Indent); Print (External_Default_Of (Node, In_Tree), Indent); end if; Write_String (")", Indent); when N_Split => pragma Debug (Indicate_Tested (N_Split)); Write_String ("split (", Indent); Print (String_Argument_Of (Node, In_Tree), Indent); Write_String (", ", Indent); Print (Separator_Of (Node, In_Tree), Indent); Write_String (")", Indent); when N_Attribute_Reference => pragma Debug (Indicate_Tested (N_Attribute_Reference)); if Present (Project_Node_Of (Node, In_Tree)) and then Project_Node_Of (Node, In_Tree) /= Project then Output_Name (Name_Of (Project_Node_Of (Node, In_Tree), In_Tree), Indent); if Present (Package_Node_Of (Node, In_Tree)) then Write_String (".", Indent); Output_Name (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree), Indent); end if; elsif Present (Package_Node_Of (Node, In_Tree)) then Output_Name (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree), Indent); else Write_String ("project", Indent); end if; Write_String ("'", Indent); Output_Attribute_Name (Name_Of (Node, In_Tree), Indent); declare Index : constant Name_Id := Associative_Array_Index_Of (Node, In_Tree); begin if Index /= No_Name then Write_String (" (", Indent); Output_String (Index, Indent, Single_Line => True); Write_String (")", Indent); end if; end; when N_Case_Construction => pragma Debug (Indicate_Tested (N_Case_Construction)); declare Case_Item : Project_Node_Id; Is_Non_Empty : Boolean := False; begin Case_Item := First_Case_Item_Of (Node, In_Tree); while Present (Case_Item) loop if Present (First_Declarative_Item_Of (Case_Item, In_Tree)) or else not Eliminate_Empty_Case_Constructions then Is_Non_Empty := True; exit; end if; Case_Item := Next_Case_Item (Case_Item, In_Tree); end loop; if Is_Non_Empty then Write_Empty_Line; Print (First_Comment_Before (Node, In_Tree), Indent); Start_Line (Indent); Write_String ("case ", Indent); Print (Case_Variable_Reference_Of (Node, In_Tree), Indent); Write_String (" is", Indent); Write_End_Of_Line_Comment (Node); Print (First_Comment_After (Node, In_Tree), Indent + Increment); declare Case_Item : Project_Node_Id := First_Case_Item_Of (Node, In_Tree); begin while Present (Case_Item) loop pragma Assert (Kind_Of (Case_Item, In_Tree) = N_Case_Item); Print (Case_Item, Indent + Increment); Case_Item := Next_Case_Item (Case_Item, In_Tree); end loop; end; Print (First_Comment_Before_End (Node, In_Tree), Indent + Increment); Start_Line (Indent); Write_Line ("end case;"); Print (First_Comment_After_End (Node, In_Tree), Indent); end if; end; when N_Case_Item => pragma Debug (Indicate_Tested (N_Case_Item)); if Present (First_Declarative_Item_Of (Node, In_Tree)) or else not Eliminate_Empty_Case_Constructions then Write_Empty_Line; Print (First_Comment_Before (Node, In_Tree), Indent); Start_Line (Indent); Write_String ("when ", Indent); if No (First_Choice_Of (Node, In_Tree)) then Write_String ("others", Indent); else declare Label : Project_Node_Id := First_Choice_Of (Node, In_Tree); begin while Present (Label) loop Print (Label, Indent); Label := Next_Literal_String (Label, In_Tree); if Present (Label) then Write_String (" | ", Indent); end if; end loop; end; end if; Write_String (" =>", Indent); Write_End_Of_Line_Comment (Node); Print (First_Comment_After (Node, In_Tree), Indent + Increment); declare First : constant Project_Node_Id := First_Declarative_Item_Of (Node, In_Tree); begin if No (First) then Write_Empty_Line; else Print (First, Indent + Increment); end if; end; end if; when N_Comment_Zones => -- Nothing to do, because it will not be processed directly null; when N_Comment => pragma Debug (Indicate_Tested (N_Comment)); if Follows_Empty_Line (Node, In_Tree) then Write_Empty_Line; end if; Start_Line (Indent); Write_String ("--", Indent); Write_String (Get_Name_String (String_Value_Of (Node, In_Tree)), Indent, Truncated => True); Write_Line (""); if Is_Followed_By_Empty_Line (Node, In_Tree) then Write_Empty_Line; end if; Print (Next_Comment (Node, In_Tree), Indent); end case; end if; end Print; -- Start of processing for Pretty_Print begin if W_Char = null then Write_Char := Write_Char_Default'Access; else Write_Char := W_Char; end if; if W_Eol = null then Write_Eol := Write_Eol_Default'Access; else Write_Eol := W_Eol; end if; if W_Str = null then Write_Str := Write_Str_Default'Access; else Write_Str := W_Str; end if; Print (Project, Initial_Indent); end Pretty_Print; ----------------------- -- Output_Statistics -- ----------------------- procedure Output_Statistics is begin Write_Line ("Project_Node_Kinds not tested:"); for Kind in Project_Node_Kind loop if Kind /= N_Comment_Zones and then Not_Tested (Kind) then Write_Str (" "); Write_Line (Project_Node_Kind'Image (Kind)); end if; end loop; Write_Eol; end Output_Statistics; --------- -- wpr -- --------- procedure wpr (Project : GPR.Project_Node_Id; In_Tree : GPR.Tree.Project_Node_Tree_Ref) is begin Pretty_Print (Project, In_Tree, Backward_Compatibility => False); end wpr; ------------------------ -- Write_Char_Default -- ------------------------ procedure Write_Char_Default (C : Character) is begin Write_Char (C); end Write_Char_Default; ----------------------- -- Write_Str_Default -- ----------------------- procedure Write_Str_Default (S : String) is begin Write_Str (S); end Write_Str_Default; ----------------------- -- Write_Eol_Default -- ----------------------- procedure Write_Eol_Default is begin Write_Eol; end Write_Eol_Default; end GPR.PP; gprbuild-25.0.0/gpr/src/gpr-pp.ads000066400000000000000000000117551470075373400167060ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2015, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package is the Project File Pretty Printer -- Used to output a project file from a project file tree. -- Used by gnatname to update or create project files. -- Also used GPS to display project file trees. -- Also be used for debugging tools that create project file trees. with GPR.Tree; package GPR.PP is -- The following access to procedure types are used to redirect output when -- calling Pretty_Print. type Write_Char_Ap is access procedure (C : Character); type Write_Eol_Ap is access procedure; type Write_Str_Ap is access procedure (S : String); subtype Max_Length_Of_Line is Positive range 50 .. 255; procedure Pretty_Print (Project : GPR.Project_Node_Id; In_Tree : GPR.Tree.Project_Node_Tree_Ref; Increment : Positive := 3; Eliminate_Empty_Case_Constructions : Boolean := False; Minimize_Empty_Lines : Boolean := False; W_Char : Write_Char_Ap := null; W_Eol : Write_Eol_Ap := null; W_Str : Write_Str_Ap := null; Backward_Compatibility : Boolean; Id : Project_Id := No_Project; Max_Line_Length : Max_Length_Of_Line := Max_Length_Of_Line'Last; Initial_Indent : Natural := 0); -- Output a project file, using either the default output routines, or the -- ones specified by W_Char, W_Eol and W_Str. -- -- Increment is the number of spaces for each indentation level -- -- W_Char, W_Eol and W_Str can be used to change the default output -- procedures. The default values force the output to Standard_Output. -- -- If Eliminate_Empty_Case_Constructions is True, then case constructions -- and case items that do not include any declarations will not be output. -- -- If Minimize_Empty_Lines is True, empty lines will be output only after -- the last with clause, after the line declaring the project name, after -- the last declarative item of the project and before each package -- declaration. Otherwise, more empty lines are output. -- -- If Backward_Compatibility is True, then new attributes (Spec, -- Spec_Suffix, Body, Body_Suffix) will be replaced by obsolete ones -- (Specification, Specification_Suffix, Implementation, -- Implementation_Suffix). -- -- Id is used to compute the display name of the project including its -- proper casing. -- -- Max_Line_Length is the maximum line length in the project file -- -- Initial_Indent is the initial indentation private procedure Output_Statistics; -- This procedure can be used after one or more calls to Pretty_Print to -- display what Project_Node_Kinds have not been exercised by the call(s) -- to Pretty_Print. It is used only for testing purposes. procedure wpr (Project : GPR.Project_Node_Id; In_Tree : GPR.Tree.Project_Node_Tree_Ref); -- Wrapper for use from gdb: call Pretty_Print with default parameters end GPR.PP; gprbuild-25.0.0/gpr/src/gpr-proc.adb000066400000000000000000004014731470075373400172110ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2022, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Containers.Vectors; with Ada.Strings.Fixed; use Ada.Strings.Fixed; with GNAT.Case_Util; use GNAT.Case_Util; with GNAT.HTable; with GPR.Attr; use GPR.Attr; with GPR.Env; use GPR.Env; with GPR.Err; use GPR.Err; with GPR.Erroutc; use GPR.Erroutc; with GPR.Ext; use GPR.Ext; with GPR.Names; use GPR.Names; with GPR.Nmsc; use GPR.Nmsc; with GPR.Opt; use GPR.Opt; with GPR.Osint; use GPR.Osint; with GPR.Output; use GPR.Output; with GPR.Part; with GPR.Util; with GPR.Snames; package body GPR.Proc is package Processed_Projects is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, Element => Project_Id, No_Element => No_Project, Key => Name_Id, Hash => Hash, Equal => "="); -- This hash table contains all processed projects package Unit_Htable is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, Element => Source_Id, No_Element => No_Source, Key => Name_Id, Hash => Hash, Equal => "="); -- This hash table contains all processed projects Runtime_Defaults : Language_Maps.Map; -- Stores the default values of 'Runtime names for the various languages procedure Add (To_Exp : in out Name_Id; Str : Name_Id); -- Concatenate two strings and returns another string if both -- arguments are not null string. -- In the following procedures, we are expected to guess the meaning of -- the parameters from their names, this is never a good idea, comments -- should be added precisely defining every formal ??? procedure Add_Attributes (Project : Project_Id; Project_Name : Name_Id; Project_Dir : Name_Id; Shared : Shared_Project_Tree_Data_Access; Decl : in out Declarations; First : Attribute_Node_Id; Project_Level : Boolean); -- Add all attributes, starting with First, with their default values to -- the package or project with declarations Decl. procedure Check (In_Tree : Project_Tree_Ref; Project : Project_Id; Node_Tree : GPR.Tree.Project_Node_Tree_Ref; Flags : Processing_Flags); -- Set all projects to not checked, then call Recursive_Check for the -- main project Project. Project is set to No_Project if errors occurred. -- Current_Dir is for optimization purposes, avoiding extra system calls. -- If Allow_Duplicate_Basenames, then files with the same base names are -- authorized within a project for source-based languages (never for unit -- based languages) procedure Copy_Package_Declarations (From : Declarations; To : in out Declarations; New_Loc : Source_Ptr; Restricted : Boolean; Shared : Shared_Project_Tree_Data_Access); -- Copy a package declaration From to To for a renamed package. Change the -- locations of all the attributes to New_Loc. When Restricted is -- True, do not copy attributes Body, Spec, Implementation, Specification -- and Linker_Options. function Imported_Or_Extended_Project_From (Project : Project_Id; With_Name : Name_Id; No_Extending : Boolean := False) return Project_Id; -- Find an imported or extended project of Project whose name is With_Name. -- When No_Extending is True, do not look for extending projects, returns -- the exact project whose name is With_Name. function Package_From (Project : Project_Id; Shared : Shared_Project_Tree_Data_Access; With_Name : Name_Id) return Package_Id; -- Find the package of Project whose name is With_Name procedure Process_Declarative_Items (Project : Project_Id; In_Tree : Project_Tree_Ref; From_Project_Node : Project_Node_Id; Node_Tree : Project_Node_Tree_Ref; Env : GPR.Tree.Environment; Pkg : Package_Id; Item : Project_Node_Id; Child_Env : in out GPR.Tree.Environment); -- Process declarative items starting with From_Project_Node, and put them -- in declarations Decl. This is a recursive procedure; it calls itself for -- a package declaration or a case construction. -- -- Child_Env is the modified environment after seeing declarations like -- "for External(...) use" or "for Project_Path use" in aggregate projects. -- It should have been initialized first. procedure Recursive_Process (In_Tree : Project_Tree_Ref; Project : out Project_Id; Packages_To_Check : String_List_Access; From_Project_Node : Project_Node_Id; From_Project_Node_Tree : Project_Node_Tree_Ref; Env : in out GPR.Tree.Environment; Extended_By : Project_Id; From_Encapsulated_Lib : Boolean; On_New_Tree_Loaded : Tree_Loaded_Callback := null); -- Process project with node From_Project_Node in the tree. Do nothing if -- From_Project_Node is Empty_Node. If project has already been processed, -- simply return its project id. Otherwise create a new project id, mark it -- as processed, call itself recursively for all imported projects and a -- extended project, if any. Then process the declarative items of the -- project. -- -- Is_Root_Project should be true only for the project that the user -- explicitly loaded. In the context of aggregate projects, only that -- project is allowed to modify the environment that will be used to load -- projects (Child_Env). -- -- From_Encapsulated_Lib is true if we are parsing a project from -- encapsulated library dependencies. -- -- If specified, On_New_Tree_Loaded is called after each aggregated project -- has been processed succesfully. function Get_Attribute_Index (Tree : Project_Node_Tree_Ref; Attr : Project_Node_Id; Index : Name_Id) return Name_Id; -- Copy the index of the attribute into Name_Buffer, converting to lower -- case if the attribute is case-insensitive. --------- -- Add -- --------- procedure Add (To_Exp : in out Name_Id; Str : Name_Id) is begin if To_Exp in No_Name | Empty_String then -- To_Exp is nil or empty. The result is Str To_Exp := Str; -- If Str is nil, then do not change To_Ext elsif Str not in No_Name | Empty_String then Get_Name_String (To_Exp); Get_Name_String_And_Append (Str); To_Exp := Name_Find; end if; end Add; -------------------- -- Add_Attributes -- -------------------- procedure Add_Attributes (Project : Project_Id; Project_Name : Name_Id; Project_Dir : Name_Id; Shared : Shared_Project_Tree_Data_Access; Decl : in out Declarations; First : Attribute_Node_Id; Project_Level : Boolean) is The_Attribute : Attribute_Node_Id := First; begin while The_Attribute /= Empty_Attribute loop if Attribute_Kind_Of (The_Attribute) = Single then declare New_Attribute : Variable_Value; begin case Variable_Kind_Of (The_Attribute) is -- Undefined should not happen when Undefined => pragma Assert (False, "attribute with an undefined kind"); raise Program_Error; -- Single attributes have a default value of empty string when Single => New_Attribute := (Project => Project, Kind => Single, Location => No_Location, Default => True, String_Type => Empty_Project_Node, Value => Empty_String, Index => 0, From_Implicit_Target => False); -- Special cases of 'Name and -- 'Project_Dir. if Project_Level then if Attribute_Name_Of (The_Attribute) = Snames.Name_Name then New_Attribute.Value := Project_Name; elsif Attribute_Name_Of (The_Attribute) = Snames.Name_Project_Dir then New_Attribute.Value := Project_Dir; end if; end if; -- List attributes have a default value of nil list when List => New_Attribute := (Project => Project, Kind => List, Location => No_Location, Default => True, String_Type => Empty_Project_Node, Values => Nil_String, Concat => Is_Config_Concatenable (The_Attribute), From_Implicit_Target => False); end case; Variable_Element_Table.Increment_Last (Shared.Variable_Elements); Shared.Variable_Elements.Table (Variable_Element_Table.Last (Shared.Variable_Elements)) := (Next => Decl.Attributes, Name => Attribute_Name_Of (The_Attribute), Value => New_Attribute); Decl.Attributes := Variable_Element_Table.Last (Shared.Variable_Elements); end; end if; The_Attribute := Next_Attribute (After => The_Attribute); end loop; end Add_Attributes; ----------- -- Check -- ----------- procedure Check (In_Tree : Project_Tree_Ref; Project : Project_Id; Node_Tree : GPR.Tree.Project_Node_Tree_Ref; Flags : Processing_Flags) is begin Process_Naming_Scheme (In_Tree, Project, Node_Tree, Flags); -- Set the Other_Part field for the units declare Source1 : Source_Id; Name : Name_Id; Source2 : Source_Id; Iter : Source_Iterator; begin Unit_Htable.Reset; Iter := For_Each_Source (In_Tree); loop Source1 := GPR.Element (Iter); exit when Source1 = No_Source; if Source1.Unit /= No_Unit_Index then Name := Source1.Unit.Name; Source2 := Unit_Htable.Get (Name); if Source2 = No_Source then Unit_Htable.Set (K => Name, E => Source1); else Unit_Htable.Remove (Name); end if; end if; Next (Iter); end loop; end; end Check; ------------------------------- -- Copy_Package_Declarations -- ------------------------------- procedure Copy_Package_Declarations (From : Declarations; To : in out Declarations; New_Loc : Source_Ptr; Restricted : Boolean; Shared : Shared_Project_Tree_Data_Access) is V1 : Variable_Id; V2 : Variable_Id := No_Variable; Var : Variable; A1 : Array_Id; A2 : Array_Id := No_Array; Arr : Array_Data; E1 : Array_Element_Id; E2 : Array_Element_Id := No_Array_Element; Elm : Array_Element; begin -- To avoid references in error messages to attribute declarations in -- an original package that has been renamed, copy all the attribute -- declarations of the package and change all locations to New_Loc, -- the location of the renamed package. -- First single attributes V1 := From.Attributes; while V1 /= No_Variable loop -- Copy the attribute Var := Shared.Variable_Elements.Table (V1); V1 := Var.Next; -- Do not copy the value of attribute Linker_Options if Restricted if Restricted and then Var.Name = Snames.Name_Linker_Options then Var.Value.Values := Nil_String; end if; -- Remove the Next component Var.Next := No_Variable; -- Change the location to New_Loc Var.Value.Location := New_Loc; Variable_Element_Table.Increment_Last (Shared.Variable_Elements); -- Put in new declaration if To.Attributes = No_Variable then To.Attributes := Variable_Element_Table.Last (Shared.Variable_Elements); else Shared.Variable_Elements.Table (V2).Next := Variable_Element_Table.Last (Shared.Variable_Elements); end if; V2 := Variable_Element_Table.Last (Shared.Variable_Elements); Shared.Variable_Elements.Table (V2) := Var; end loop; -- Then the associated array attributes A1 := From.Arrays; while A1 /= No_Array loop Arr := Shared.Arrays.Table (A1); A1 := Arr.Next; -- Remove the Next component Arr.Next := No_Array; Array_Table.Increment_Last (Shared.Arrays); -- Create new Array declaration if To.Arrays = No_Array then To.Arrays := Array_Table.Last (Shared.Arrays); else Shared.Arrays.Table (A2).Next := Array_Table.Last (Shared.Arrays); end if; A2 := Array_Table.Last (Shared.Arrays); -- Don't store the array as its first element has not been set yet -- Copy the array elements of the array E1 := Arr.Value; Arr.Value := No_Array_Element; while E1 /= No_Array_Element loop -- Copy the array element Elm := Shared.Array_Elements.Table (E1); E1 := Elm.Next; -- Remove the Next component Elm.Next := No_Array_Element; Elm.Restricted := Restricted; -- Change the location Elm.Value.Location := New_Loc; Array_Element_Table.Increment_Last (Shared.Array_Elements); -- Create new array element if Arr.Value = No_Array_Element then Arr.Value := Array_Element_Table.Last (Shared.Array_Elements); else Shared.Array_Elements.Table (E2).Next := Array_Element_Table.Last (Shared.Array_Elements); end if; E2 := Array_Element_Table.Last (Shared.Array_Elements); Shared.Array_Elements.Table (E2) := Elm; end loop; -- Finally, store the new array Shared.Arrays.Table (A2) := Arr; end loop; end Copy_Package_Declarations; ------------------------- -- Get_Attribute_Index -- ------------------------- function Get_Attribute_Index (Tree : Project_Node_Tree_Ref; Attr : Project_Node_Id; Index : Name_Id) return Name_Id is begin if Index = All_Other_Names or else not Case_Insensitive (Attr, Tree) then return Index; end if; Get_Name_String (Index); To_Lower (Name_Buffer (1 .. Name_Len)); return Name_Find; end Get_Attribute_Index; ---------------- -- Expression -- ---------------- function Expression (Project : Project_Id; Shared : Shared_Project_Tree_Data_Access; From_Project_Node : Project_Node_Id; From_Project_Node_Tree : Project_Node_Tree_Ref; Env : GPR.Tree.Environment; Pkg : Package_Id; First_Term : Project_Node_Id; Kind : Variable_Kind) return Variable_Value is The_Term : Project_Node_Id; -- The term in the expression list The_Current_Term : Project_Node_Id := Empty_Project_Node; -- The current term node id Result : Variable_Value (Kind => Kind); -- The returned result Last : String_List_Id := Nil_String; -- Reference to the last string elements in Result, when Kind is List Current_Term_Kind : Project_Node_Kind; procedure Split (Source : Project_Node_Id; Separator : Project_Node_Id); -- Process N_Split node ----------- -- Split -- ----------- procedure Split (Source : Project_Node_Id; Separator : Project_Node_Id) is use GPR.Util; Source_Var : constant Variable_Value := Expression (Project => Project, Shared => Shared, From_Project_Node => Source, From_Project_Node_Tree => From_Project_Node_Tree, Env => Env, Pkg => Pkg, First_Term => Tree.First_Term (Source, From_Project_Node_Tree), Kind => Single); Separator_Var : constant Variable_Value := Expression (Project => Project, Shared => Shared, From_Project_Node => Separator, From_Project_Node_Tree => From_Project_Node_Tree, Env => Env, Pkg => Pkg, First_Term => Tree.First_Term (Separator, From_Project_Node_Tree), Kind => Single); Source_String : constant String := Get_Name_String (Source_Var.Value); Separator_String : constant String := Get_Name_String (Separator_Var.Value); Names : constant Name_Array_Type := Split (Source => Source_String, Separator => Separator_String); begin for J in Names'Range loop String_Element_Table.Increment_Last (Shared.String_Elements); if Last = Nil_String then Result.Values := String_Element_Table.Last (Shared.String_Elements); else Shared.String_Elements.Table (Last).Next := String_Element_Table.Last (Shared.String_Elements); end if; Last := String_Element_Table.Last (Shared.String_Elements); Shared.String_Elements.Table (Last) := (Value => Names (J), Display_Value => No_Name, Location => Location_Of (The_Current_Term, From_Project_Node_Tree), Next => Nil_String, Index => 0); end loop; end Split; begin Result.Project := Project; Result.Location := Location_Of (First_Term, From_Project_Node_Tree); -- Process each term of the expression, starting with First_Term The_Term := First_Term; while Present (The_Term) loop The_Current_Term := Current_Term (The_Term, From_Project_Node_Tree); if Present (The_Current_Term) then Current_Term_Kind := Kind_Of (The_Current_Term, From_Project_Node_Tree); case Current_Term_Kind is when N_Literal_String => case Kind is when Undefined => -- Should never happen pragma Assert (False, "Undefined expression kind"); raise Program_Error; when Single => Add (Result.Value, String_Value_Of (The_Current_Term, From_Project_Node_Tree)); Result.Index := Source_Index_Of (The_Current_Term, From_Project_Node_Tree); when List => String_Element_Table.Increment_Last (Shared.String_Elements); if Last = Nil_String then -- This can happen in an expression like () & "toto" Result.Values := String_Element_Table.Last (Shared.String_Elements); else Shared.String_Elements.Table (Last).Next := String_Element_Table.Last (Shared.String_Elements); end if; Last := String_Element_Table.Last (Shared.String_Elements); Shared.String_Elements.Table (Last) := (Value => String_Value_Of (The_Current_Term, From_Project_Node_Tree), Index => Source_Index_Of (The_Current_Term, From_Project_Node_Tree), Display_Value => No_Name, Location => Location_Of (The_Current_Term, From_Project_Node_Tree), Next => Nil_String); end case; when N_Literal_String_List => if Kind = Single then -- Expected value does not correspond to actual. Error check -- will be later, in Parse_Attribute_Declaration. return Result; end if; declare String_Node : Project_Node_Id := First_Expression_In_List (The_Current_Term, From_Project_Node_Tree); Value : Variable_Value; begin if Present (String_Node) then -- If String_Node is nil, it is an empty list, there is -- nothing to do. Value := Expression (Project => Project, Shared => Shared, From_Project_Node => From_Project_Node, From_Project_Node_Tree => From_Project_Node_Tree, Env => Env, Pkg => Pkg, First_Term => Tree.First_Term (String_Node, From_Project_Node_Tree), Kind => Single); String_Element_Table.Increment_Last (Shared.String_Elements); if Result.Values = Nil_String then -- This literal string list is the first term in a -- string list expression Result.Values := String_Element_Table.Last (Shared.String_Elements); else Shared.String_Elements.Table (Last).Next := String_Element_Table.Last (Shared.String_Elements); end if; Last := String_Element_Table.Last (Shared.String_Elements); Shared.String_Elements.Table (Last) := (Value => Value.Value, Display_Value => No_Name, Location => Value.Location, Next => Nil_String, Index => Value.Index); loop -- Add the other element of the literal string list -- one after the other. String_Node := Next_Expression_In_List (String_Node, From_Project_Node_Tree); exit when No (String_Node); Value := Expression (Project => Project, Shared => Shared, From_Project_Node => From_Project_Node, From_Project_Node_Tree => From_Project_Node_Tree, Env => Env, Pkg => Pkg, First_Term => Tree.First_Term (String_Node, From_Project_Node_Tree), Kind => Single); String_Element_Table.Increment_Last (Shared.String_Elements); Shared.String_Elements.Table (Last).Next := String_Element_Table.Last (Shared.String_Elements); Last := String_Element_Table.Last (Shared.String_Elements); Shared.String_Elements.Table (Last) := (Value => Value.Value, Display_Value => No_Name, Location => Value.Location, Next => Nil_String, Index => Value.Index); end loop; end if; end; when N_Variable_Reference | N_Attribute_Reference => declare The_Project : Project_Id := Project; The_Package : Package_Id := Pkg; The_Name : Name_Id := No_Name; The_Variable_Id : Variable_Id := No_Variable; The_Variable : Variable_Value; Term_Project : constant Project_Node_Id := Project_Node_Of (The_Current_Term, From_Project_Node_Tree); Term_Package : constant Project_Node_Id := Package_Node_Of (The_Current_Term, From_Project_Node_Tree); Index : Name_Id := No_Name; begin <> The_Project := Project; The_Package := Pkg; The_Name := No_Name; The_Variable_Id := No_Variable; Index := No_Name; if Present (Term_Project) and then Term_Project /= From_Project_Node then -- This variable or attribute comes from another project The_Name := Name_Of (Term_Project, From_Project_Node_Tree); The_Project := Imported_Or_Extended_Project_From (Project, With_Name => The_Name, No_Extending => True); end if; if Present (Term_Package) then -- This is an attribute of a package The_Name := Name_Of (Term_Package, From_Project_Node_Tree); The_Package := The_Project.Decl.Packages; while The_Package /= No_Package and then Shared.Packages.Table (The_Package).Name /= The_Name loop The_Package := Shared.Packages.Table (The_Package).Next; end loop; if The_Package = No_Package then Get_Name_String (The_Name); Error_Msg (Env.Flags, "unknown package `" & Name_Buffer (1 .. Name_Len) & "`", Location_Of (The_Current_Term, From_Project_Node_Tree), Project); goto Process_Next_Term; end if; elsif Kind_Of (The_Current_Term, From_Project_Node_Tree) = N_Attribute_Reference then The_Package := No_Package; end if; The_Name := Name_Of (The_Current_Term, From_Project_Node_Tree); if Current_Term_Kind = N_Attribute_Reference then Index := Associative_Array_Index_Of (The_Current_Term, From_Project_Node_Tree); end if; -- If it is not an associative array attribute if Index = No_Name then -- It is not an associative array attribute if The_Package /= No_Package then -- First, if there is a package, look into the package if Current_Term_Kind = N_Variable_Reference then The_Variable_Id := Shared.Packages.Table (The_Package).Decl.Variables; else The_Variable_Id := Shared.Packages.Table (The_Package).Decl.Attributes; end if; while The_Variable_Id /= No_Variable and then Shared.Variable_Elements.Table (The_Variable_Id).Name /= The_Name loop The_Variable_Id := Shared.Variable_Elements.Table (The_Variable_Id).Next; end loop; end if; if The_Variable_Id = No_Variable then -- If we have not found it, look into the project if Current_Term_Kind = N_Variable_Reference then The_Variable_Id := The_Project.Decl.Variables; else The_Variable_Id := The_Project.Decl.Attributes; end if; while The_Variable_Id /= No_Variable and then Shared.Variable_Elements.Table (The_Variable_Id).Name /= The_Name loop The_Variable_Id := Shared.Variable_Elements.Table (The_Variable_Id).Next; end loop; end if; if From_Project_Node_Tree.Incomplete_With then if The_Variable_Id = No_Variable then The_Variable := Nil_Variable_Value; else The_Variable := Shared.Variable_Elements.Table (The_Variable_Id).Value; end if; else pragma Assert (The_Variable_Id /= No_Variable, "variable or attribute not found"); The_Variable := Shared.Variable_Elements.Table (The_Variable_Id).Value; end if; else -- It is an associative array attribute declare The_Array : Array_Id := No_Array; The_Element : Array_Element_Id := No_Array_Element; Array_Index : Name_Id := No_Name; Case_Insens : constant Boolean := Case_Insensitive (The_Current_Term, From_Project_Node_Tree); function Same_Index (N1 : Name_Id; N2 : Name_Id) return Boolean; -- Return True iff N1 and N2 are the same string with -- the case-insensitivity Case_Insens. ---------------- -- Same_Index -- ---------------- function Same_Index (N1 : Name_Id; N2 : Name_Id) return Boolean is begin if Case_Insens and then N1 /= All_Other_Names and then N2 /= All_Other_Names then declare Name_1 : String := Get_Name_String (N1); Name_2 : String := Get_Name_String (N2); begin To_Lower (Name_1); To_Lower (Name_2); return Name_1 = Name_2; end; else return N1 = N2; end if; end Same_Index; begin if The_Package /= No_Package then The_Array := Shared.Packages.Table (The_Package).Decl.Arrays; else The_Array := The_Project.Decl.Arrays; end if; while The_Array /= No_Array and then Shared.Arrays.Table (The_Array).Name /= The_Name loop The_Array := Shared.Arrays.Table (The_Array).Next; end loop; if The_Array /= No_Array then The_Element := Shared.Arrays.Table (The_Array).Value; Array_Index := Get_Attribute_Index (From_Project_Node_Tree, The_Current_Term, Index); while The_Element /= No_Array_Element and then not Same_Index (Shared.Array_Elements.Table (The_Element).Index, Array_Index) loop The_Element := Shared.Array_Elements.Table (The_Element).Next; end loop; end if; if The_Element /= No_Array_Element then The_Variable := Shared.Array_Elements.Table (The_Element).Value; else if Expression_Kind_Of (The_Current_Term, From_Project_Node_Tree) = List then The_Variable := (Project => Project, Kind => List, Location => No_Location, Default => True, String_Type => Empty_Project_Node, Values => Nil_String, Concat => Is_Config_Concatenable (The_Current_Term, From_Project_Node_Tree), From_Implicit_Target => False); else The_Variable := (Project => Project, Kind => Single, Location => No_Location, Default => True, String_Type => Empty_Project_Node, Value => Empty_String, Index => 0, From_Implicit_Target => False); end if; end if; end; end if; -- Check the defaults if Current_Term_Kind = N_Attribute_Reference then declare The_Default : constant Attribute_Default_Value := Default_Of (The_Current_Term, From_Project_Node_Tree); CL : Language_Maps.Cursor; begin -- Check the special value for 'Target when specified if The_Default = Target_Value and then Opt.Target_Origin = Specified then The_Variable.Value := Get_Name_Id (Opt.Target_Value.all); elsif The_Default = Canonical_Target_Value and then Opt.Target_Value_Canonical /= null then The_Variable.Value := Get_Name_Id (Opt.Target_Value_Canonical.all); -- Check special value for Runtime (): --RTS= -- overrides declaration of Runtime (). elsif The_Default = Runtime_Value then Get_Name_String (Index); To_Lower (Name_Buffer (1 .. Name_Len)); CL := Runtime_Defaults.Find (Name_Find); if Language_Maps.Has_Element (CL) then The_Variable.Value := Language_Maps.Element (CL); end if; -- Check the defaults elsif The_Variable.Default then case The_Variable.Kind is when Undefined => null; when Single => case The_Default is when Read_Only_Value => null; when Empty_Value => The_Variable.Value := Empty_String; when Dot_Value => The_Variable.Value := Dot_String; when Object_Dir_Value => From_Project_Node_Tree.Project_Nodes.Table (The_Current_Term).Name := Snames.Name_Object_Dir; From_Project_Node_Tree.Project_Nodes.Table (The_Current_Term).Default := Dot_Value; goto Object_Dir_Restart; when Target_Value => if Opt.Target_Value = null then The_Variable.Value := Empty_String; else The_Variable.Value := Get_Name_Id (Opt.Target_Value.all); The_Variable.From_Implicit_Target := True; end if; when Canonical_Target_Value => if Opt.Target_Value_Canonical = null then The_Variable.Value := Empty_String; else The_Variable.Value := Get_Name_Id (Opt.Target_Value_Canonical.all); end if; when Runtime_Value => null; end case; when List => case The_Default is when Read_Only_Value => null; when Empty_Value => The_Variable.Values := Nil_String; when Dot_Value => The_Variable.Values := Shared.Dot_String_List; when Object_Dir_Value | Target_Value | Runtime_Value | Canonical_Target_Value => null; end case; end case; end if; end; end if; case Kind is when Undefined => -- This can happen when there are missing withs null; when Single => case The_Variable.Kind is when Undefined => null; when Single => Add (Result.Value, The_Variable.Value); Result.From_Implicit_Target := The_Variable.From_Implicit_Target; when List => -- Should never happen pragma Assert (False, "list cannot appear in single " & "string expression"); null; end case; when List => case The_Variable.Kind is when Undefined => null; when Single => String_Element_Table.Increment_Last (Shared.String_Elements); if Last = Nil_String then -- This can happen in an expression such as -- () & Var Result.Values := String_Element_Table.Last (Shared.String_Elements); else Shared.String_Elements.Table (Last).Next := String_Element_Table.Last (Shared.String_Elements); end if; Last := String_Element_Table.Last (Shared.String_Elements); Shared.String_Elements.Table (Last) := (Value => The_Variable.Value, Display_Value => No_Name, Location => Location_Of (The_Current_Term, From_Project_Node_Tree), Next => Nil_String, Index => 0); when List => declare The_List : String_List_Id := The_Variable.Values; begin while The_List /= Nil_String loop String_Element_Table.Increment_Last (Shared.String_Elements); if Last = Nil_String then Result.Values := String_Element_Table.Last (Shared.String_Elements); else Shared. String_Elements.Table (Last).Next := String_Element_Table.Last (Shared.String_Elements); end if; Last := String_Element_Table.Last (Shared.String_Elements); Shared.String_Elements.Table (Last) := (Value => Shared.String_Elements.Table (The_List).Value, Display_Value => No_Name, Location => Location_Of (The_Current_Term, From_Project_Node_Tree), Next => Nil_String, Index => 0); The_List := Shared.String_Elements.Table (The_List).Next; end loop; end; Result.Concat := The_Variable.Concat; end case; end case; end; when N_External_Value => Get_Name_String (String_Value_Of (External_Reference_Of (The_Current_Term, From_Project_Node_Tree), From_Project_Node_Tree)); declare Name : constant Name_Id := Name_Find; Default : Name_Id := No_Name; Value : Name_Id := No_Name; Ext_List : Boolean := False; Str_List : String_List_Access := null; Def_Var : Variable_Value; Default_Node : constant Project_Node_Id := External_Default_Of (The_Current_Term, From_Project_Node_Tree); begin -- If there is a default value for the external reference, -- get its value. if Present (Default_Node) then Def_Var := Expression (Project => Project, Shared => Shared, From_Project_Node => From_Project_Node, From_Project_Node_Tree => From_Project_Node_Tree, Env => Env, Pkg => Pkg, First_Term => Tree.First_Term (Default_Node, From_Project_Node_Tree), Kind => Single); if Def_Var /= Nil_Variable_Value then Default := Def_Var.Value; end if; end if; Ext_List := Expression_Kind_Of (The_Current_Term, From_Project_Node_Tree) = List; if Ext_List then Value := GPR.Ext.Value_Of (Env.External, Name, No_Name); GPR.Ext.Add_Name_To_Context (Env.External, Name, Value); if Value /= No_Name then declare Sep : constant String := Get_Name_String (Default); First : Positive := 1; Lst : Natural; Done : Boolean := False; Nmb : Natural; begin Get_Name_String (Value); if Name_Len = 0 or else Sep'Length = 0 or else Name_Buffer (1 .. Name_Len) = Sep then Done := True; end if; if not Done and then Name_Len < Sep'Length then Str_List := new String_List' (1 => new String' (Name_Buffer (1 .. Name_Len))); Done := True; end if; if not Done then if Name_Buffer (1 .. Sep'Length) = Sep then First := Sep'Length + 1; end if; if Name_Len - First + 1 >= Sep'Length and then Name_Buffer (Name_Len - Sep'Length + 1 .. Name_Len) = Sep then Name_Len := Name_Len - Sep'Length; end if; if Name_Len = 0 then Str_List := new String_List'(1 => new String'("")); Done := True; end if; end if; if not Done then -- Count the number of strings declare Saved : constant Positive := First; begin Nmb := 1; loop Lst := Index (Source => Name_Buffer (First .. Name_Len), Pattern => Sep); exit when Lst = 0; Nmb := Nmb + 1; First := Lst + Sep'Length; end loop; First := Saved; end; Str_List := new String_List (1 .. Nmb); -- Populate the string list Nmb := 1; loop Lst := Index (Source => Name_Buffer (First .. Name_Len), Pattern => Sep); if Lst = 0 then Str_List (Nmb) := new String' (Name_Buffer (First .. Name_Len)); exit; else Str_List (Nmb) := new String' (Name_Buffer (First .. Lst - 1)); Nmb := Nmb + 1; First := Lst + Sep'Length; end if; end loop; end if; end; end if; else -- Get the value Value := GPR.Ext.Value_Of (Env.External, Name, Default); GPR.Ext.Add_Name_To_Context (Env.External, Name, Value); -- It is an error if an external reference is not found -- and there is no default. if Value = No_Name then -- The name of the external reference needs to be -- displayed verbatim and between double quotes. Get_Name_String (Name); for J in reverse 1 .. Name_Len loop Name_Buffer (J * 2) := Name_Buffer (J); Name_Buffer (J * 2 - 1) := '''; end loop; Name_Len := Name_Len * 2; Error_Msg (Env.Flags, "undefined external reference `" & Name_Buffer (1 .. Name_Len) & "`", Location_Of (The_Current_Term, From_Project_Node_Tree), Project); Value := Empty_String; end if; end if; case Kind is when Undefined => null; when Single => if Ext_List then null; -- error else Add (Result.Value, Value); end if; when List => if not Ext_List or else Str_List /= null then String_Element_Table.Increment_Last (Shared.String_Elements); if Last = Nil_String then Result.Values := String_Element_Table.Last (Shared.String_Elements); else Shared.String_Elements.Table (Last).Next := String_Element_Table.Last (Shared.String_Elements); end if; Last := String_Element_Table.Last (Shared.String_Elements); if Ext_List then for Ind in Str_List'Range loop Value := Get_Name_Id (Str_List (Ind).all); Shared.String_Elements.Table (Last) := (Value => Value, Display_Value => No_Name, Location => Location_Of (The_Current_Term, From_Project_Node_Tree), Next => Nil_String, Index => 0); if Ind /= Str_List'Last then String_Element_Table.Increment_Last (Shared.String_Elements); Shared.String_Elements.Table (Last).Next := String_Element_Table.Last (Shared.String_Elements); Last := String_Element_Table.Last (Shared.String_Elements); end if; end loop; else Shared.String_Elements.Table (Last) := (Value => Value, Display_Value => No_Name, Location => Location_Of (The_Current_Term, From_Project_Node_Tree), Next => Nil_String, Index => 0); end if; end if; end case; end; when N_Split => Split (Source => String_Argument_Of (The_Current_Term, From_Project_Node_Tree), Separator => Separator_Of (The_Current_Term, From_Project_Node_Tree)); when others => -- Should never happen pragma Assert (False, "illegal node kind in an expression"); raise Program_Error; end case; end if; <> The_Term := Next_Term (The_Term, From_Project_Node_Tree); end loop; return Result; end Expression; --------------------------------------- -- Imported_Or_Extended_Project_From -- --------------------------------------- function Imported_Or_Extended_Project_From (Project : Project_Id; With_Name : Name_Id; No_Extending : Boolean := False) return Project_Id is List : Project_List; Result : Project_Id; Temp_Result : Project_Id; begin -- First check if it is the name of an extended project Result := Project.Extends; while Result /= No_Project loop if Result.Name = With_Name then return Result; else Result := Result.Extends; end if; end loop; -- Then check the name of each imported project Temp_Result := No_Project; List := Project.Imported_Projects; while List /= null loop Result := List.Project; -- If the project is directly imported, then returns its ID if Result.Name = With_Name then return Result; end if; -- If a project extending the project is imported, then keep this -- extending project as a possibility. It will be the returned ID -- if the project is not imported directly. declare Proj : Project_Id := Result.Extends; begin while Proj /= No_Project loop if Proj.Name = With_Name then if No_Extending then Temp_Result := Proj; else Temp_Result := Result; end if; exit; end if; Proj := Proj.Extends; end loop; end; List := List.Next; end loop; if Temp_Result = No_Project then -- Check is it grand parent case declare Grand : constant String := Get_Name_String (With_Name); Child : constant String := Get_Name_String (Project.Name); function Error_Message return String is ("Name " & Grand & " not found for project " & Child); function Recursive_Parent_Search (Proj : Project_Id) return Project_Id; ----------------------------- -- Recursive_Parent_Search -- ----------------------------- function Recursive_Parent_Search (Proj : Project_Id) return Project_Id is List : Project_List := Proj.Imported_Projects; Result : Project_Id; begin while List /= null loop Result := List.Project; if Result.Name = With_Name then return Result; elsif Util.Starts_With (Get_Name_String (Result.Name), Grand & '.') then Result := Recursive_Parent_Search (Result); if Result /= No_Project then return Result; end if; end if; List := List.Next; end loop; if Proj.Extends /= No_Project then return Recursive_Parent_Search (Proj.Extends); end if; return No_Project; end Recursive_Parent_Search; begin if not Util.Starts_With (Child, Grand & '.') then pragma Assert (False, Error_Message); end if; -- If search of grand parent then look at import or extended of -- parents recursively. Temp_Result := Recursive_Parent_Search (Project); pragma Assert (Temp_Result /= No_Project, Error_Message); end; end if; return Temp_Result; end Imported_Or_Extended_Project_From; ------------------ -- Package_From -- ------------------ function Package_From (Project : Project_Id; Shared : Shared_Project_Tree_Data_Access; With_Name : Name_Id) return Package_Id is Result : Package_Id := Project.Decl.Packages; begin -- Check the name of each existing package of Project while Result /= No_Package and then Shared.Packages.Table (Result).Name /= With_Name loop Result := Shared.Packages.Table (Result).Next; end loop; if Result = No_Package then Error_Msg ("no package " & Get_Name_String_Safe (With_Name) & " in project " & Get_Name_String_Safe (Project.Display_Name), Project.Location); raise Project_Error; end if; return Result; end Package_From; ------------- -- Process -- ------------- procedure Process (In_Tree : Project_Tree_Ref; Project : out Project_Id; Packages_To_Check : String_List_Access; Success : out Boolean; From_Project_Node : Project_Node_Id; From_Project_Node_Tree : Project_Node_Tree_Ref; Env : in out GPR.Tree.Environment; Reset_Tree : Boolean := True; On_New_Tree_Loaded : Tree_Loaded_Callback := null) is begin Process_Project_Tree_Phase_1 (In_Tree => In_Tree, Project => Project, Success => Success, From_Project_Node => From_Project_Node, From_Project_Node_Tree => From_Project_Node_Tree, Env => Env, Packages_To_Check => Packages_To_Check, Reset_Tree => Reset_Tree, On_New_Tree_Loaded => On_New_Tree_Loaded); if Project_Qualifier_Of (From_Project_Node, From_Project_Node_Tree) /= Configuration then Process_Project_Tree_Phase_2 (In_Tree => In_Tree, Project => Project, Success => Success, From_Project_Node => From_Project_Node, From_Project_Node_Tree => From_Project_Node_Tree, Env => Env); end if; end Process; ------------------------------- -- Process_Declarative_Items -- ------------------------------- procedure Process_Declarative_Items (Project : Project_Id; In_Tree : Project_Tree_Ref; From_Project_Node : Project_Node_Id; Node_Tree : Project_Node_Tree_Ref; Env : GPR.Tree.Environment; Pkg : Package_Id; Item : Project_Node_Id; Child_Env : in out GPR.Tree.Environment) is Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared; procedure Check_Or_Set_Typed_Variable (Value : in out Variable_Value; Declaration : Project_Node_Id); -- Check whether Value is valid for this typed variable declaration. If -- it is an error, the behavior depends on the flags: either an error is -- reported, or a warning, or nothing. In the last two cases, the value -- of the variable is set to a valid value, replacing Value. procedure Process_Package_Declaration (Current_Item : Project_Node_Id); procedure Process_Attribute_Declaration (Current : Project_Node_Id); procedure Process_Case_Construction (Current_Item : Project_Node_Id); procedure Process_Associative_Array (Current_Item : Project_Node_Id); procedure Process_Expression (Current : Project_Node_Id); procedure Process_Expression_For_Associative_Array (Current : Project_Node_Id; New_Value : Variable_Value); procedure Process_Expression_Variable_Decl (Current_Item : Project_Node_Id; New_Value : Variable_Value); -- Process the various declarative items --------------------------------- -- Check_Or_Set_Typed_Variable -- --------------------------------- procedure Check_Or_Set_Typed_Variable (Value : in out Variable_Value; Declaration : Project_Node_Id) is Loc : constant Source_Ptr := Location_Of (Declaration, Node_Tree); Reset_Value : Boolean := False; Current_String : Project_Node_Id; begin -- Report an error for an empty string if Value.Kind = Undefined or else Value.Value = Empty_String then Error_Msg_Name_1 := Name_Of (Declaration, Node_Tree); case Env.Flags.Allow_Invalid_External is when Error => Error_Msg (Env.Flags, "no value defined for %%", Loc, Project); when Warning => Reset_Value := True; Error_Msg (Env.Flags, "?no value defined for %%", Loc, Project); when Silent | Decide_Later => Reset_Value := True; end case; else -- Loop through all the valid strings for the -- string type and compare to the string value. declare Str_Type : constant Project_Node_Id := String_Type_Of (Declaration, Node_Tree); begin if No (Str_Type) then Current_String := Empty_Project_Node; else Current_String := First_Literal_String (Str_Type, Node_Tree); end if; while Present (Current_String) and then String_Value_Of (Current_String, Node_Tree) /= Value.Value loop Current_String := Next_Literal_String (Current_String, Node_Tree); end loop; -- Report error if string value is not one for the string type if No (Current_String) then Error_Msg_Name_1 := Value.Value; Error_Msg_Name_2 := Name_Of (Declaration, Node_Tree); case Env.Flags.Allow_Invalid_External is when Error => Error_Msg (Env.Flags, "value %% is illegal for typed string %%", Loc, Project); when Warning => Error_Msg (Env.Flags, "?value %% is illegal for typed string %%", Loc, Project); Reset_Value := True; when Silent | Decide_Later => Reset_Value := True; end case; else Value.String_Type := String_Type_Of (Declaration, Node_Tree); end if; end; end if; if Value.Kind /= Undefined and then Reset_Value and then not Env.Flags.Incomplete_Withs then -- The type we are looking for might be from a missing with -- project, in that case we cannot search for the first value. -- We supress corresponding error/warning messages in this case -- as well anyway. Current_String := First_Literal_String (String_Type_Of (Declaration, Node_Tree), Node_Tree); Value.Value := String_Value_Of (Current_String, Node_Tree); end if; end Check_Or_Set_Typed_Variable; --------------------------------- -- Process_Package_Declaration -- --------------------------------- procedure Process_Package_Declaration (Current_Item : Project_Node_Id) is begin -- Do not process a package declaration that should be ignored if Expression_Kind_Of (Current_Item, Node_Tree) /= Ignored then -- Create the new package Package_Table.Increment_Last (Shared.Packages); declare New_Pkg : constant Package_Id := Package_Table.Last (Shared.Packages); The_New_Package : Package_Element; Project_Of_Renamed_Package : constant Project_Node_Id := Project_Of_Renamed_Package_Of (Current_Item, Node_Tree); begin -- Set the name of the new package The_New_Package.Name := Name_Of (Current_Item, Node_Tree); -- Insert the new package in the appropriate list if Pkg /= No_Package then The_New_Package.Next := Shared.Packages.Table (Pkg).Decl.Packages; Shared.Packages.Table (Pkg).Decl.Packages := New_Pkg; else The_New_Package.Next := Project.Decl.Packages; Project.Decl.Packages := New_Pkg; end if; Shared.Packages.Table (New_Pkg) := The_New_Package; if Present (Project_Of_Renamed_Package) then -- Renamed or extending package declare Project_Name : constant Name_Id := Name_Of (Project_Of_Renamed_Package, Node_Tree); Renamed_Project : constant Project_Id := Ultimate_Extending_Project_Of (Imported_Or_Extended_Project_From (Project, Project_Name), Before => Project); Renamed_Package : constant Package_Id := Package_From (Renamed_Project, Shared, Name_Of (Current_Item, Node_Tree)); begin -- For a renamed package, copy the declarations of the -- renamed package, but set all the locations to the -- location of the package name in the renaming -- declaration. Copy_Package_Declarations (From => Shared.Packages.Table (Renamed_Package).Decl, To => Shared.Packages.Table (New_Pkg).Decl, New_Loc => Location_Of (Current_Item, Node_Tree), Restricted => False, Shared => Shared); end; else -- Set the default values of the attributes Add_Attributes (Project, Project.Name, Name_Id (Project.Directory.Display_Name), Shared, Shared.Packages.Table (New_Pkg).Decl, First_Attribute_Of (Package_Id_Of (Current_Item, Node_Tree)), Project_Level => False); end if; -- Process declarative items (nothing to do when the package is -- renaming, as the first declarative item is null). Process_Declarative_Items (Project => Project, In_Tree => In_Tree, From_Project_Node => From_Project_Node, Node_Tree => Node_Tree, Env => Env, Pkg => New_Pkg, Item => First_Declarative_Item_Of (Current_Item, Node_Tree), Child_Env => Child_Env); end; end if; end Process_Package_Declaration; ------------------------------- -- Process_Associative_Array -- ------------------------------- procedure Process_Associative_Array (Current_Item : Project_Node_Id) is Current_Item_Name : constant Name_Id := Name_Of (Current_Item, Node_Tree); -- The name of the attribute Current_Location : constant Source_Ptr := Location_Of (Current_Item, Node_Tree); New_Array : Array_Id; -- The new associative array created Orig_Array : Array_Id; -- The associative array value Orig_Project_Name : Name_Id := No_Name; -- The name of the project where the associative array -- value is. Orig_Project : Project_Id := No_Project; -- The id of the project where the associative array -- value is. Orig_Package_Name : Name_Id := No_Name; -- The name of the package, if any, where the associative array value -- is located. Orig_Package : Package_Id := No_Package; -- The id of the package, if any, where the associative array value -- is located. New_Element : Array_Element_Id := No_Array_Element; -- Id of a new array element created Prev_Element : Array_Element_Id := No_Array_Element; -- Last new element id created Orig_Element : Array_Element_Id := No_Array_Element; -- Current array element in original associative array Next_Element : Array_Element_Id := No_Array_Element; -- Id of the array element that follows the new element. This is not -- always nil, because values for the associative array attribute may -- already have been declared, and the array elements declared are -- reused. Prj : Project_List; begin -- First find if the associative array attribute already has elements -- declared. if Pkg /= No_Package then New_Array := Shared.Packages.Table (Pkg).Decl.Arrays; else New_Array := Project.Decl.Arrays; end if; while New_Array /= No_Array and then Shared.Arrays.Table (New_Array).Name /= Current_Item_Name loop New_Array := Shared.Arrays.Table (New_Array).Next; end loop; -- If the attribute has never been declared add new entry in the -- arrays of the project/package and link it. if New_Array = No_Array then Array_Table.Increment_Last (Shared.Arrays); New_Array := Array_Table.Last (Shared.Arrays); if Pkg /= No_Package then Shared.Arrays.Table (New_Array) := (Name => Current_Item_Name, Location => Current_Location, Value => No_Array_Element, Next => Shared.Packages.Table (Pkg).Decl.Arrays); Shared.Packages.Table (Pkg).Decl.Arrays := New_Array; else Shared.Arrays.Table (New_Array) := (Name => Current_Item_Name, Location => Current_Location, Value => No_Array_Element, Next => Project.Decl.Arrays); Project.Decl.Arrays := New_Array; end if; end if; -- Find the project where the value is declared Orig_Project_Name := Name_Of (Associative_Project_Of (Current_Item, Node_Tree), Node_Tree); Prj := In_Tree.Projects; while Prj /= null loop if Prj.Project.Name = Orig_Project_Name then Orig_Project := Prj.Project; exit; end if; Prj := Prj.Next; end loop; pragma Assert (Orig_Project /= No_Project, "original project not found"); if No (Associative_Package_Of (Current_Item, Node_Tree)) then Orig_Array := Orig_Project.Decl.Arrays; else -- If in a package, find the package where the value is declared Orig_Package_Name := Name_Of (Associative_Package_Of (Current_Item, Node_Tree), Node_Tree); Orig_Package := Orig_Project.Decl.Packages; pragma Assert (Orig_Package /= No_Package, "original package not found"); while Shared.Packages.Table (Orig_Package).Name /= Orig_Package_Name loop Orig_Package := Shared.Packages.Table (Orig_Package).Next; pragma Assert (Orig_Package /= No_Package, "original package not found"); end loop; Orig_Array := Shared.Packages.Table (Orig_Package).Decl.Arrays; end if; -- Now look for the array while Orig_Array /= No_Array and then Shared.Arrays.Table (Orig_Array).Name /= Current_Item_Name loop Orig_Array := Shared.Arrays.Table (Orig_Array).Next; end loop; if Orig_Array = No_Array then Error_Msg (Env.Flags, "associative array value not found", Location_Of (Current_Item, Node_Tree), Project); else Orig_Element := Shared.Arrays.Table (Orig_Array).Value; -- Copy each array element while Orig_Element /= No_Array_Element loop -- Case of first element if Prev_Element = No_Array_Element then -- And there is no array element declared yet, create a new -- first array element. if Shared.Arrays.Table (New_Array).Value = No_Array_Element then Array_Element_Table.Increment_Last (Shared.Array_Elements); New_Element := Array_Element_Table.Last (Shared.Array_Elements); Shared.Arrays.Table (New_Array).Value := New_Element; Next_Element := No_Array_Element; -- Otherwise, the new element is the first else New_Element := Shared.Arrays.Table (New_Array).Value; Next_Element := Shared.Array_Elements.Table (New_Element).Next; end if; -- Otherwise, reuse an existing element, or create -- one if necessary. else Next_Element := Shared.Array_Elements.Table (Prev_Element).Next; if Next_Element = No_Array_Element then Array_Element_Table.Increment_Last (Shared.Array_Elements); New_Element := Array_Element_Table.Last (Shared.Array_Elements); Shared.Array_Elements.Table (Prev_Element).Next := New_Element; else New_Element := Next_Element; Next_Element := Shared.Array_Elements.Table (New_Element).Next; end if; end if; -- Copy the value of the element Shared.Array_Elements.Table (New_Element) := Shared.Array_Elements.Table (Orig_Element); Shared.Array_Elements.Table (New_Element).Value.Project := Project; -- Adjust the Next link Shared.Array_Elements.Table (New_Element).Next := Next_Element; -- Adjust the previous id for the next element Prev_Element := New_Element; -- Go to the next element in the original array Orig_Element := Shared.Array_Elements.Table (Orig_Element).Next; end loop; -- Make sure that the array ends here, in case there previously a -- greater number of elements. Shared.Array_Elements.Table (New_Element).Next := No_Array_Element; end if; end Process_Associative_Array; ---------------------------------------------- -- Process_Expression_For_Associative_Array -- ---------------------------------------------- procedure Process_Expression_For_Associative_Array (Current : Project_Node_Id; New_Value : Variable_Value) is Name : constant Name_Id := Name_Of (Current, Node_Tree); Current_Location : constant Source_Ptr := Location_Of (Current, Node_Tree); Index_Name : Name_Id := Associative_Array_Index_Of (Current, Node_Tree); Source_Index : constant Int := Source_Index_Of (Current, Node_Tree); The_Array : Array_Id; Elem : Array_Element_Id := No_Array_Element; begin if Index_Name /= All_Other_Names then Index_Name := Get_Attribute_Index (Node_Tree, Current, Index_Name); end if; -- Look for the array in the appropriate list if Pkg /= No_Package then The_Array := Shared.Packages.Table (Pkg).Decl.Arrays; else The_Array := Project.Decl.Arrays; end if; while The_Array /= No_Array and then Shared.Arrays.Table (The_Array).Name /= Name loop The_Array := Shared.Arrays.Table (The_Array).Next; end loop; -- If the array cannot be found, create a new entry in the list. -- As The_Array_Element is initialized to No_Array_Element, a new -- element will be created automatically later if The_Array = No_Array then Array_Table.Increment_Last (Shared.Arrays); The_Array := Array_Table.Last (Shared.Arrays); if Pkg /= No_Package then Shared.Arrays.Table (The_Array) := (Name => Name, Location => Current_Location, Value => No_Array_Element, Next => Shared.Packages.Table (Pkg).Decl.Arrays); Shared.Packages.Table (Pkg).Decl.Arrays := The_Array; else Shared.Arrays.Table (The_Array) := (Name => Name, Location => Current_Location, Value => No_Array_Element, Next => Project.Decl.Arrays); Project.Decl.Arrays := The_Array; end if; else Elem := Shared.Arrays.Table (The_Array).Value; end if; -- Look in the list, if any, to find an element with the same index -- and same source index. while Elem /= No_Array_Element and then (Shared.Array_Elements.Table (Elem).Index /= Index_Name or else Shared.Array_Elements.Table (Elem).Src_Index /= Source_Index) loop Elem := Shared.Array_Elements.Table (Elem).Next; end loop; -- If no such element were found, create a new one -- and insert it in the element list, with the -- proper value. if Elem = No_Array_Element then Array_Element_Table.Increment_Last (Shared.Array_Elements); Elem := Array_Element_Table.Last (Shared.Array_Elements); Shared.Array_Elements.Table (Elem) := (Index => Index_Name, Restricted => False, Src_Index => Source_Index, Index_Case_Sensitive => not Case_Insensitive (Current, Node_Tree), Value => New_Value, Next => Shared.Arrays.Table (The_Array).Value); Shared.Arrays.Table (The_Array).Value := Elem; else -- An element with the same index already exists, just replace its -- value with the new one. Shared.Array_Elements.Table (Elem).Value := New_Value; end if; if Name = Snames.Name_External then if In_Tree.Is_Root_Tree then Add (Child_Env.External, External_Name => Get_Name_String (Index_Name), Value => Get_Name_String (New_Value.Value), Source => From_External_Attribute); Add (Env.External, External_Name => Get_Name_String (Index_Name), Value => Get_Name_String (New_Value.Value), Source => From_External_Attribute, Silent => True); else if Current_Verbosity = High then Debug_Output ("'for External' has no effect except in root aggregate (" & Get_Name_String_Safe (Index_Name) & ")", New_Value.Value); end if; end if; end if; end Process_Expression_For_Associative_Array; -------------------------------------- -- Process_Expression_Variable_Decl -- -------------------------------------- procedure Process_Expression_Variable_Decl (Current_Item : Project_Node_Id; New_Value : Variable_Value) is Name : constant Name_Id := Name_Of (Current_Item, Node_Tree); Is_Attribute : constant Boolean := Kind_Of (Current_Item, Node_Tree) = N_Attribute_Declaration; Var : Variable_Id := No_Variable; begin -- First, find the list where to find the variable or attribute if Is_Attribute then if Pkg /= No_Package then Var := Shared.Packages.Table (Pkg).Decl.Attributes; else Var := Project.Decl.Attributes; end if; else if Pkg /= No_Package then Var := Shared.Packages.Table (Pkg).Decl.Variables; else Var := Project.Decl.Variables; end if; end if; -- Loop through the list, to find if it has already been declared while Var /= No_Variable and then Shared.Variable_Elements.Table (Var).Name /= Name loop Var := Shared.Variable_Elements.Table (Var).Next; end loop; -- If it has not been declared, create a new entry in the list if Var = No_Variable then -- All single string attribute should already have been declared -- with a default empty string value. pragma Assert (not Is_Attribute, "illegal attribute declaration for " & Get_Name_String_Safe (Name)); Variable_Element_Table.Increment_Last (Shared.Variable_Elements); Var := Variable_Element_Table.Last (Shared.Variable_Elements); -- Put the new variable in the appropriate list if Pkg /= No_Package then Shared.Variable_Elements.Table (Var) := (Next => Shared.Packages.Table (Pkg).Decl.Variables, Name => Name, Value => New_Value); Shared.Packages.Table (Pkg).Decl.Variables := Var; else Shared.Variable_Elements.Table (Var) := (Next => Project.Decl.Variables, Name => Name, Value => New_Value); Project.Decl.Variables := Var; end if; -- If the variable/attribute has already been declared, just -- change the value. else Shared.Variable_Elements.Table (Var).Value := New_Value; end if; if Is_Attribute and then Name = Snames.Name_Project_Path then if In_Tree.Is_Root_Tree then declare package Name_Ids is new Ada.Containers.Vectors (Positive, Name_Id); Val : String_List_Id := New_Value.Values; List : Name_Ids.Vector; begin -- Get all values while Val /= Nil_String loop List.Prepend (Shared.String_Elements.Table (Val).Value); Val := Shared.String_Elements.Table (Val).Next; end loop; -- Prepend them in the order found in the attribute for K in Positive range 1 .. Positive (List.Length) loop GPR.Env.Add_Directories (Child_Env.Project_Path, Normalize_Pathname (Name => Get_Name_String (List.Element (K)), Directory => Get_Name_String (Project.Directory.Display_Name)), Prepend => True); end loop; end; else if Current_Verbosity = High then Debug_Output ("'for Project_Path' has no effect except in" & " root aggregate"); end if; end if; end if; end Process_Expression_Variable_Decl; ------------------------ -- Process_Expression -- ------------------------ procedure Process_Expression (Current : Project_Node_Id) is New_Value : Variable_Value := Expression (Project => Project, Shared => Shared, From_Project_Node => From_Project_Node, From_Project_Node_Tree => Node_Tree, Env => Env, Pkg => Pkg, First_Term => Tree.First_Term (Expression_Of (Current, Node_Tree), Node_Tree), Kind => Expression_Kind_Of (Current, Node_Tree)); begin -- Process a typed variable declaration if Kind_Of (Current, Node_Tree) = N_Typed_Variable_Declaration then Check_Or_Set_Typed_Variable (New_Value, Current); end if; if Kind_Of (Current, Node_Tree) /= N_Attribute_Declaration or else Associative_Array_Index_Of (Current, Node_Tree) = No_Name then Process_Expression_Variable_Decl (Current, New_Value); else Process_Expression_For_Associative_Array (Current, New_Value); end if; end Process_Expression; ----------------------------------- -- Process_Attribute_Declaration -- ----------------------------------- procedure Process_Attribute_Declaration (Current : Project_Node_Id) is begin if No (Expression_Of (Current, Node_Tree)) then Process_Associative_Array (Current); else Process_Expression (Current); end if; end Process_Attribute_Declaration; ------------------------------- -- Process_Case_Construction -- ------------------------------- procedure Process_Case_Construction (Current_Item : Project_Node_Id) is The_Project : Project_Id := Project; -- The id of the project of the case variable The_Package : Package_Id := Pkg; -- The id of the package, if any, of the case variable The_Variable : Variable_Value := Nil_Variable_Value; -- The case variable Case_Value : Name_Id := No_Name; -- The case variable value Case_Item : Project_Node_Id := Empty_Project_Node; Choice_String : Project_Node_Id := Empty_Project_Node; Decl_Item : Project_Node_Id := Empty_Project_Node; begin declare Variable_Node : constant Project_Node_Id := Case_Variable_Reference_Of (Current_Item, Node_Tree); Var_Id : Variable_Id := No_Variable; Name : Name_Id := No_Name; begin -- If a project was specified for the case variable, get its id if Present (Project_Node_Of (Variable_Node, Node_Tree)) then Name := Name_Of (Project_Node_Of (Variable_Node, Node_Tree), Node_Tree); The_Project := Imported_Or_Extended_Project_From (Project, Name, No_Extending => True); The_Package := No_Package; end if; -- If a package was specified for the case variable, get its id if Present (Package_Node_Of (Variable_Node, Node_Tree)) then Name := Name_Of (Package_Node_Of (Variable_Node, Node_Tree), Node_Tree); The_Package := Package_From (The_Project, Shared, Name); end if; Name := Name_Of (Variable_Node, Node_Tree); -- First, look for the case variable into the package, if any if The_Package /= No_Package then Name := Name_Of (Variable_Node, Node_Tree); Var_Id := Shared.Packages.Table (The_Package).Decl.Variables; while Var_Id /= No_Variable and then Shared.Variable_Elements.Table (Var_Id).Name /= Name loop Var_Id := Shared.Variable_Elements.Table (Var_Id).Next; end loop; end if; -- If not found in the package, or if there is no package, look at -- the project level. if Var_Id = No_Variable and then No (Package_Node_Of (Variable_Node, Node_Tree)) then Var_Id := The_Project.Decl.Variables; while Var_Id /= No_Variable and then Shared.Variable_Elements.Table (Var_Id).Name /= Name loop Var_Id := Shared.Variable_Elements.Table (Var_Id).Next; end loop; end if; if Var_Id = No_Variable then if Node_Tree.Incomplete_With then return; -- Should never happen, because this has already been checked -- during parsing. else Write_Line ("variable """ & Get_Name_String_Safe (Name) & """ not found"); raise Program_Error; end if; end if; -- Get the case variable The_Variable := Shared.Variable_Elements.Table (Var_Id).Value; if The_Variable.Kind /= Single then if Node_Tree.Incomplete_With and then The_Variable.Kind = Undefined then return; end if; -- Should never happen, because this has already been checked -- during parsing. Write_Line ("variable """ & Get_Name_String_Safe (Name) & """ is not a single string variable"); raise Program_Error; end if; -- Get the case variable value Case_Value := The_Variable.Value; end; -- Now look into all the case items of the case construction Case_Item := First_Case_Item_Of (Current_Item, Node_Tree); Case_Item_Loop : while Present (Case_Item) loop Choice_String := First_Choice_Of (Case_Item, Node_Tree); -- When Choice_String is nil, it means that it is the -- "when others =>" alternative. if No (Choice_String) then Decl_Item := First_Declarative_Item_Of (Case_Item, Node_Tree); exit Case_Item_Loop; end if; -- Look into all the alternative of this case item Choice_Loop : while Present (Choice_String) loop if Case_Value = String_Value_Of (Choice_String, Node_Tree) then Decl_Item := First_Declarative_Item_Of (Case_Item, Node_Tree); exit Case_Item_Loop; end if; Choice_String := Next_Literal_String (Choice_String, Node_Tree); end loop Choice_Loop; Case_Item := Next_Case_Item (Case_Item, Node_Tree); end loop Case_Item_Loop; -- If there is an alternative, then we process it if Present (Decl_Item) then Process_Declarative_Items (Project => Project, In_Tree => In_Tree, From_Project_Node => From_Project_Node, Node_Tree => Node_Tree, Env => Env, Pkg => Pkg, Item => Decl_Item, Child_Env => Child_Env); end if; end Process_Case_Construction; -- Local variables Current, Decl : Project_Node_Id; Kind : Project_Node_Kind; -- Start of processing for Process_Declarative_Items begin Decl := Item; while Present (Decl) loop Current := Current_Item_Node (Decl, Node_Tree); Decl := Next_Declarative_Item (Decl, Node_Tree); Kind := Kind_Of (Current, Node_Tree); case Kind is when N_Package_Declaration => Process_Package_Declaration (Current); -- Nothing to process for string type declaration when N_String_Type_Declaration => null; when N_Attribute_Declaration | N_Typed_Variable_Declaration | N_Variable_Declaration => Process_Attribute_Declaration (Current); when N_Case_Construction => Process_Case_Construction (Current); when others => Write_Line ("Illegal declarative item: " & Kind'Img); raise Program_Error; end case; end loop; end Process_Declarative_Items; ---------------------------------- -- Process_Project_Tree_Phase_1 -- ---------------------------------- procedure Process_Project_Tree_Phase_1 (In_Tree : Project_Tree_Ref; Project : out Project_Id; Packages_To_Check : String_List_Access; Success : out Boolean; From_Project_Node : Project_Node_Id; From_Project_Node_Tree : Project_Node_Tree_Ref; Env : in out GPR.Tree.Environment; Reset_Tree : Boolean := True; On_New_Tree_Loaded : Tree_Loaded_Callback := null) is begin if Reset_Tree then -- Make sure there are no projects in the data structure Free_List (In_Tree.Projects, Free_Project => True); end if; Processed_Projects.Reset; -- And process the main project and all of the projects it depends on, -- recursively. Debug_Increase_Indent ("Process tree, phase 1"); Recursive_Process (Project => Project, In_Tree => In_Tree, Packages_To_Check => Packages_To_Check, From_Project_Node => From_Project_Node, From_Project_Node_Tree => From_Project_Node_Tree, Env => Env, Extended_By => No_Project, From_Encapsulated_Lib => False, On_New_Tree_Loaded => On_New_Tree_Loaded); Success := Total_Errors_Detected = 0 and then (Warning_Mode /= Treat_As_Error or else Warnings_Detected = 0); if Current_Verbosity = High then Debug_Decrease_Indent ("Done Process tree, phase 1, Success=" & Success'Img); end if; end Process_Project_Tree_Phase_1; ---------------------------------- -- Process_Project_Tree_Phase_2 -- ---------------------------------- procedure Process_Project_Tree_Phase_2 (In_Tree : Project_Tree_Ref; Project : Project_Id; Success : out Boolean; From_Project_Node : Project_Node_Id; From_Project_Node_Tree : Project_Node_Tree_Ref; Env : Environment) is Obj_Dir : Path_Name_Type; Extending : Project_Id; Extending2 : Project_Id; Prj : Project_List; -- Start of processing for Process_Project_Tree_Phase_2 begin Success := True; Debug_Increase_Indent ("Process tree, phase 2", Project.Name); if Project /= No_Project then Check (In_Tree, Project, From_Project_Node_Tree, Env.Flags); end if; -- If main project is an extending all project, set object directory of -- all virtual extending projects to object directory of main project. if Project /= No_Project and then Is_Extending_All (From_Project_Node, From_Project_Node_Tree) then declare Object_Dir : constant Path_Information := Project.Object_Directory; begin Prj := In_Tree.Projects; while Prj /= null loop if Prj.Project.Virtual then Prj.Project.Object_Directory := Object_Dir; end if; Prj := Prj.Next; end loop; end; end if; -- Check that no extending project shares its object directory with -- the project(s) it extends. if Project /= No_Project then Prj := In_Tree.Projects; while Prj /= null loop Extending := Prj.Project.Extended_By; if Extending /= No_Project then Obj_Dir := Prj.Project.Object_Directory.Name; -- Check that a project being extended does not share its -- object directory with any project that extends it, directly -- or indirectly, including a virtual extending project. -- Start with the project directly extending it Extending2 := Extending; while Extending2 /= No_Project loop if Has_Ada_Sources (Extending2) and then Extending2.Object_Directory.Name = Obj_Dir then if Extending2.Virtual then Error_Msg_Name_1 := Prj.Project.Display_Name; Error_Msg (Env.Flags, "project %% cannot be extended by a virtual" & " project with the same object directory", Prj.Project.Location, Project); else Error_Msg_Name_1 := Extending2.Display_Name; Error_Msg_Name_2 := Prj.Project.Display_Name; Error_Msg (Env.Flags, "project %% cannot extend project %%", Extending2.Location, Project); Error_Msg (Env.Flags, "\they share the same object directory", Extending2.Location, Project); end if; end if; -- Continue with the next extending project, if any Extending2 := Extending2.Extended_By; end loop; end if; Prj := Prj.Next; end loop; end if; Debug_Decrease_Indent ("Done Process tree, phase 2"); Success := Total_Errors_Detected = 0 and then (Warning_Mode /= Treat_As_Error or else Warnings_Detected = 0); end Process_Project_Tree_Phase_2; ----------------------- -- Recursive_Process -- ----------------------- procedure Recursive_Process (In_Tree : Project_Tree_Ref; Project : out Project_Id; Packages_To_Check : String_List_Access; From_Project_Node : Project_Node_Id; From_Project_Node_Tree : Project_Node_Tree_Ref; Env : in out GPR.Tree.Environment; Extended_By : Project_Id; From_Encapsulated_Lib : Boolean; On_New_Tree_Loaded : Tree_Loaded_Callback := null) is Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared; Child_Env : GPR.Tree.Environment; -- Only used for the root aggregate project (if any). This is left -- uninitialized otherwise. procedure Process_Imported_Projects (Imported : in out Project_List; Limited_With : Boolean); -- Process imported projects. If Limited_With is True, then only -- projects processed through a "limited with" are processed, otherwise -- only projects imported through a standard "with" are processed. -- Imported is the id of the last imported project. procedure Process_Aggregated_Projects; -- Process all the projects aggregated in List. This does nothing if the -- project is not an aggregate project. procedure Process_Extended_Project; -- Process the extended project: inherit all packages from the extended -- project that are not explicitly defined or renamed. Also inherit the -- languages, if attribute Languages is not explicitly defined. ------------------------------- -- Process_Imported_Projects -- ------------------------------- procedure Process_Imported_Projects (Imported : in out Project_List; Limited_With : Boolean) is With_Clause : Project_Node_Id; New_Project : Project_Id; Proj_Node : Project_Node_Id; begin With_Clause := First_With_Clause_Of (From_Project_Node, From_Project_Node_Tree); while Present (With_Clause) loop Proj_Node := Non_Limited_Project_Node_Of (With_Clause, From_Project_Node_Tree); New_Project := No_Project; if (Limited_With and then No (Proj_Node)) or else (not Limited_With and then Present (Proj_Node)) then Recursive_Process (In_Tree => In_Tree, Project => New_Project, Packages_To_Check => Packages_To_Check, From_Project_Node => Project_Node_Of (With_Clause, From_Project_Node_Tree), From_Project_Node_Tree => From_Project_Node_Tree, Env => Env, Extended_By => No_Project, From_Encapsulated_Lib => From_Encapsulated_Lib, On_New_Tree_Loaded => On_New_Tree_Loaded); while New_Project.Extended_By /= null and then New_Project.Extended_By.Virtual loop -- Use extending instead of extended wherever possible. -- Non-virtual projects processed at -- GPR.Part.Parse_Single_Project. -- We have to do the same for virtual projects here. New_Project := New_Project.Extended_By; end loop; if Imported = null then Project.Imported_Projects := new Project_List_Element' (Project => New_Project, From_Encapsulated_Lib => False, Next => null); Imported := Project.Imported_Projects; else Imported.Next := new Project_List_Element' (Project => New_Project, From_Encapsulated_Lib => False, Next => null); Imported := Imported.Next; end if; end if; With_Clause := Next_With_Clause_Of (With_Clause, From_Project_Node_Tree); end loop; end Process_Imported_Projects; --------------------------------- -- Process_Aggregated_Projects -- --------------------------------- procedure Process_Aggregated_Projects is List : Aggregated_Project_List; Loaded_Project : GPR.Project_Node_Id; Success : Boolean := True; Tree : Project_Tree_Ref; Node_Tree : Project_Node_Tree_Ref; begin if Project.Qualifier not in Aggregate_Project then return; end if; Debug_Increase_Indent ("Process_Aggregated_Projects", Project.Name); GPR.Nmsc.Process_Aggregated_Projects (Tree => In_Tree, Project => Project, Node_Tree => From_Project_Node_Tree, Flags => Env.Flags); List := Project.Aggregated_Projects; while Success and then List /= null loop Node_Tree := new Project_Node_Tree_Data; Initialize (Node_Tree); GPR.Part.Parse (In_Tree => Node_Tree, Project => Loaded_Project, Packages_To_Check => Packages_To_Check, Project_File_Name => Get_Name_String (List.Path), Errout_Handling => GPR.Part.Never_Finalize, Current_Directory => Get_Name_String (Project.Directory.Name), Is_Config_File => False, Env => Child_Env); Success := not GPR.Tree.No (Loaded_Project); if Success then if Node_Tree.Incomplete_With then From_Project_Node_Tree.Incomplete_With := True; end if; List.Tree := new Project_Tree_Data (Is_Root_Tree => False); GPR.Initialize (List.Tree); List.Tree.Shared := In_Tree.Shared; List.Node_Tree := Node_Tree; -- In aggregate library, aggregated projects are parsed using -- the aggregate library tree. if Project.Qualifier = Aggregate_Library then Tree := In_Tree; else Tree := List.Tree; end if; -- We can only do the phase 1 of the processing, since we do -- not have access to the configuration file yet (this is -- called when doing phase 1 of the processing for the root -- aggregate project). if In_Tree.Is_Root_Tree then Process_Project_Tree_Phase_1 (In_Tree => Tree, Project => List.Project, Packages_To_Check => Packages_To_Check, Success => Success, From_Project_Node => Loaded_Project, From_Project_Node_Tree => Node_Tree, Env => Child_Env, Reset_Tree => False, On_New_Tree_Loaded => On_New_Tree_Loaded); else -- use the same environment as the rest of the aggregated -- projects, ie the one that was setup by the root aggregate Process_Project_Tree_Phase_1 (In_Tree => Tree, Project => List.Project, Packages_To_Check => Packages_To_Check, Success => Success, From_Project_Node => Loaded_Project, From_Project_Node_Tree => Node_Tree, Env => Env, Reset_Tree => False, On_New_Tree_Loaded => On_New_Tree_Loaded); end if; if On_New_Tree_Loaded /= null then On_New_Tree_Loaded (Node_Tree, Tree, Loaded_Project, List.Project); end if; else Debug_Output ("Failed to parse", Name_Id (List.Path)); end if; List := List.Next; end loop; Debug_Decrease_Indent ("Done Process_Aggregated_Projects"); end Process_Aggregated_Projects; ------------------------------ -- Process_Extended_Project -- ------------------------------ procedure Process_Extended_Project is Extended_Pkg : Package_Id; Current_Pkg : Package_Id; Element : Package_Element; First : constant Package_Id := Project.Decl.Packages; Attribute1 : Variable_Id; Attribute2 : Variable_Id; Attr_Value1 : Variable; Attr_Value2 : Variable; begin Extended_Pkg := Project.Extends.Decl.Packages; while Extended_Pkg /= No_Package loop Element := Shared.Packages.Table (Extended_Pkg); Current_Pkg := First; while Current_Pkg /= No_Package and then Shared.Packages.Table (Current_Pkg).Name /= Element.Name loop Current_Pkg := Shared.Packages.Table (Current_Pkg).Next; end loop; if Current_Pkg = No_Package then Package_Table.Increment_Last (Shared.Packages); Current_Pkg := Package_Table.Last (Shared.Packages); Shared.Packages.Table (Current_Pkg) := (Name => Element.Name, Decl => No_Declarations, Parent => No_Package, Next => Project.Decl.Packages); Project.Decl.Packages := Current_Pkg; Copy_Package_Declarations (From => Element.Decl, To => Shared.Packages.Table (Current_Pkg).Decl, New_Loc => No_Location, Restricted => True, Shared => Shared); end if; Extended_Pkg := Element.Next; end loop; -- Check if attribute Languages is declared in the extending project Attribute1 := Project.Decl.Attributes; while Attribute1 /= No_Variable loop Attr_Value1 := Shared.Variable_Elements. Table (Attribute1); exit when Attr_Value1.Name = Snames.Name_Languages; Attribute1 := Attr_Value1.Next; end loop; if Attribute1 = No_Variable or else Attr_Value1.Value.Default then -- Attribute Languages is not declared in the extending project. -- Check if it is declared in the project being extended. Attribute2 := Project.Extends.Decl.Attributes; while Attribute2 /= No_Variable loop Attr_Value2 := Shared.Variable_Elements.Table (Attribute2); exit when Attr_Value2.Name = Snames.Name_Languages; Attribute2 := Attr_Value2.Next; end loop; if Attribute2 /= No_Variable and then not Attr_Value2.Value.Default then -- As attribute Languages is declared in the project being -- extended, copy its value for the extending project. if Attribute1 = No_Variable then Variable_Element_Table.Increment_Last (Shared.Variable_Elements); Attribute1 := Variable_Element_Table.Last (Shared.Variable_Elements); Attr_Value1.Next := Project.Decl.Attributes; Project.Decl.Attributes := Attribute1; end if; Attr_Value1.Name := Snames.Name_Languages; Attr_Value1.Value := Attr_Value2.Value; Shared.Variable_Elements.Table (Attribute1) := Attr_Value1; end if; end if; end Process_Extended_Project; -- Start of processing for Recursive_Process begin if No (From_Project_Node) then Project := No_Project; else declare Imported, Mark : Project_List; Declaration_Node : Project_Node_Id := Empty_Project_Node; Name : constant Name_Id := Name_Of (From_Project_Node, From_Project_Node_Tree); Display_Name : constant Name_Id := Display_Name_Of (From_Project_Node, From_Project_Node_Tree); begin Project := Processed_Projects.Get (Name); if Project /= No_Project then -- Make sure that, when a project is extended, the project id -- of the project extending it is recorded in its data, even -- when it has already been processed as an imported project. -- This is for virtually extended projects. if Extended_By /= No_Project then Project.Extended_By := Extended_By; end if; return; end if; -- Check if the project is already in the tree Project := No_Project; declare List : Project_List := In_Tree.Projects; Path : constant Path_Name_Type := Path_Name_Of (From_Project_Node, From_Project_Node_Tree); Path_Name : String := Get_Name_String (Path); begin Canonical_Case_File_Name (Path_Name); while List /= null loop if List.Project.Path.Display_Name /= No_Path then declare Project_Path : String := Get_Name_String (List.Project.Path.Display_Name); begin Canonical_Case_File_Name (Project_Path); if Project_Path = Path_Name then Project := List.Project; exit; end if; end; end if; List := List.Next; end loop; end; if Project = No_Project then Project := new Project_Data' (Empty_Project (Project_Qualifier_Of (From_Project_Node, From_Project_Node_Tree))); -- Note that at this point we do not know yet if the project -- has been withed from an encapsulated library or not. In_Tree.Projects := new Project_List_Element' (Project => Project, From_Encapsulated_Lib => False, Next => In_Tree.Projects); end if; -- Keep track of this point Mark := In_Tree.Projects; Processed_Projects.Set (Name, Project); Project.Name := Name; Project.Display_Name := Display_Name; -- If name starts with the virtual prefix, flag the project as -- being a virtual extending project. if Util.Starts_With (Get_Name_String (Name), Virtual_Prefix) then Project.Virtual := True; end if; Project.Path.Display_Name := Path_Name_Of (From_Project_Node, From_Project_Node_Tree); Get_Name_String (Project.Path.Display_Name); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); Project.Path.Name := Name_Find; Project.Location := Location_Of (From_Project_Node, From_Project_Node_Tree); Project.Directory.Display_Name := Directory_Of (From_Project_Node, From_Project_Node_Tree); Get_Name_String (Project.Directory.Display_Name); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); Project.Directory.Name := Name_Find; Project.Extended_By := Extended_By; Project.Checksum := From_Project_Node_Tree.Project_Nodes.Table (From_Project_Node).Checksum; Add_Attributes (Project, Name, Name_Id (Project.Directory.Display_Name), In_Tree.Shared, Project.Decl, GPR.Attr.Attribute_First, Project_Level => True); Process_Imported_Projects (Imported, Limited_With => False); if Project.Qualifier = Aggregate then Initialize_And_Copy (Child_Env, Copy_From => Env); elsif Project.Qualifier = Aggregate_Library then -- The child environment is the same as the current one. -- Copy the Project_Path, so that if it is freed, the project -- path of the parent is not modified. Child_Env := (Env.External, No_Project_Search_Path, Env.Flags); Copy (Env.Project_Path, Child_Env.Project_Path); else -- No need to initialize Child_Env, since it will not be -- used anyway by Process_Declarative_Items (only the root -- aggregate can modify it, and it is never read anyway). null; end if; Declaration_Node := Project_Declaration_Of (From_Project_Node, From_Project_Node_Tree); Recursive_Process (In_Tree => In_Tree, Project => Project.Extends, Packages_To_Check => Packages_To_Check, From_Project_Node => Extended_Project_Of (Declaration_Node, From_Project_Node_Tree), From_Project_Node_Tree => From_Project_Node_Tree, Env => Env, Extended_By => Project, From_Encapsulated_Lib => From_Encapsulated_Lib, On_New_Tree_Loaded => On_New_Tree_Loaded); Process_Declarative_Items (Project => Project, In_Tree => In_Tree, From_Project_Node => From_Project_Node, Node_Tree => From_Project_Node_Tree, Env => Env, Pkg => No_Package, Item => First_Declarative_Item_Of (Declaration_Node, From_Project_Node_Tree), Child_Env => Child_Env); if Project.Extends /= No_Project then Process_Extended_Project; end if; Process_Imported_Projects (Imported, Limited_With => True); if Total_Errors_Detected = 0 then Process_Aggregated_Projects; end if; -- At this point (after Process_Declarative_Items) we have the -- attribute values set, we can backtrace In_Tree.Project and -- set the From_Encapsulated_Library status. declare Lib_Standalone : constant GPR.Variable_Value := GPR.Util.Value_Of (Snames.Name_Library_Standalone, Project.Decl.Attributes, Shared); List : Project_List := In_Tree.Projects; Is_Encapsulated : Boolean; begin Get_Name_String (Lib_Standalone.Value); To_Lower (Name_Buffer (1 .. Name_Len)); Is_Encapsulated := Name_Buffer (1 .. Name_Len) = "encapsulated"; if Is_Encapsulated then while List /= null and then List /= Mark loop List.From_Encapsulated_Lib := Is_Encapsulated; List := List.Next; end loop; end if; if Total_Errors_Detected = 0 then -- For an aggregate library we add the aggregated projects -- as imported ones. This is necessary to give visibility -- to all sources from the aggregates from the aggregated -- library projects. if Project.Qualifier = Aggregate_Library then declare L : Aggregated_Project_List; begin L := Project.Aggregated_Projects; while L /= null loop Project.Imported_Projects := new Project_List_Element' (Project => L.Project, From_Encapsulated_Lib => Is_Encapsulated, Next => Project.Imported_Projects); L := L.Next; end loop; end; end if; end if; end; if Project.Qualifier = Aggregate and then In_Tree.Is_Root_Tree then Free (Child_Env); end if; end; end if; end Recursive_Process; ----------------------------- -- Set_Default_Runtime_For -- ----------------------------- procedure Set_Default_Runtime_For (Language : Name_Id; Value : String) is begin Name_Len := Value'Length; Name_Buffer (1 .. Name_Len) := Value; Runtime_Defaults.Include (Language, Name_Find); end Set_Default_Runtime_For; end GPR.Proc; gprbuild-25.0.0/gpr/src/gpr-proc.ads000066400000000000000000000133171470075373400172260ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2021, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package is used to convert a project file tree (see prj-tree.ads) to -- project file data structures (see prj.ads), taking into account the -- environment (external references). with GPR.Tree; use GPR.Tree; package GPR.Proc is type Tree_Loaded_Callback is access procedure (Node_Tree : Project_Node_Tree_Ref; Tree : Project_Tree_Ref; Project_Node : Project_Node_Id; Project : Project_Id); -- Callback used after the phase 1 of the processing of each aggregated -- project to get access to project trees of aggregated projects. procedure Process_Project_Tree_Phase_1 (In_Tree : Project_Tree_Ref; Project : out Project_Id; Packages_To_Check : String_List_Access; Success : out Boolean; From_Project_Node : Project_Node_Id; From_Project_Node_Tree : Project_Node_Tree_Ref; Env : in out GPR.Tree.Environment; Reset_Tree : Boolean := True; On_New_Tree_Loaded : Tree_Loaded_Callback := null); -- Process a project tree (ie the direct resulting of parsing a .gpr file) -- based on the current external references. -- -- The result of this phase_1 is a partial project tree (Project) where -- only a few fields have been initialized (in particular the list of -- languages). These are the fields that are necessary to run gprconfig if -- needed to automatically generate a configuration file. This first phase -- of the processing does not require a configuration file. -- -- When Reset_Tree is True, all the project data are removed from the -- project table before processing. -- -- If specified, On_New_Tree_Loaded is called after each aggregated project -- has been processed successfully. procedure Process_Project_Tree_Phase_2 (In_Tree : Project_Tree_Ref; Project : Project_Id; Success : out Boolean; From_Project_Node : Project_Node_Id; From_Project_Node_Tree : Project_Node_Tree_Ref; Env : GPR.Tree.Environment); -- Perform the second phase of the processing, filling the rest of the -- project with the information extracted from the project tree. This phase -- requires that the configuration file has already been parsed (in fact -- we currently assume that the contents of the configuration file has -- been included in Project through Confgpr.Apply_Config_File). The -- parameters are the same as for phase_1, with the addition of: procedure Process (In_Tree : Project_Tree_Ref; Project : out Project_Id; Packages_To_Check : String_List_Access; Success : out Boolean; From_Project_Node : Project_Node_Id; From_Project_Node_Tree : Project_Node_Tree_Ref; Env : in out GPR.Tree.Environment; Reset_Tree : Boolean := True; On_New_Tree_Loaded : Tree_Loaded_Callback := null); -- Performs the two phases of the processing procedure Set_Default_Runtime_For (Language : Name_Id; Value : String); -- Set the default value for the runtime of Language. To be used for the -- value of 'Runtime() when Runtime () is not declared. function Expression (Project : Project_Id; Shared : Shared_Project_Tree_Data_Access; From_Project_Node : Project_Node_Id; From_Project_Node_Tree : Project_Node_Tree_Ref; Env : GPR.Tree.Environment; Pkg : Package_Id; First_Term : Project_Node_Id; Kind : Variable_Kind) return Variable_Value; -- From N_Expression project node From_Project_Node, compute the value -- of an expression and return it as a Variable_Value. end GPR.Proc; gprbuild-25.0.0/gpr/src/gpr-scans.adb000066400000000000000000000071031470075373400173450ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2015, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ package body GPR.Scans is ------------------------ -- Restore_Scan_State -- ------------------------ procedure Restore_Scan_State (Saved_State : Saved_Scan_State) is begin Scan_Ptr := Saved_State.Save_Scan_Ptr; Token := Saved_State.Save_Token; Token_Ptr := Saved_State.Save_Token_Ptr; Current_Line_Start := Saved_State.Save_Current_Line_Start; Start_Column := Saved_State.Save_Start_Column; Checksum := Saved_State.Save_Checksum; First_Non_Blank_Location := Saved_State.Save_First_Non_Blank_Location; Token_Node := Saved_State.Save_Token_Node; Token_Name := Saved_State.Save_Token_Name; Prev_Token := Saved_State.Save_Prev_Token; Prev_Token_Ptr := Saved_State.Save_Prev_Token_Ptr; end Restore_Scan_State; --------------------- -- Save_Scan_State -- --------------------- procedure Save_Scan_State (Saved_State : out Saved_Scan_State) is begin Saved_State.Save_Scan_Ptr := Scan_Ptr; Saved_State.Save_Token := Token; Saved_State.Save_Token_Ptr := Token_Ptr; Saved_State.Save_Current_Line_Start := Current_Line_Start; Saved_State.Save_Start_Column := Start_Column; Saved_State.Save_Checksum := Checksum; Saved_State.Save_First_Non_Blank_Location := First_Non_Blank_Location; Saved_State.Save_Token_Node := Token_Node; Saved_State.Save_Token_Name := Token_Name; Saved_State.Save_Prev_Token := Prev_Token; Saved_State.Save_Prev_Token_Ptr := Prev_Token_Ptr; end Save_Scan_State; end GPR.Scans; gprbuild-25.0.0/gpr/src/gpr-scans.ads000066400000000000000000000250321470075373400173670ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with GPR.Names; use GPR.Names; with GPR.Osint; use GPR.Osint; package GPR.Scans is type Token_Type is (Tok_Integer_Literal, Tok_Real_Literal, Tok_String_Literal, Tok_Char_Literal, Tok_Operator_Symbol, Tok_Identifier, Tok_Double_Asterisk, -- ** Tok_Ampersand, -- & Tok_Minus, -- - Tok_Plus, -- + Tok_Asterisk, -- * Tok_Mod, Tok_Rem, Tok_Slash, -- / Tok_New, Tok_Abs, Tok_Others, Tok_Null, Tok_Raise, Tok_Dot, -- . Tok_Apostrophe, -- ' Tok_Left_Paren, -- ( Tok_Delta, Tok_Digits, Tok_Range, Tok_Right_Paren, -- ) Tok_Comma, -- , Tok_And, Tok_Or, Tok_Xor, Tok_Less, -- < Tok_Equal, -- = Tok_Greater, -- > Tok_Not_Equal, -- /= Tok_Greater_Equal, -- >= Tok_Less_Equal, -- <= Tok_In, Tok_Not, Tok_Box, -- <> Tok_Colon_Equal, -- := Tok_Colon, -- : Tok_Greater_Greater, -- >> Tok_Abstract, Tok_Access, Tok_Aliased, Tok_All, Tok_Array, Tok_At, Tok_Body, Tok_Constant, Tok_Do, Tok_Is, Tok_Interface, Tok_Limited, Tok_Of, Tok_Out, Tok_Record, Tok_Renames, Tok_Reverse, Tok_Some, Tok_Tagged, Tok_Then, Tok_Less_Less, -- << Tok_Abort, Tok_Accept, Tok_Case, Tok_Delay, Tok_Else, Tok_Elsif, Tok_End, Tok_Exception, Tok_Exit, Tok_Goto, Tok_If, Tok_Pragma, Tok_Requeue, Tok_Return, Tok_Select, Tok_Terminate, Tok_Until, Tok_When, Tok_Begin, Tok_Declare, Tok_For, Tok_Loop, Tok_While, Tok_Entry, Tok_Protected, Tok_Task, Tok_Type, Tok_Subtype, Tok_Overriding, Tok_Synchronized, Tok_Use, Tok_Function, Tok_Generic, Tok_Package, Tok_Procedure, Tok_Private, Tok_With, Tok_Separate, Tok_EOF, Tok_Semicolon, Tok_Arrow, -- => Tok_Vertical_Bar, -- | Tok_Dot_Dot, -- .. Tok_Project, Tok_Extends, Tok_External, Tok_External_As_List, Tok_Comment, Tok_End_Of_Line, Tok_Special, Tok_SPARK_Hide, No_Token); -- No_Token is used for initializing Token values to indicate that no value -- has been set yet. subtype Token_Class_Cunit is Token_Type range Tok_Function .. Tok_Separate; -- Tokens which can begin a compilation unit subtype Token_Class_Literal is Token_Type range Tok_Integer_Literal .. Tok_Operator_Symbol; -- Literal type Token_Flag_Array is array (Token_Type) of Boolean; Is_Reserved_Keyword : constant Token_Flag_Array := Token_Flag_Array' (Tok_Mod .. Tok_Rem => True, Tok_New .. Tok_Null => True, Tok_Delta .. Tok_Range => True, Tok_And .. Tok_Xor => True, Tok_In .. Tok_Not => True, Tok_Abstract .. Tok_Then => True, Tok_Abort .. Tok_Separate => True, others => False); -- Flag array used to test for reserved word Special_Character : Character; -- Valid only when Token = Tok_Special. Returns one of the characters -- '#', '$', '?', '@', '`', '\', '^', '~', or '_'. -------------------------- -- Scan State Variables -- -------------------------- -- Note: these variables can only be referenced during the parsing of a -- file. Reference to any of them from Sem or the expander is wrong. -- These variables are initialized as required by Scn.Initialize_Scanner, -- and should not be referenced before such a call. However, there are -- situations in which these variables are saved and restored, and this -- may happen before the first Initialize_Scanner call, resulting in the -- assignment of invalid values. To avoid this, and allow building with -- the -gnatVa switch, we initialize some variables to known valid values. Scan_Ptr : Source_Ptr := No_Location; -- init for -gnatVa -- Current scan pointer location. After a call to Scan, this points -- just past the end of the token just scanned. Token : Token_Type := No_Token; -- init for -gnatVa -- Type of current token Token_Ptr : Source_Ptr := No_Location; -- init for -gnatVa -- Pointer to first character of current token Current_Line_Start : Source_Ptr := No_Location; -- init for -gnatVa -- Pointer to first character of line containing current token Start_Column : Column_Number := No_Column_Number; -- init for -gnatVa -- Starting column number (zero origin) of the first non-blank character on -- the line containing the current token. This is used for error recovery -- circuits which depend on looking at the column line up. Type_Token_Location : Source_Ptr := No_Location; -- init for -gnatVa -- Within a type declaration, gives the location of the TYPE keyword that -- opened the type declaration. Used in checking the end column of a record -- declaration, which can line up either with the TYPE keyword, or with the -- start of the line containing the RECORD keyword. Checksum : Word := 0; -- init for -gnatVa -- Used to accumulate a CRC representing the tokens in the source file -- being compiled. This CRC includes only program tokens, and excludes -- comments. First_Non_Blank_Location : Source_Ptr := No_Location; -- init for -gnatVa -- Location of first non-blank character on the line containing the current -- token (i.e. the location of the character whose column number is stored -- in Start_Column). Token_Node : Node_Id := Empty_Node; -- Node table Id for the current token. This is set only if the current -- token is one for which the scanner constructs a node (i.e. it is -- an identifier, operator symbol, or literal). For other token types, -- Token_Node is undefined. Token_Name : Name_Id := No_Name; -- For identifiers, this is set to the Name_Id of the identifier scanned. -- For all other tokens, Token_Name is set to Error_Name. Note that it -- would be possible for the caller to extract this information from -- Token_Node. We set Token_Name separately for two reasons. First it -- allows a quicker test for a specific identifier. Second, it allows a -- version of the parser to be built that does not build tree nodes, -- usable as a syntax checker. Prev_Token : Token_Type := No_Token; -- Type of previous token Prev_Token_Ptr : Source_Ptr; -- Pointer to first character of previous token Comment_Id : Name_Id := No_Name; -- Valid only when Token = Tok_Comment. Store the string that follows the -- "--" of a comment when scanning project files. Character_Code : Char_Code; -- Valid only when Token is Tok_Char_Literal. Contains the value of the -- scanned literal. Int_Literal_Value : Int; -- Valid only when Token = Tok_Integer_Literal, contains the value of the -- scanned literal. -------------------------------------------------------- -- Procedures for Saving and Restoring the Scan State -- -------------------------------------------------------- -- The following procedures can be used to save and restore the entire -- scan state. They are used in cases where it is necessary to backup -- the scan during the parse. type Saved_Scan_State is private; -- Used for saving and restoring the scan state procedure Save_Scan_State (Saved_State : out Saved_Scan_State); -- pragma Inline (Save_Scan_State); Saves the current scan state for -- possible later restoration. Note that there is no harm in saving -- the state and then never restoring it. procedure Restore_Scan_State (Saved_State : Saved_Scan_State); -- pragma Inline (Restore_Scan_State); -- Restores a scan state saved by a call to Save_Scan_State. -- The saved scan state must refer to the current source file. private type Saved_Scan_State is record Save_Scan_Ptr : Source_Ptr; Save_Token : Token_Type; Save_Token_Ptr : Source_Ptr; Save_Current_Line_Start : Source_Ptr; Save_Start_Column : Column_Number; Save_Checksum : Word; Save_First_Non_Blank_Location : Source_Ptr; Save_Token_Node : Node_Id; Save_Token_Name : Name_Id; Save_Prev_Token : Token_Type; Save_Prev_Token_Ptr : Source_Ptr; end record; end GPR.Scans; gprbuild-25.0.0/gpr/src/gpr-script.adb000066400000000000000000000122221470075373400175400ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2016-2018, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with GPR.Names; use GPR.Names; package body GPR.Script is Quote_List : constant String := "|&;<>()$`\"" *?[#~"; function Potentially_Quoted (S : String) return String; -- Check if S needed to be quoted. It needs to be quoted if S contains at -- least one character in the list above. Return S between simple quotes if -- needed, otherwise return S. ------------------------ -- Potentially_Quoted -- ------------------------ function Potentially_Quoted (S : String) return String is Need_Quoting : Boolean := False; Arg : String (1 .. 4 * S'Length); Last : Natural := 0; begin for J in S'Range loop if S (J) = ''' then Need_Quoting := True; Arg (Last + 1 .. Last + 4) := "'\''"; Last := Last + 4; else Last := Last + 1; Arg (Last) := S (J); if not Need_Quoting then for K in Quote_List'Range loop if S (J) = Quote_List (K) then Need_Quoting := True; exit; end if; end loop; end if; end if; end loop; if Need_Quoting then return "'" & Arg (1 .. Last) & "'"; else return S; end if; end Potentially_Quoted; ----------------------- -- Script_Change_Dir -- ----------------------- procedure Script_Change_Dir (New_Dir : Path_Name_Type) is Args : String_Vectors.Vector; begin if Build_Script_Name = null then return; end if; Args.Append (Get_Name_String (New_Dir)); Script_Write ("cd", Args); end Script_Change_Dir; ----------------- -- Script_Copy -- ----------------- procedure Script_Copy (File_Name : String; Destination : String) is begin if Build_Script_Name = null then return; end if; declare Args : String_Vectors.Vector; begin Args.Append (File_Name); Args.Append (Destination); Script_Write ("cp", Args); end; end Script_Copy; ------------------ -- Script_Write -- ------------------ procedure Script_Write (Program_Name : String; Args : String_Vectors.Vector) is Already_Open : Boolean; begin if Build_Script_Name = null then return; end if; Already_Open := Is_Open (Build_Script_File); if not Already_Open then Open (Build_Script_File, Append_File, Build_Script_Name.all); end if; Put (Build_Script_File, Potentially_Quoted (Program_Name)); for Arg of Args loop Put (Build_Script_File, " " & Potentially_Quoted (Arg)); end loop; New_Line (Build_Script_File); if not Already_Open then Close (Build_Script_File); end if; end Script_Write; ---------------------------- -- Spawn_And_Script_Write -- ---------------------------- procedure Spawn_And_Script_Write (Program_Name : String; Args : String_Vectors.Vector; Success : out Boolean) is Arg_List : String_List_Access := new String_List'(To_Argument_List (Args)); begin Script_Write (Program_Name, Args); Spawn (Program_Name, Arg_List.all, Success); Free (Arg_List); end Spawn_And_Script_Write; end GPR.Script; gprbuild-25.0.0/gpr/src/gpr-script.ads000066400000000000000000000060341470075373400175650ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2016-2018, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package provide services to build a build script in gprbuild. with Ada.Text_IO; use Ada.Text_IO; with GPR.Util; use GPR.Util; package GPR.Script is Build_Script_Option : constant String := "--build-script="; -- gprbuild switch to create a build script Build_Script_Name : String_Access := null; -- Path name of the build script Build_Script_File : File_Type; -- Build script file procedure Script_Write (Program_Name : String; Args : String_Vectors.Vector); -- If a build script is being built, append a line to invoke the -- program with its arguments. procedure Script_Change_Dir (New_Dir : Path_Name_Type); -- If a build script is being built, append a line to change the current -- working directory to New_Dir. procedure Script_Copy (File_Name : String; Destination : String); -- If a build script is being built, append a line to copy file File_Name -- to directory Destination. procedure Spawn_And_Script_Write (Program_Name : String; Args : String_Vectors.Vector; Success : out Boolean); -- If a build script is being built, append a line to invoke the program -- with its arguments, then spawn the process. end GPR.Script; gprbuild-25.0.0/gpr/src/gpr-sdefault.adb000066400000000000000000000073741470075373400200570ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2022, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with Ada.Text_IO; with System.OS_Constants; with GPR.Util; use GPR.Util; package body GPR.Sdefault is Default_Target_Parsed : Boolean := False; Default_Target_Val : Unbounded_String; ------------------------ -- Set_Default_Target -- ------------------------ procedure Set_Default_Target; -- Tries to parse /share/gprconfig/default_target -- and sets Default_Target_Val. procedure Set_Default_Target is Tgt_File_Base : constant String := "default_target"; Tgt_File_Full : constant String := Executable_Prefix_Path & "share" & Directory_Separator & "gprconfig" & Directory_Separator & Tgt_File_Base; F : Ada.Text_IO.File_Type; begin if Executable_Prefix_Path = "" then Debug_Output ("Gprtools installation not found"); Default_Target_Val := To_Unbounded_String (System.OS_Constants.Target_Name); end if; if not Is_Regular_File (Tgt_File_Full) then Debug_Output (Tgt_File_Full & " not found"); Default_Target_Val := To_Unbounded_String (System.OS_Constants.Target_Name); end if; Ada.Text_IO.Open (F, Ada.Text_IO.In_File, Tgt_File_Full); Default_Target_Val := To_Unbounded_String (Ada.Text_IO.Get_Line (F)); Ada.Text_IO.Close (F); exception when X : others => Debug_Output ("Cannot parse " & Tgt_File_Full); Debug_Output (Ada.Exceptions.Exception_Information (X)); Default_Target_Val := To_Unbounded_String (System.OS_Constants.Target_Name); end Set_Default_Target; -------------- -- Hostname -- -------------- function Hostname return String is begin if not Default_Target_Parsed then Default_Target_Parsed := True; Set_Default_Target; end if; return To_String (Default_Target_Val); end Hostname; end GPR.Sdefault; gprbuild-25.0.0/gpr/src/gpr-sdefault.ads000066400000000000000000000042441470075373400200710ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2006-2022, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- Package that provides the default hostname value package GPR.Sdefault is function Hostname return String; -- Calculates if necessary and returns the value of hostname. If gprtools -- installation contains share/gprconfig/default_target file, takes its -- contents as the hostname, otherwise defaults to target name specified -- in System.OS_Constants. end GPR.Sdefault; gprbuild-25.0.0/gpr/src/gpr-sinput.adb000066400000000000000000000545311470075373400175670ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 1992-2021, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Containers.Hashed_Maps; with Ada.Unchecked_Deallocation; with Ada.Unchecked_Conversion; with GNAT.Byte_Order_Mark; use GNAT.Byte_Order_Mark; with System; use System; pragma Warnings (Off); with System.WCh_Con; use System.WCh_Con; with System.WCh_Cnv; use System.WCh_Cnv; with System.Memory; pragma Warnings (On); with GPR.Err; with GPR.Erroutc; use GPR.Erroutc; with GPR.Names; use GPR.Names; with GPR.Opt; use GPR.Opt; with GPR.Output; use GPR.Output; package body GPR.Sinput is Lines_Initial : constant := 500; First : Boolean := True; -- Flag used when Load_File is called the first time, to set -- Main_Source_File. -- The flag is reset to False at the first call to Load_Project_File. -- Calling Reset_First sets it back to True. function Hash (Name : File_Name_Type) return Ada.Containers.Hash_Type is (Ada.Containers.Hash_Type (Name)); package Source_Id_Maps is new Ada.Containers.Hashed_Maps (Key_Type => File_Name_Type, Element_Type => Source_File_Index, Hash => Hash, Equivalent_Keys => "="); Sources_Map : Source_Id_Maps.Map; procedure Free is new Ada.Unchecked_Deallocation (Lines_Table_Type, Lines_Table_Ptr); procedure Free (S : in out GPR.Sinput.Source_File_Record); -- Free allocated memory --------------------------- -- Add_Line_Tables_Entry -- --------------------------- procedure Add_Line_Tables_Entry (S : in out Source_File_Record; P : Source_Ptr) is LL : Line_Number; begin -- Reallocate the lines tables if necessary if S.Last_Source_Line = S.Lines_Table'Last then declare New_Table : constant Lines_Table_Ptr := new Lines_Table_Type (1 .. S.Last_Source_Line * 2); begin New_Table (1 .. S.Last_Source_Line) := S.Lines_Table (1 .. S.Last_Source_Line); Free (S.Lines_Table); S.Lines_Table := New_Table; end; end if; S.Last_Source_Line := S.Last_Source_Line + 1; LL := S.Last_Source_Line; S.Lines_Table (LL) := P; end Add_Line_Tables_Entry; ------------------- -- Check_For_BOM -- ------------------- procedure Check_For_BOM is BOM : BOM_Kind; Len : Natural; Tst : String (1 .. 5); C : Character; begin for J in 1 .. 5 loop C := Source (Scan_Ptr + Source_Ptr (J) - 1); -- Definitely no BOM if EOF character marks either end of file, or -- an illegal non-BOM character if not at the end of file. if C = EOF then return; end if; Tst (J) := C; end loop; Read_BOM (Tst, Len, BOM, False); case BOM is when UTF8_All => Scan_Ptr := Scan_Ptr + Source_Ptr (Len); Wide_Character_Encoding_Method := WCEM_UTF8; Upper_Half_Encoding := True; when UTF16_LE | UTF16_BE => Set_Standard_Error; Write_Line ("UTF-16 encoding format not recognized"); raise Unrecoverable_Error; when UTF32_LE | UTF32_BE => Set_Standard_Error; Write_Line ("UTF-32 encoding format not recognized"); raise Unrecoverable_Error; when Unknown => null; when others => raise Program_Error; end case; end Check_For_BOM; ----------------------------- -- Clear_Source_File_Table -- ----------------------------- procedure Clear_Source_File_Table is begin for X in 1 .. Source_File.Last loop Free (Source_File.Table (X)); end loop; Sources_Map.Clear; Source_File.Free; Sinput.Initialize; end Clear_Source_File_Table; ---------- -- Free -- ---------- procedure Free (S : in out GPR.Sinput.Source_File_Record) is Lo : constant Source_Ptr := S.Source_First; Hi : constant Source_Ptr := S.Source_Last; subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi); -- Physical buffer allocated type Actual_Source_Ptr is access Actual_Source_Buffer; -- This is the pointer type for the physical buffer allocated procedure Free is new Ada.Unchecked_Deallocation (Actual_Source_Buffer, Actual_Source_Ptr); pragma Suppress (All_Checks); pragma Warnings (Off); -- The following unchecked conversion is aliased safe, since it -- is not used to create improperly aliased pointer values. function To_Actual_Source_Ptr is new Ada.Unchecked_Conversion (Address, Actual_Source_Ptr); pragma Warnings (On); Actual_Ptr : Actual_Source_Ptr := To_Actual_Source_Ptr (S.Source_Text (Lo)'Address); begin Free (Actual_Ptr); Free (S.Lines_Table); end Free; -------------------- -- Full_File_Name -- -------------------- function Full_File_Name (S : Source_File_Index) return File_Name_Type is begin return Source_File.Table (S).Full_File_Name; end Full_File_Name; ------------------- -- Full_Ref_Name -- ------------------- function Full_Ref_Name (S : Source_File_Index) return File_Name_Type is begin return Source_File.Table (S).Full_Ref_Name; end Full_Ref_Name; ----------------------- -- Get_Column_Number -- ----------------------- function Get_Column_Number (P : Source_Ptr) return Column_Number is S : Source_Ptr; C : Column_Number; Sindex : Source_File_Index; Src : Source_Buffer_Ptr; begin -- If the input source pointer is not a meaningful value then return -- at once with column number 1. This can happen for a file not found -- condition for a file loaded indirectly by RTE, and also perhaps on -- some unknown internal error conditions. In either case we certainly -- don't want to blow up. if P < 1 then return 1; else Sindex := Get_Source_File_Index (P); Src := Source_File.Table (Sindex).Source_Text; S := Line_Start (P); C := 1; while S < P loop if Src (S) = ASCII.HT then C := (C - 1) / 8 * 8 + (8 + 1); S := S + 1; -- Deal with wide character case, but don't include brackets -- notation in this circuit, since we know that this will -- display unencoded (no one encodes brackets notation). elsif Src (S) /= '[' and then Is_Start_Of_Wide_Char (Src, S) then C := C + 1; Skip_Wide (Src, S); -- Normal (non-wide) character case or brackets sequence else C := C + 1; S := S + 1; end if; end loop; return C; end if; end Get_Column_Number; --------------------- -- Get_Line_Number -- --------------------- function Get_Line_Number (P : Source_Ptr) return Line_Number is Sfile : Source_File_Index; Table : Lines_Table_Ptr; Lo : Line_Number; Hi : Line_Number; Mid : Line_Number; Loc : Source_Ptr; begin -- If the input source pointer is not a meaningful value then return -- at once with line number 1. This can happen for a file not found -- condition for a file loaded indirectly by RTE, and also perhaps on -- some unknown internal error conditions. In either case we certainly -- don't want to blow up. if P < 1 then return 1; -- Otherwise we can do the binary search else Sfile := Get_Source_File_Index (P); Loc := P; Table := Source_File.Table (Sfile).Lines_Table; Lo := 1; Hi := Source_File.Table (Sfile).Last_Source_Line; loop Mid := (Lo + Hi) / 2; if Loc < Table (Mid) then Hi := Mid - 1; else -- Loc >= Table (Mid) if Mid = Hi or else Loc < Table (Mid + 1) then return Mid; else Lo := Mid + 1; end if; end if; end loop; end if; end Get_Line_Number; --------------------------- -- Get_Source_File_Index -- --------------------------- function Get_Source_File_Index (S : Source_Ptr) return Source_File_Index is begin return Source_File_Index_Table (Int (S) / Source_Align); end Get_Source_File_Index; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Source_File.Init; end Initialize; ---------------------- -- Last_Source_File -- ---------------------- function Last_Source_File return Source_File_Index is begin return Source_File.Last; end Last_Source_File; ---------------- -- Line_Start -- ---------------- function Line_Start (P : Source_Ptr) return Source_Ptr is Sindex : constant Source_File_Index := Get_Source_File_Index (P); Src : constant Source_Buffer_Ptr := Source_File.Table (Sindex).Source_Text; Sfirst : constant Source_Ptr := Source_File.Table (Sindex).Source_First; S : Source_Ptr; begin if Src = null then return No_Location; end if; S := P; while S > Sfirst and then Src (S - 1) /= ASCII.CR and then Src (S - 1) /= ASCII.LF loop S := S - 1; end loop; return S; end Line_Start; function Line_Start (L : Line_Number; S : Source_File_Index) return Source_Ptr is begin return Source_File.Table (S).Lines_Table (L); end Line_Start; --------------- -- Load_File -- --------------- function Load_File (Path : String) return Source_File_Index is Src : Source_Buffer_Ptr; X : Source_File_Index; Lo : Source_Ptr; Hi : Source_Ptr; Source_File_FD : File_Descriptor; -- The file descriptor for the current source file. A negative value -- indicates failure to open the specified source file. Len : Integer; -- Length of file (assume no more than 2 gigabytes of source) Actual_Len : Integer; Position : Source_Id_Maps.Cursor; Inserted : Boolean; Path_Id : File_Name_Type; File_Id : File_Name_Type; begin if Path = "" then return No_Source_File; end if; Path_Id := Get_File_Name_Id (Path); Sources_Map.Insert (Path_Id, Source_File.Last + 1, Position, Inserted); if not Inserted then return Result : constant Source_File_Index := Source_Id_Maps.Element (Position) do pragma Assert (Source_File.Table (Result).Full_Debug_Name = Path_Id, "insertion failed for " & Get_Name_String_Safe (Source_File.Table (Result).Full_Debug_Name) & ' ' & Get_Name_String_Safe (Path_Id)); pragma Assert (Source_File.Table (Result).Full_File_Name = Path_Id, "insertion failed for " & Source_File.Table (Result).Full_File_Name'Img & Path_Id'Img); pragma Assert (Source_File.Table (Result).Full_Ref_Name = Path_Id, "insertion failed for " & Source_File.Table (Result).Full_Ref_Name'Img & Path_Id'Img); end return; end if; Source_File.Increment_Last; X := Source_File.Last; if X = Source_File.First then Lo := First_Source_Ptr; else Lo := ((Source_File.Table (X - 1).Source_Last + Source_Align) / Source_Align) * Source_Align; end if; Name_Buffer (Name_Len + 1) := ASCII.NUL; -- Open the source FD, note that we open in binary mode, because as -- documented in the spec, the caller is expected to handle either -- DOS or Unix mode files, and there is no point in wasting time on -- text translation when it is not required. Source_File_FD := Open_Read (Name_Buffer'Address, Binary); if Source_File_FD = Invalid_FD then Source_File.Decrement_Last; Sources_Map.Delete (Position); return No_Source_File; end if; Len := Integer (File_Length (Source_File_FD)); -- Set Hi so that length is one more than the physical length, allowing -- for the extra EOF character at the end of the buffer Hi := Lo + Source_Ptr (Len); -- Do the actual read operation declare subtype Actual_Source_Buffer is Source_Buffer (Lo .. Hi); -- Physical buffer allocated type Actual_Source_Ptr is access Actual_Source_Buffer; -- This is the pointer type for the physical buffer allocated Actual_Ptr : constant Actual_Source_Ptr := new Actual_Source_Buffer; -- And this is the actual physical buffer begin -- Allocate source buffer, allowing extra character at end for EOF -- Some systems have file types that require one read per line, -- so read until we get the Len bytes or until there are no more -- characters. Hi := Lo; loop Actual_Len := Read (Source_File_FD, Actual_Ptr (Hi)'Address, Len); Hi := Hi + Source_Ptr (Actual_Len); exit when Actual_Len = Len or else Actual_Len <= 0; end loop; Actual_Ptr (Hi) := EOF; -- Now we need to work out the proper virtual origin pointer to -- return. This is exactly Actual_Ptr (0)'Address, but we have to -- be careful to suppress checks to compute this address. declare pragma Suppress (All_Checks); pragma Warnings (Off); -- The following unchecked conversion is aliased safe, since it -- is not used to create improperly aliased pointer values. function To_Source_Buffer_Ptr is new Ada.Unchecked_Conversion (Address, Source_Buffer_Ptr); pragma Warnings (On); begin Src := To_Source_Buffer_Ptr (Actual_Ptr (0)'Address); end; end; -- Read is complete, close the file and we are done (no need to test -- status from close, since we have successfully read the file). Close (Source_File_FD); -- Get the file name, without path information declare Index : Positive := Path'Last; begin while Index > Path'First loop exit when Is_Directory_Separator (Path (Index - 1)); Index := Index - 1; end loop; Name_Len := Path'Last - Index + 1; Name_Buffer (1 .. Name_Len) := Path (Index .. Path'Last); File_Id := Name_Find; end; declare S : Source_File_Record renames Source_File.Table (X); begin S := (File_Name => File_Id, Reference_Name => File_Id, Debug_Source_Name => File_Id, Full_Debug_Name => Path_Id, Full_File_Name => Path_Id, Full_Ref_Name => Path_Id, Source_Text => Src, Source_First => Lo, Source_Last => Hi, Last_Source_Line => 1, Lines_Table => new Lines_Table_Type (1 .. Lines_Initial)); S.Lines_Table (1) := Lo; end; Set_Source_File_Index_Table (X); if First then Main_Source_File := X; First := False; end if; return X; end Load_File; ---------------------- -- Num_Source_Files -- ---------------------- function Num_Source_Files return Nat is begin return Int (Source_File.Last) - Int (Source_File.First) + 1; end Num_Source_Files; ---------------------- -- Num_Source_Lines -- ---------------------- function Num_Source_Lines (S : Source_File_Index) return Nat is begin return Nat (Source_File.Table (S).Last_Source_Line); end Num_Source_Lines; -------------------- -- Reference_Name -- -------------------- function Reference_Name (S : Source_File_Index) return File_Name_Type is begin return Source_File.Table (S).Reference_Name; end Reference_Name; ----------------- -- Reset_First -- ----------------- procedure Reset_First is begin First := True; end Reset_First; -------------------------------- -- Restore_Project_Scan_State -- -------------------------------- procedure Restore_Project_Scan_State (Saved_State : Saved_Project_Scan_State) is begin Restore_Scan_State (Saved_State.Scan_State); Source := Saved_State.Source; Current_Source_File := Saved_State.Current_Source_File; end Restore_Project_Scan_State; ----------------------------- -- Save_Project_Scan_State -- ----------------------------- procedure Save_Project_Scan_State (Saved_State : out Saved_Project_Scan_State) is begin Save_Scan_State (Saved_State.Scan_State); Saved_State.Source := Source; Saved_State.Current_Source_File := Current_Source_File; end Save_Project_Scan_State; --------------------------------- -- Set_Source_File_Index_Table -- --------------------------------- procedure Set_Source_File_Index_Table (Xnew : Source_File_Index) is Ind : Int; SP : Source_Ptr; SL : constant Source_Ptr := Source_File.Table (Xnew).Source_Last; begin SP := Source_File.Table (Xnew).Source_First; pragma Assert (SP mod Source_Align = 0); Ind := Int (SP) / Source_Align; while SP <= SL loop Source_File_Index_Table (Ind) := Xnew; SP := SP + Source_Align; Ind := Ind + 1; end loop; end Set_Source_File_Index_Table; --------------- -- Skip_Wide -- --------------- procedure Skip_Wide (S : Source_Buffer_Ptr; P : in out Source_Ptr) is function Skip_Char return Character; -- Function to skip one character of wide character escape sequence --------------- -- Skip_Char -- --------------- function Skip_Char return Character is begin P := P + 1; return S (P - 1); end Skip_Char; function WC_Skip is new Char_Sequence_To_UTF_32 (Skip_Char); Discard : UTF_32_Code; pragma Warnings (Off, Discard); -- Start of processing for Skip_Wide begin Discard := WC_Skip (Skip_Char, Wide_Character_Encoding_Method); end Skip_Wide; ---------------------------- -- Source_File_Is_Subunit -- ---------------------------- function Source_File_Is_Subunit (X : Source_File_Index) return Boolean is begin -- Nothing to do if X is no source file, so simply return False if X = No_Source_File then return False; end if; Err.Scanner.Initialize_Scanner (X, Err.Scanner.Ada); -- No error for special characters that are used for preprocessing Err.Scanner.Set_Special_Character ('#'); Err.Scanner.Set_Special_Character ('$'); -- We scan past junk to the first interesting compilation unit token, to -- see if it is SEPARATE. We ignore WITH keywords during this and also -- PRIVATE. The reason for ignoring PRIVATE is that it handles some -- error situations, and also to handle PRIVATE WITH in Ada 2005 mode. while Token = Tok_With or else Token = Tok_Private or else (Token not in Token_Class_Cunit and then Token /= Tok_EOF) loop Err.Scanner.Scan; end loop; Err.Scanner.Reset_Special_Characters; return Token = Tok_Separate; end Source_File_Is_Subunit; ---------------------- -- Source_File_Trim -- ---------------------- procedure Source_File_Trim (Last : Source_File_Index) is begin for Index in Last + 1 .. GPR.Sinput.Source_File.Last loop Sources_Map.Delete (GPR.Sinput.Source_File.Table (Index).Full_File_Name); Free (GPR.Sinput.Source_File.Table (Index)); end loop; GPR.Sinput.Source_File.Set_Last (Last); end Source_File_Trim; ------------------ -- Source_First -- ------------------ function Source_First (S : Source_File_Index) return Source_Ptr is begin return Source_File.Table (S).Source_First; end Source_First; ----------------- -- Source_Last -- ----------------- function Source_Last (S : Source_File_Index) return Source_Ptr is begin return Source_File.Table (S).Source_Last; end Source_Last; ----------------- -- Source_Text -- ----------------- function Source_Text (S : Source_File_Index) return Source_Buffer_Ptr is begin return Source_File.Table (S).Source_Text; end Source_Text; end GPR.Sinput; gprbuild-25.0.0/gpr/src/gpr-sinput.ads000066400000000000000000000401011470075373400175740ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 1992-2021, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package contains the input routines used for reading the -- input source file. The actual I/O routines are in OS_Interface, -- with this module containing only the system independent processing. -- General Note: throughout the compiler, we use the term line or source -- line to refer to a physical line in the source, terminated by the end of -- physical line sequence. -- There are two distinct concepts of line terminator in GNAT -- A logical line terminator is what corresponds to the "end of a line" as -- described in RM 2.2 (13). Any of the characters FF, LF, CR or VT or any -- wide character that is a Line or Paragraph Separator acts as an end of -- logical line in this sense, and it is essentially irrelevant whether one -- or more appears in sequence (since if a sequence of such characters is -- regarded as separate ends of line, then the intervening logical lines -- are null in any case). -- A physical line terminator is a sequence of format effectors that is -- treated as ending a physical line. Physical lines have no Ada semantic -- significance, but they are significant for error reporting purposes, -- since errors are identified by line and column location. -- In GNAT, a physical line is ended by any of the sequences LF, CR/LF, or -- CR. LF is used in typical Unix systems, CR/LF in DOS systems, and CR -- alone in System 7. In addition, we recognize any of these sequences in -- any of the operating systems, for better behavior in treating foreign -- files (e.g. a Unix file with LF terminators transferred to a DOS system). -- Finally, wide character codes in categories Separator, Line and Separator, -- Paragraph are considered to be physical line terminators. with GNAT.Table; with GPR.Scans; use GPR.Scans; with GPR.Osint; use GPR.Osint; package GPR.Sinput is function Last_Source_File return Source_File_Index; -- Index of last source file table entry function Num_Source_Files return Nat; -- Number of source file table entries procedure Initialize; -- Initialize internal tables Main_Source_File : Source_File_Index := No_Source_File; -- This is set to the source file index of the main unit function Load_File (Path : String) return Source_File_Index; -- Load a file into memory and Initialize the Scans state ----------------------------- -- Source_File_Index_Table -- ----------------------------- -- The Get_Source_File_Index function is called very frequently. Earlier -- versions cached a single entry, but then reverted to a serial search, -- and this proved to be a significant source of inefficiency. We then -- switched to using a table with a start point followed by a serial -- search. Now we make sure source buffers are on a reasonable boundary -- (see Types.Source_Align), and we can just use a direct look up in the -- following table. -- Note that this array is pretty large, but in most operating systems -- it will not be allocated in physical memory unless it is actually used. Source_File_Index_Table : array (Int range 0 .. 1 + (Int'Last / Source_Align)) of Source_File_Index; procedure Set_Source_File_Index_Table (Xnew : Source_File_Index); -- Sets entries in the Source_File_Index_Table for the newly created -- Source_File table entry whose index is Xnew. The Source_First and -- Source_Last fields of this entry must be set before the call. function Get_Column_Number (P : Source_Ptr) return Column_Number; -- The ones-origin column number of the specified Source_Ptr value is -- determined and returned. Tab characters if present are assumed to -- represent the standard 1,9,17.. spacing pattern. function Get_Line_Number (P : Source_Ptr) return Line_Number; -- The line number of the specified source position is obtained by -- doing a binary search on the source positions in the lines table -- for the unit containing the given source position. The returned -- value is the line number in the source being compiled. function Get_Source_File_Index (S : Source_Ptr) return Source_File_Index; pragma Inline (Get_Source_File_Index); -- Return file table index of file identified by given source pointer -- value. This call must always succeed, since any valid source pointer -- value belongs to some previously loaded source file. function Line_Start (P : Source_Ptr) return Source_Ptr; -- Finds the source position of the start of the line containing the -- given source location. function Line_Start (L : Line_Number; S : Source_File_Index) return Source_Ptr; -- Finds the source position of the start of the given line in the -- given source file, using a physical line number to identify the line. function Num_Source_Lines (S : Source_File_Index) return Nat; -- Returns the number of source lines (this is equivalent to reading -- the value of Last_Source_Line, but returns Nat rather than a -- physical line number. function Full_File_Name (S : Source_File_Index) return File_Name_Type; function Full_Ref_Name (S : Source_File_Index) return File_Name_Type; function Reference_Name (S : Source_File_Index) return File_Name_Type; function Source_First (S : Source_File_Index) return Source_Ptr; function Source_Last (S : Source_File_Index) return Source_Ptr; function Source_Text (S : Source_File_Index) return Source_Buffer_Ptr; procedure Skip_Wide (S : Source_Buffer_Ptr; P : in out Source_Ptr); -- Similar to the above procedure, but operates on a source buffer -- instead of a string, with P being a Source_Ptr referencing the -- contents of the source buffer. ----------------------- -- Checksum Handling -- ----------------------- -- As a source file is scanned, a checksum is computed by taking all the -- non-blank characters in the file, excluding comment characters, the -- minus-minus sequence starting a comment, and all control characters -- except ESC. -- The checksum algorithm used is the standard CRC-32 algorithm, as -- implemented by System.CRC32, except that we do not bother with the -- final XOR with all 1 bits. -- This algorithm ensures that the checksum includes all semantically -- significant aspects of the program represented by the source file, -- but is insensitive to layout, presence or contents of comments, wide -- character representation method, or casing conventions outside strings. -- Scans.Checksum is initialized appropriately at the start of scanning -- a file, and copied into the Source_Checksum field of the file table -- entry when the end of file is encountered. ----------------- -- Global Data -- ----------------- Current_Source_File : Source_File_Index := No_Source_File; -- Source_File table index of source file currently being scanned. -- Initialized so that some tools (such as gprbuild) can be built with -- -gnatVa and pragma Initialized_Scalars without problems. Source : Source_Buffer_Ptr; -- Current source (copy of Source_File.Table (Current_Source_Unit).Source) Internal_Source : aliased Source_Buffer (1 .. 81); -- This buffer is used internally in the compiler when the lexical analyzer -- is used to scan a string from within the compiler. The procedure is to -- establish Internal_Source_Ptr as the value of Source, set the string to -- be scanned, appropriately terminated, in this buffer, and set Scan_Ptr -- to point to the start of the buffer. It is a fatal error if the scanner -- signals an error while scanning a token in this internal buffer. Internal_Source_Ptr : constant Source_Buffer_Ptr := Internal_Source'Unrestricted_Access; -- Pointer to internal source buffer Upper_Half_Encoding : Boolean := False; -- Normally set False, indicating that upper half ISO 8859-1 characters are -- used in the normal way to represent themselves. If the wide character -- encoding method uses the upper bit for this encoding, then this flag is -- set True, and upper half characters in the source indicate the start of -- a wide character sequence. procedure Clear_Source_File_Table; -- This procedure frees memory allocated in the Source_File table (in the -- private part of package Sinput). It should only be used when it is -- guaranteed that all source files that have been loaded so far will not -- be accessed before being reloaded. It is intended for tools that parse -- several times sources, to avoid memory leaks. procedure Reset_First; -- Indicate that the next project loaded should be considered as the first -- one, so that Sinput.Main_Source_File is set for this project file. This -- is to get the correct number of lines when error finalization is called. function Source_File_Is_Subunit (X : Source_File_Index) return Boolean; -- This function determines if a source file represents a subunit. It works -- by scanning for the first compilation unit token, and returning True if -- it is the token SEPARATE. It will return False otherwise, meaning that -- the file cannot possibly be a legal subunit. This function does NOT do a -- complete parse of the file, or build a tree. It is used in gnatmake and -- gprbuild to decide if a body without a spec in a project file needs to -- be compiled or not. Returns False if X = No_Source_File. type Saved_Project_Scan_State is limited private; -- Used to save project scan state in following two routines procedure Save_Project_Scan_State (Saved_State : out Saved_Project_Scan_State); pragma Inline (Save_Project_Scan_State); -- Save the Scans state, as well as the values of Source and -- Current_Source_File. procedure Restore_Project_Scan_State (Saved_State : Saved_Project_Scan_State); pragma Inline (Restore_Project_Scan_State); -- Restore the Scans state and the values of Source and -- Current_Source_File. procedure Check_For_BOM; -- Check if the current source starts with a BOM. Scan_Ptr needs to be at -- the start of the current source. If the current source starts with a -- recognized BOM, then some flags such as Wide_Character_Encoding_Method -- are set accordingly, and the Scan_Ptr on return points past this BOM. -- An error message is output and Unrecoverable_Error raised if a non- -- recognized BOM is detected. The call has no effect if no BOM is found. ------------------------- -- Source_Lines Tables -- ------------------------- type Lines_Table_Type is array (Line_Number range <>) of Source_Ptr; -- Type used for lines table type Lines_Table_Ptr is access all Lines_Table_Type; -- Type used for pointers to line tables -- See earlier descriptions for meanings of public fields type Source_File_Record is record File_Name : File_Name_Type; Reference_Name : File_Name_Type; Debug_Source_Name : File_Name_Type; Full_Debug_Name : File_Name_Type; Full_File_Name : File_Name_Type; Full_Ref_Name : File_Name_Type; Source_Text : Source_Buffer_Ptr; Source_First : Source_Ptr; Source_Last : Source_Ptr; Last_Source_Line : Line_Number; -- The following fields are for internal use only (i.e. only in the -- body of Sinput or its children, with no direct access by clients). Lines_Table : Lines_Table_Ptr; -- Pointer to lines table for this source. Updated as additional -- lines are accessed using the Skip_Line_Terminators procedure. -- Note: the lines table for an instantiation entry refers to the -- original line numbers of the template see Sinput-L for details. end record; function Current_Source_Record return access Source_File_Record; -- Returns access to the current source file record function Source_File_Last return Source_File_Index; -- Returns number of source files in the internal table procedure Source_File_Trim (Last : Source_File_Index); -- Truncate number of source files kept in the internal table procedure Add_Line_Tables_Entry (S : in out Source_File_Record; P : Source_Ptr); -- Increment line table size by one (reallocating the lines table if -- needed) and set the new entry to contain the value P. Also bumps -- the Source_Line_Count field. If source reference pragmas are -- present, also increments logical lines table size by one, and -- sets new entry. private ----------------------- -- Source_File Table -- ----------------------- package Source_File is new GNAT.Table (Table_Component_Type => Source_File_Record, Table_Index_Type => Source_File_Index, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 200); type Saved_Project_Scan_State is record Scan_State : Saved_Scan_State; Source : Source_Buffer_Ptr; Current_Source_File : Source_File_Index; end record; function Current_Source_Record return access Source_File_Record is (Source_File.Table (Current_Source_File)'Unrestricted_Access); function Source_File_Last return Source_File_Index is (Source_File.Last); ----------------- -- Subprograms -- ----------------- -- procedure Alloc_Line_Tables -- (S : in out Source_File_Record; -- New_Max : Nat); -- -- Allocate or reallocate the lines table for the given source file so -- -- that it can accommodate at least New_Max lines. Also allocates or -- -- reallocates logical lines table if source ref pragmas are present. -- -- procedure Add_Line_Tables_Entry -- (S : in out Source_File_Record; -- P : Source_Ptr); -- -- Increment line table size by one (reallocating the lines table if -- -- needed) and set the new entry to contain the value P. Also bumps -- -- the Source_Line_Count field. If source reference pragmas are -- -- present, also increments logical lines table size by one, and -- -- sets new entry. -- -- procedure Trim_Lines_Table (S : Source_File_Index); -- -- Set lines table size for entry S in the source file table to -- -- correspond to the current value of Num_Source_Lines, releasing -- -- any unused storage. This is used by Sinput.L and Sinput.D. end GPR.Sinput; gprbuild-25.0.0/gpr/src/gpr-snames.adb000066400000000000000000000305431470075373400175300ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2015-2022, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with GPR.Names; use GPR.Names; package body GPR.Snames is procedure Add_Name (S : String); Sequence : Name_Id := First_Name_Id; -------------- -- Add_Name -- -------------- procedure Add_Name (S : String) is begin Sequence := Sequence + 1; if Get_Name_Id (S) /= Sequence then raise Program_Error with "Wrong string constant """ & S & """ initialization" & Sequence'Img; end if; end Add_Name; ---------------- -- Initialize -- ---------------- procedure Initialize is begin if Sequence > First_Name_Id then return; end if; Add_Name ("c"); Add_Name ("abort"); Add_Name ("abs"); Add_Name ("accept"); Add_Name ("and"); Add_Name ("all"); Add_Name ("array"); Add_Name ("at"); Add_Name ("begin"); Add_Name ("body"); Add_Name ("case"); Add_Name ("constant"); Add_Name ("declare"); Add_Name ("delay"); Add_Name ("do"); Add_Name ("else"); Add_Name ("elsif"); Add_Name ("end"); Add_Name ("entry"); Add_Name ("exception"); Add_Name ("exit"); Add_Name ("for"); Add_Name ("function"); Add_Name ("generic"); Add_Name ("goto"); Add_Name ("if"); Add_Name ("in"); Add_Name ("is"); Add_Name ("limited"); Add_Name ("loop"); Add_Name ("new"); Add_Name ("not"); Add_Name ("null"); Add_Name ("of"); Add_Name ("or"); Add_Name ("others"); Add_Name ("out"); Add_Name ("package"); Add_Name ("pragma"); Add_Name ("private"); Add_Name ("procedure"); Add_Name ("raise"); Add_Name ("record"); Add_Name ("rem"); Add_Name ("renames"); Add_Name ("return"); Add_Name ("reverse"); Add_Name ("select"); Add_Name ("separate"); Add_Name ("subtype"); Add_Name ("task"); Add_Name ("terminate"); Add_Name ("then"); Add_Name ("type"); Add_Name ("use"); Add_Name ("when"); Add_Name ("while"); Add_Name ("with"); Add_Name ("xor"); Add_Name ("access"); Add_Name ("delta"); Add_Name ("digits"); Add_Name ("mod"); Add_Name ("range"); Add_Name ("abstract"); Add_Name ("aliased"); Add_Name ("protected"); Add_Name ("until"); Add_Name ("requeue"); Add_Name ("tagged"); Add_Name ("project"); Add_Name ("extends"); Add_Name ("external"); Add_Name ("external_as_list"); Add_Name ("interface"); Add_Name ("overriding"); Add_Name ("synchronized"); Add_Name ("some"); Add_Name ("active"); Add_Name ("aggregate"); Add_Name ("archive_builder"); Add_Name ("archive_builder_append_option"); Add_Name ("archive_indexer"); Add_Name ("archive_suffix"); Add_Name ("artifacts"); Add_Name ("artifacts_in_exec_dir"); Add_Name ("artifacts_in_object_dir"); Add_Name ("binder"); Add_Name ("bindfile_option_substitution"); Add_Name ("body_suffix"); Add_Name ("builder"); Add_Name ("clean"); Add_Name ("compiler"); Add_Name ("compiler_command"); Add_Name ("config_body_file_name"); Add_Name ("config_body_file_name_index"); Add_Name ("config_body_file_name_pattern"); Add_Name ("config_file_dependency_support"); Add_Name ("config_file_switches"); Add_Name ("config_file_unique"); Add_Name ("config_spec_file_name"); Add_Name ("config_spec_file_name_index"); Add_Name ("config_spec_file_name_pattern"); Add_Name ("configuration"); Add_Name ("cross_reference"); Add_Name ("def"); Add_Name ("default_language"); Add_Name ("default_switches"); Add_Name ("dependency_driver"); Add_Name ("dependency_kind"); Add_Name ("dependency_switches"); Add_Name ("driver"); Add_Name ("excluded_source_dirs"); Add_Name ("excluded_source_files"); Add_Name ("excluded_source_list_file"); Add_Name ("exec_dir"); Add_Name ("exec_subdir"); Add_Name ("excluded_patterns"); Add_Name ("executable"); Add_Name ("executable_suffix"); Add_Name ("externally_built"); Add_Name ("finder"); Add_Name ("flat"); Add_Name ("gcc"); Add_Name ("gcc_gnu"); Add_Name ("gcc_option_list"); Add_Name ("gcc_object_list"); Add_Name ("global_compilation_switches"); Add_Name ("global_configuration_pragmas"); Add_Name ("global_config_file"); Add_Name ("gnatls"); Add_Name ("gnatstub"); Add_Name ("gnu"); Add_Name ("ide"); Add_Name ("ignore_source_sub_dirs"); Add_Name ("implementation"); Add_Name ("implementation_exceptions"); Add_Name ("implementation_suffix"); Add_Name ("included_artifact_patterns"); Add_Name ("included_patterns"); Add_Name ("include_switches"); Add_Name ("include_path"); Add_Name ("include_path_file"); Add_Name ("inherit_source_path"); Add_Name ("install"); Add_Name ("install_project"); Add_Name ("languages"); Add_Name ("language_kind"); Add_Name ("leading_library_options"); Add_Name ("leading_required_switches"); Add_Name ("leading_switches"); Add_Name ("ali_subdir"); Add_Name ("lib_subdir"); Add_Name ("link_lib_subdir"); Add_Name ("library"); Add_Name ("library_ali_dir"); Add_Name ("library_auto_init"); Add_Name ("library_auto_init_supported"); Add_Name ("library_builder"); Add_Name ("library_dir"); Add_Name ("library_gcc"); Add_Name ("library_install_name_option"); Add_Name ("library_interface"); Add_Name ("library_kind"); Add_Name ("library_name"); Add_Name ("library_major_minor_id_supported"); Add_Name ("library_options"); Add_Name ("library_partial_linker"); Add_Name ("library_rpath_options"); Add_Name ("library_standalone"); Add_Name ("library_encapsulated_options"); Add_Name ("library_encapsulated_supported"); Add_Name ("library_src_dir"); Add_Name ("library_support"); Add_Name ("library_symbol_file"); Add_Name ("library_symbol_policy"); Add_Name ("library_version"); Add_Name ("library_version_switches"); Add_Name ("linker"); Add_Name ("linker_executable_option"); Add_Name ("linker_lib_dir_option"); Add_Name ("linker_lib_name_option"); Add_Name ("local_config_file"); Add_Name ("local_configuration_pragmas"); Add_Name ("locally_removed_files"); Add_Name ("map_file_option"); Add_Name ("mapping_file_switches"); Add_Name ("mapping_spec_suffix"); Add_Name ("mapping_body_suffix"); Add_Name ("max_command_line_length"); Add_Name ("metrics"); Add_Name ("multi_unit_object_separator"); Add_Name ("multi_unit_switches"); Add_Name ("naming"); Add_Name ("none"); Add_Name ("object_artifact_extensions"); Add_Name ("object_file_suffix"); Add_Name ("object_file_switches"); Add_Name ("object_generated"); Add_Name ("object_list"); Add_Name ("object_path_switches"); Add_Name ("objects_linked"); Add_Name ("objects_path"); Add_Name ("objects_path_file"); Add_Name ("object_dir"); Add_Name ("option_list"); Add_Name ("pic_option"); Add_Name ("pretty_printer"); Add_Name ("prefix"); Add_Name ("project_dir"); Add_Name ("project_files"); Add_Name ("project_path"); Add_Name ("project_subdir"); Add_Name ("remote"); Add_Name ("response_file_format"); Add_Name ("response_file_switches"); Add_Name ("root_dir"); Add_Name ("roots"); Add_Name ("required_artifacts"); Add_Name ("required_switches"); Add_Name ("run_path_option"); Add_Name ("run_path_origin"); Add_Name ("separate_run_path_options"); Add_Name ("shared_library_minimum_switches"); Add_Name ("shared_library_prefix"); Add_Name ("shared_library_suffix"); Add_Name ("separate_suffix"); Add_Name ("side_debug"); Add_Name ("source_artifact_extensions"); Add_Name ("source_dirs"); Add_Name ("source_file_switches"); Add_Name ("source_files"); Add_Name ("source_list_file"); Add_Name ("sources_subdir"); Add_Name ("spec"); Add_Name ("spec_suffix"); Add_Name ("specification"); Add_Name ("specification_exceptions"); Add_Name ("specification_suffix"); Add_Name ("stack"); Add_Name ("switches"); Add_Name ("symbolic_link_supported"); Add_Name ("toolchain_description"); Add_Name ("toolchain_version"); Add_Name ("trailing_required_switches"); Add_Name ("trailing_switches"); Add_Name ("runtime_library_dir"); Add_Name ("runtime_library_dirs"); Add_Name ("runtime_source_dir"); Add_Name ("ada"); Add_Name ("interfaces"); Add_Name ("main"); Add_Name ("target"); Add_Name ("casing"); Add_Name ("dot_replacement"); Add_Name ("standard"); Add_Name ("name"); Add_Name ("linker_options"); Add_Name ("runtime"); Add_Name ("mode"); Add_Name ("install_name"); Add_Name ("object_lister"); Add_Name ("object_lister_matcher"); Add_Name ("export_file_format"); Add_Name ("export_file_switch"); Add_Name ("runtime_source_dirs"); Add_Name ("runtime_dir"); Add_Name ("runtime_library_version"); Add_Name ("split"); Add_Name ("create_missing_dirs"); Add_Name ("canonical_target"); Add_Name ("warning_message"); Add_Name ("only_dirs_with_sources"); Add_Name ("include_switches_via_spec"); Add_Name ("required_toolchain_version"); Add_Name ("toolchain_name"); Add_Name ("check"); Add_Name ("eliminate"); Add_Name ("remote_host"); Add_Name ("program_host"); Add_Name ("communication_protocol"); Add_Name ("debugger_command"); Add_Name ("gnatlist"); Add_Name ("vcs_kind"); Add_Name ("vcs_file_check"); Add_Name ("vcs_log_check"); Add_Name ("documentation_dir"); Add_Name ("codepeer"); Add_Name ("output_directory"); Add_Name ("database_directory"); Add_Name ("message_patterns"); Add_Name ("additional_patterns"); Add_Name ("origin_project"); Add_Name ("library_reference_symbol_file"); Add_Name ("unconditional_linking"); Add_Name ("toolchain_path"); Add_Name ("config_prj_file"); Add_Name (""); Add_Name ("."); Add_Name ("*"); end Initialize; end GPR.Snames; gprbuild-25.0.0/gpr/src/gpr-snames.ads000066400000000000000000000640241470075373400175520ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2015-2022, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with GNAT.Source_Info; package GPR.Snames is function L return Positive renames GNAT.Source_Info.Line; -- Static line number -- Constant values in the following block are assigned automatically -- based on the line number of the constant. For this to work correctly, -- the block must be contiguous, without empty or comment lines until -- the "End of empty lines prohibition" comment. N : constant Name_Id := Name_Id (L) - First_Name_Id; -- No empty lines below Name_C : constant Name_Id := Name_Id (L) - N; Name_Abort : constant Name_Id := Name_Id (L) - N; Name_Abs : constant Name_Id := Name_Id (L) - N; Name_Accept : constant Name_Id := Name_Id (L) - N; Name_And : constant Name_Id := Name_Id (L) - N; Name_All : constant Name_Id := Name_Id (L) - N; Name_Array : constant Name_Id := Name_Id (L) - N; Name_At : constant Name_Id := Name_Id (L) - N; Name_Begin : constant Name_Id := Name_Id (L) - N; Name_Body : constant Name_Id := Name_Id (L) - N; Name_Case : constant Name_Id := Name_Id (L) - N; Name_Constant : constant Name_Id := Name_Id (L) - N; Name_Declare : constant Name_Id := Name_Id (L) - N; Name_Delay : constant Name_Id := Name_Id (L) - N; Name_Do : constant Name_Id := Name_Id (L) - N; Name_Else : constant Name_Id := Name_Id (L) - N; Name_Elsif : constant Name_Id := Name_Id (L) - N; Name_End : constant Name_Id := Name_Id (L) - N; Name_Entry : constant Name_Id := Name_Id (L) - N; Name_Exception : constant Name_Id := Name_Id (L) - N; Name_Exit : constant Name_Id := Name_Id (L) - N; Name_For : constant Name_Id := Name_Id (L) - N; Name_Function : constant Name_Id := Name_Id (L) - N; Name_Generic : constant Name_Id := Name_Id (L) - N; Name_Goto : constant Name_Id := Name_Id (L) - N; Name_If : constant Name_Id := Name_Id (L) - N; Name_In : constant Name_Id := Name_Id (L) - N; Name_Is : constant Name_Id := Name_Id (L) - N; Name_Limited : constant Name_Id := Name_Id (L) - N; Name_Loop : constant Name_Id := Name_Id (L) - N; Name_New : constant Name_Id := Name_Id (L) - N; Name_Not : constant Name_Id := Name_Id (L) - N; Name_Null : constant Name_Id := Name_Id (L) - N; Name_Of : constant Name_Id := Name_Id (L) - N; Name_Or : constant Name_Id := Name_Id (L) - N; Name_Others : constant Name_Id := Name_Id (L) - N; Name_Out : constant Name_Id := Name_Id (L) - N; Name_Package : constant Name_Id := Name_Id (L) - N; Name_Pragma : constant Name_Id := Name_Id (L) - N; Name_Private : constant Name_Id := Name_Id (L) - N; Name_Procedure : constant Name_Id := Name_Id (L) - N; Name_Raise : constant Name_Id := Name_Id (L) - N; Name_Record : constant Name_Id := Name_Id (L) - N; Name_Rem : constant Name_Id := Name_Id (L) - N; Name_Renames : constant Name_Id := Name_Id (L) - N; Name_Return : constant Name_Id := Name_Id (L) - N; Name_Reverse : constant Name_Id := Name_Id (L) - N; Name_Select : constant Name_Id := Name_Id (L) - N; Name_Separate : constant Name_Id := Name_Id (L) - N; Name_Subtype : constant Name_Id := Name_Id (L) - N; Name_Task : constant Name_Id := Name_Id (L) - N; Name_Terminate : constant Name_Id := Name_Id (L) - N; Name_Then : constant Name_Id := Name_Id (L) - N; Name_Type : constant Name_Id := Name_Id (L) - N; Name_Use : constant Name_Id := Name_Id (L) - N; Name_When : constant Name_Id := Name_Id (L) - N; Name_While : constant Name_Id := Name_Id (L) - N; Name_With : constant Name_Id := Name_Id (L) - N; Name_Xor : constant Name_Id := Name_Id (L) - N; Name_Access : constant Name_Id := Name_Id (L) - N; Name_Delta : constant Name_Id := Name_Id (L) - N; Name_Digits : constant Name_Id := Name_Id (L) - N; Name_Mod : constant Name_Id := Name_Id (L) - N; Name_Range : constant Name_Id := Name_Id (L) - N; Name_Abstract : constant Name_Id := Name_Id (L) - N; Name_Aliased : constant Name_Id := Name_Id (L) - N; Name_Protected : constant Name_Id := Name_Id (L) - N; Name_Until : constant Name_Id := Name_Id (L) - N; Name_Requeue : constant Name_Id := Name_Id (L) - N; Name_Tagged : constant Name_Id := Name_Id (L) - N; Name_Project : constant Name_Id := Name_Id (L) - N; Name_Extends : constant Name_Id := Name_Id (L) - N; Name_External : constant Name_Id := Name_Id (L) - N; Name_External_As_List : constant Name_Id := Name_Id (L) - N; Name_Interface : constant Name_Id := Name_Id (L) - N; Name_Overriding : constant Name_Id := Name_Id (L) - N; Name_Synchronized : constant Name_Id := Name_Id (L) - N; Name_Some : constant Name_Id := Name_Id (L) - N; Name_Active : constant Name_Id := Name_Id (L) - N; Name_Aggregate : constant Name_Id := Name_Id (L) - N; Name_Archive_Builder : constant Name_Id := Name_Id (L) - N; Name_Archive_Builder_Append_Option : constant Name_Id := Name_Id (L) - N; Name_Archive_Indexer : constant Name_Id := Name_Id (L) - N; Name_Archive_Suffix : constant Name_Id := Name_Id (L) - N; Name_Artifacts : constant Name_Id := Name_Id (L) - N; Name_Artifacts_In_Exec_Dir : constant Name_Id := Name_Id (L) - N; Name_Artifacts_In_Object_Dir : constant Name_Id := Name_Id (L) - N; Name_Binder : constant Name_Id := Name_Id (L) - N; Name_Bindfile_Option_Substitution : constant Name_Id := Name_Id (L) - N; Name_Body_Suffix : constant Name_Id := Name_Id (L) - N; Name_Builder : constant Name_Id := Name_Id (L) - N; Name_Clean : constant Name_Id := Name_Id (L) - N; Name_Compiler : constant Name_Id := Name_Id (L) - N; Name_Compiler_Command : constant Name_Id := Name_Id (L) - N; Name_Config_Body_File_Name : constant Name_Id := Name_Id (L) - N; Name_Config_Body_File_Name_Index : constant Name_Id := Name_Id (L) - N; Name_Config_Body_File_Name_Pattern : constant Name_Id := Name_Id (L) - N; Name_Config_File_Dependency_Support : constant Name_Id := Name_Id (L) - N; Name_Config_File_Switches : constant Name_Id := Name_Id (L) - N; Name_Config_File_Unique : constant Name_Id := Name_Id (L) - N; Name_Config_Spec_File_Name : constant Name_Id := Name_Id (L) - N; Name_Config_Spec_File_Name_Index : constant Name_Id := Name_Id (L) - N; Name_Config_Spec_File_Name_Pattern : constant Name_Id := Name_Id (L) - N; Name_Configuration : constant Name_Id := Name_Id (L) - N; Name_Cross_Reference : constant Name_Id := Name_Id (L) - N; Name_Def : constant Name_Id := Name_Id (L) - N; Name_Default_Language : constant Name_Id := Name_Id (L) - N; Name_Default_Switches : constant Name_Id := Name_Id (L) - N; Name_Dependency_Driver : constant Name_Id := Name_Id (L) - N; Name_Dependency_Kind : constant Name_Id := Name_Id (L) - N; Name_Dependency_Switches : constant Name_Id := Name_Id (L) - N; Name_Driver : constant Name_Id := Name_Id (L) - N; Name_Excluded_Source_Dirs : constant Name_Id := Name_Id (L) - N; Name_Excluded_Source_Files : constant Name_Id := Name_Id (L) - N; Name_Excluded_Source_List_File : constant Name_Id := Name_Id (L) - N; Name_Exec_Dir : constant Name_Id := Name_Id (L) - N; Name_Exec_Subdir : constant Name_Id := Name_Id (L) - N; Name_Excluded_Patterns : constant Name_Id := Name_Id (L) - N; Name_Executable : constant Name_Id := Name_Id (L) - N; Name_Executable_Suffix : constant Name_Id := Name_Id (L) - N; Name_Externally_Built : constant Name_Id := Name_Id (L) - N; Name_Finder : constant Name_Id := Name_Id (L) - N; Name_Flat : constant Name_Id := Name_Id (L) - N; Name_Gcc : constant Name_Id := Name_Id (L) - N; Name_Gcc_Gnu : constant Name_Id := Name_Id (L) - N; Name_Gcc_Option_List : constant Name_Id := Name_Id (L) - N; Name_Gcc_Object_List : constant Name_Id := Name_Id (L) - N; Name_Global_Compilation_Switches : constant Name_Id := Name_Id (L) - N; Name_Global_Configuration_Pragmas : constant Name_Id := Name_Id (L) - N; Name_Global_Config_File : constant Name_Id := Name_Id (L) - N; Name_Gnatls : constant Name_Id := Name_Id (L) - N; Name_Gnatstub : constant Name_Id := Name_Id (L) - N; Name_Gnu : constant Name_Id := Name_Id (L) - N; Name_Ide : constant Name_Id := Name_Id (L) - N; Name_Ignore_Source_Sub_Dirs : constant Name_Id := Name_Id (L) - N; Name_Implementation : constant Name_Id := Name_Id (L) - N; Name_Implementation_Exceptions : constant Name_Id := Name_Id (L) - N; Name_Implementation_Suffix : constant Name_Id := Name_Id (L) - N; Name_Included_Artifact_Patterns : constant Name_Id := Name_Id (L) - N; Name_Included_Patterns : constant Name_Id := Name_Id (L) - N; Name_Include_Switches : constant Name_Id := Name_Id (L) - N; Name_Include_Path : constant Name_Id := Name_Id (L) - N; Name_Include_Path_File : constant Name_Id := Name_Id (L) - N; Name_Inherit_Source_Path : constant Name_Id := Name_Id (L) - N; Name_Install : constant Name_Id := Name_Id (L) - N; Name_Install_Project : constant Name_Id := Name_Id (L) - N; Name_Languages : constant Name_Id := Name_Id (L) - N; Name_Language_Kind : constant Name_Id := Name_Id (L) - N; Name_Leading_Library_Options : constant Name_Id := Name_Id (L) - N; Name_Leading_Required_Switches : constant Name_Id := Name_Id (L) - N; Name_Leading_Switches : constant Name_Id := Name_Id (L) - N; Name_ALI_Subdir : constant Name_Id := Name_Id (L) - N; Name_Lib_Subdir : constant Name_Id := Name_Id (L) - N; Name_Link_Lib_Subdir : constant Name_Id := Name_Id (L) - N; Name_Library : constant Name_Id := Name_Id (L) - N; Name_Library_Ali_Dir : constant Name_Id := Name_Id (L) - N; Name_Library_Auto_Init : constant Name_Id := Name_Id (L) - N; Name_Library_Auto_Init_Supported : constant Name_Id := Name_Id (L) - N; Name_Library_Builder : constant Name_Id := Name_Id (L) - N; Name_Library_Dir : constant Name_Id := Name_Id (L) - N; Name_Library_GCC : constant Name_Id := Name_Id (L) - N; Name_Library_Install_Name_Option : constant Name_Id := Name_Id (L) - N; Name_Library_Interface : constant Name_Id := Name_Id (L) - N; Name_Library_Kind : constant Name_Id := Name_Id (L) - N; Name_Library_Name : constant Name_Id := Name_Id (L) - N; Name_Library_Major_Minor_Id_Supported : constant Name_Id := Name_Id (L) - N; Name_Library_Options : constant Name_Id := Name_Id (L) - N; Name_Library_Partial_Linker : constant Name_Id := Name_Id (L) - N; Name_Library_Rpath_Options : constant Name_Id := Name_Id (L) - N; Name_Library_Standalone : constant Name_Id := Name_Id (L) - N; Name_Library_Encapsulated_Options : constant Name_Id := Name_Id (L) - N; Name_Library_Encapsulated_Supported : constant Name_Id := Name_Id (L) - N; Name_Library_Src_Dir : constant Name_Id := Name_Id (L) - N; Name_Library_Support : constant Name_Id := Name_Id (L) - N; Name_Library_Symbol_File : constant Name_Id := Name_Id (L) - N; Name_Library_Symbol_Policy : constant Name_Id := Name_Id (L) - N; Name_Library_Version : constant Name_Id := Name_Id (L) - N; Name_Library_Version_Switches : constant Name_Id := Name_Id (L) - N; Name_Linker : constant Name_Id := Name_Id (L) - N; Name_Linker_Executable_Option : constant Name_Id := Name_Id (L) - N; Name_Linker_Lib_Dir_Option : constant Name_Id := Name_Id (L) - N; Name_Linker_Lib_Name_Option : constant Name_Id := Name_Id (L) - N; Name_Local_Config_File : constant Name_Id := Name_Id (L) - N; Name_Local_Configuration_Pragmas : constant Name_Id := Name_Id (L) - N; Name_Locally_Removed_Files : constant Name_Id := Name_Id (L) - N; Name_Map_File_Option : constant Name_Id := Name_Id (L) - N; Name_Mapping_File_Switches : constant Name_Id := Name_Id (L) - N; Name_Mapping_Spec_Suffix : constant Name_Id := Name_Id (L) - N; Name_Mapping_Body_Suffix : constant Name_Id := Name_Id (L) - N; Name_Max_Command_Line_Length : constant Name_Id := Name_Id (L) - N; Name_Metrics : constant Name_Id := Name_Id (L) - N; Name_Multi_Unit_Object_Separator : constant Name_Id := Name_Id (L) - N; Name_Multi_Unit_Switches : constant Name_Id := Name_Id (L) - N; Name_Naming : constant Name_Id := Name_Id (L) - N; Name_None : constant Name_Id := Name_Id (L) - N; Name_Object_Artifact_Extensions : constant Name_Id := Name_Id (L) - N; Name_Object_File_Suffix : constant Name_Id := Name_Id (L) - N; Name_Object_File_Switches : constant Name_Id := Name_Id (L) - N; Name_Object_Generated : constant Name_Id := Name_Id (L) - N; Name_Object_List : constant Name_Id := Name_Id (L) - N; Name_Object_Path_Switches : constant Name_Id := Name_Id (L) - N; Name_Objects_Linked : constant Name_Id := Name_Id (L) - N; Name_Objects_Path : constant Name_Id := Name_Id (L) - N; Name_Objects_Path_File : constant Name_Id := Name_Id (L) - N; Name_Object_Dir : constant Name_Id := Name_Id (L) - N; Name_Option_List : constant Name_Id := Name_Id (L) - N; Name_Pic_Option : constant Name_Id := Name_Id (L) - N; Name_Pretty_Printer : constant Name_Id := Name_Id (L) - N; Name_Prefix : constant Name_Id := Name_Id (L) - N; Name_Project_Dir : constant Name_Id := Name_Id (L) - N; Name_Project_Files : constant Name_Id := Name_Id (L) - N; Name_Project_Path : constant Name_Id := Name_Id (L) - N; Name_Project_Subdir : constant Name_Id := Name_Id (L) - N; Name_Remote : constant Name_Id := Name_Id (L) - N; Name_Response_File_Format : constant Name_Id := Name_Id (L) - N; Name_Response_File_Switches : constant Name_Id := Name_Id (L) - N; Name_Root_Dir : constant Name_Id := Name_Id (L) - N; Name_Roots : constant Name_Id := Name_Id (L) - N; Name_Required_Artifacts : constant Name_Id := Name_Id (L) - N; Name_Required_Switches : constant Name_Id := Name_Id (L) - N; Name_Run_Path_Option : constant Name_Id := Name_Id (L) - N; Name_Run_Path_Origin : constant Name_Id := Name_Id (L) - N; Name_Separate_Run_Path_Options : constant Name_Id := Name_Id (L) - N; Name_Shared_Library_Minimum_Switches : constant Name_Id := Name_Id (L) - N; Name_Shared_Library_Prefix : constant Name_Id := Name_Id (L) - N; Name_Shared_Library_Suffix : constant Name_Id := Name_Id (L) - N; Name_Separate_Suffix : constant Name_Id := Name_Id (L) - N; Name_Side_Debug : constant Name_Id := Name_Id (L) - N; Name_Source_Artifact_Extensions : constant Name_Id := Name_Id (L) - N; Name_Source_Dirs : constant Name_Id := Name_Id (L) - N; Name_Source_File_Switches : constant Name_Id := Name_Id (L) - N; Name_Source_Files : constant Name_Id := Name_Id (L) - N; Name_Source_List_File : constant Name_Id := Name_Id (L) - N; Name_Sources_Subdir : constant Name_Id := Name_Id (L) - N; Name_Spec : constant Name_Id := Name_Id (L) - N; Name_Spec_Suffix : constant Name_Id := Name_Id (L) - N; Name_Specification : constant Name_Id := Name_Id (L) - N; Name_Specification_Exceptions : constant Name_Id := Name_Id (L) - N; Name_Specification_Suffix : constant Name_Id := Name_Id (L) - N; Name_Stack : constant Name_Id := Name_Id (L) - N; Name_Switches : constant Name_Id := Name_Id (L) - N; Name_Symbolic_Link_Supported : constant Name_Id := Name_Id (L) - N; Name_Toolchain_Description : constant Name_Id := Name_Id (L) - N; Name_Toolchain_Version : constant Name_Id := Name_Id (L) - N; Name_Trailing_Required_Switches : constant Name_Id := Name_Id (L) - N; Name_Trailing_Switches : constant Name_Id := Name_Id (L) - N; Name_Runtime_Library_Dir : constant Name_Id := Name_Id (L) - N; Name_Runtime_Library_Dirs : constant Name_Id := Name_Id (L) - N; Name_Runtime_Source_Dir : constant Name_Id := Name_Id (L) - N; Name_Ada : constant Name_Id := Name_Id (L) - N; Name_Interfaces : constant Name_Id := Name_Id (L) - N; Name_Main : constant Name_Id := Name_Id (L) - N; Name_Target : constant Name_Id := Name_Id (L) - N; Name_Casing : constant Name_Id := Name_Id (L) - N; Name_Dot_Replacement : constant Name_Id := Name_Id (L) - N; Name_Standard : constant Name_Id := Name_Id (L) - N; Name_Name : constant Name_Id := Name_Id (L) - N; Name_Linker_Options : constant Name_Id := Name_Id (L) - N; Name_Runtime : constant Name_Id := Name_Id (L) - N; Name_Mode : constant Name_Id := Name_Id (L) - N; Name_Install_Name : constant Name_Id := Name_Id (L) - N; Name_Object_Lister : constant Name_Id := Name_Id (L) - N; Name_Object_Lister_Matcher : constant Name_Id := Name_Id (L) - N; Name_Export_File_Format : constant Name_Id := Name_Id (L) - N; Name_Export_File_Switch : constant Name_Id := Name_Id (L) - N; Name_Runtime_Source_Dirs : constant Name_Id := Name_Id (L) - N; Name_Runtime_Dir : constant Name_Id := Name_Id (L) - N; Name_Runtime_Library_Version : constant Name_Id := Name_Id (L) - N; Name_Split : constant Name_Id := Name_Id (L) - N; Name_Create_Missing_Dirs : constant Name_Id := Name_Id (L) - N; Name_Canonical_Target : constant Name_Id := Name_Id (L) - N; Name_Warning_Message : constant Name_Id := Name_Id (L) - N; Name_Only_Dirs_With_Sources : constant Name_Id := Name_Id (L) - N; Name_Include_Switches_Via_Spec : constant Name_Id := Name_Id (L) - N; Name_Required_Toolchain_Version : constant Name_Id := Name_Id (L) - N; Name_Toolchain_Name : constant Name_Id := Name_Id (L) - N; Name_Check : constant Name_Id := Name_Id (L) - N; Name_Eliminate : constant Name_Id := Name_Id (L) - N; Name_Remote_Host : constant Name_Id := Name_Id (L) - N; Name_Program_Host : constant Name_Id := Name_Id (L) - N; Name_Communication_Protocol : constant Name_Id := Name_Id (L) - N; Name_Debugger_Command : constant Name_Id := Name_Id (L) - N; Name_Gnatlist : constant Name_Id := Name_Id (L) - N; Name_Vcs_Kind : constant Name_Id := Name_Id (L) - N; Name_Vcs_File_Check : constant Name_Id := Name_Id (L) - N; Name_Vcs_Log_Check : constant Name_Id := Name_Id (L) - N; Name_Documentation_Dir : constant Name_Id := Name_Id (L) - N; Name_Codepeer : constant Name_Id := Name_Id (L) - N; Name_Output_Directory : constant Name_Id := Name_Id (L) - N; Name_Database_Directory : constant Name_Id := Name_Id (L) - N; Name_Message_Patterns : constant Name_Id := Name_Id (L) - N; Name_Additional_Patterns : constant Name_Id := Name_Id (L) - N; Name_Origin_Project : constant Name_Id := Name_Id (L) - N; Name_Library_Reference_Symbol_File : constant Name_Id := Name_Id (L) - N; Name_Unconditional_Linking : constant Name_Id := Name_Id (L) - N; Name_Toolchain_Path : constant Name_Id := Name_Id (L) - N; Name_Config_Prj_File : constant Name_Id := Name_Id (L) - N; The_Empty_String : constant Name_Id := Name_Id (L) - N; The_Dot_String : constant Name_Id := Name_Id (L) - N; The_Star_String : constant Name_Id := Name_Id (L) - N; -- End of empty lines prohibition subtype Reserved_Ada_95 is Name_Id range Name_Abort .. Name_Tagged; subtype Reserved_Ada_Project is Name_Id range Name_Abort .. Name_External_As_List; subtype Reserved_Ada_Other is Name_Id range Name_Interface .. Name_Some; procedure Initialize; end GPR.Snames; gprbuild-25.0.0/gpr/src/gpr-strt.adb000066400000000000000000001665321470075373400172460ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2021, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Strings.Fixed; use Ada.Strings.Fixed; with GNAT.Table; with GPR.Attr; use GPR.Attr; with GPR.Err; use GPR.Err; with GPR.Erroutc; use GPR.Erroutc; with GPR.Names; use GPR.Names; with GPR.Scans; use GPR.Scans; with GPR.Snames; with GPR.Tree; use GPR.Tree; with GPR.Util; use GPR.Util; package body GPR.Strt is Buffer : String_Access; Buffer_Last : Natural := 0; type Choice_String is record The_String : Name_Id; Already_Used : Boolean := False; end record; -- The string of a case label, and an indication that it has already -- been used (to avoid duplicate case labels). Choices_Initial : constant := 10; Choices_Increment : constant := 100; -- These should be in alloc.ads Choice_Node_Low_Bound : constant := 0; Choice_Node_High_Bound : constant := 099_999_999; -- In practice, infinite type Choice_Node_Id is range Choice_Node_Low_Bound .. Choice_Node_High_Bound; First_Choice_Node_Id : constant Choice_Node_Id := Choice_Node_Low_Bound; package Choices is new GNAT.Table (Table_Component_Type => Choice_String, Table_Index_Type => Choice_Node_Id'Base, Table_Low_Bound => First_Choice_Node_Id, Table_Initial => Choices_Initial, Table_Increment => Choices_Increment); -- Used to store the case labels and check that there is no duplicate package Choice_Lasts is new GNAT.Table (Table_Component_Type => Choice_Node_Id, Table_Index_Type => Nat, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 100); -- Used to store the indexes of the choices in table Choices, to -- distinguish nested case constructions. Choice_First : Choice_Node_Id := 0; -- Index in table Choices of the first case label of the current -- case construction. Zero means no current case construction. type Name_Location is record Name : Name_Id := No_Name; Location : Source_Ptr := No_Location; end record; -- Store the identifier and the location of a simple name package Names is new GNAT.Table (Table_Component_Type => Name_Location, Table_Index_Type => Nat, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 100); -- Used to accumulate the single names of a name procedure Add (This_String : Name_Id); -- Add a string to the case label list, indicating that it has not -- yet been used. procedure Add_To_Names (NL : Name_Location); -- Add one single names to table Names procedure External_Reference (In_Tree : Project_Node_Tree_Ref; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; External_Value : out Project_Node_Id; Expr_Kind : in out Variable_Kind; Flags : Processing_Flags); -- Parse an external reference. Current token is "external" or -- "external_as_list". procedure Parse_Split (In_Tree : Project_Node_Tree_Ref; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; Split_Value : out Project_Node_Id; Flags : Processing_Flags); -- Parse built-in function Split (, ) procedure Attribute_Reference (In_Tree : Project_Node_Tree_Ref; Reference : out Project_Node_Id; First_Attribute : Attribute_Node_Id; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; Flags : Processing_Flags); -- Parse an attribute reference. Current token is an apostrophe procedure Terms (In_Tree : Project_Node_Tree_Ref; Term : out Project_Node_Id; Expr_Kind : in out Variable_Kind; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; Optional_Index : Boolean; Flags : Processing_Flags); -- Recursive procedure to parse one term or several terms concatenated -- using "&". --------- -- Add -- --------- procedure Add (This_String : Name_Id) is begin Choices.Increment_Last; Choices.Table (Choices.Last) := (The_String => This_String, Already_Used => False); end Add; ------------------ -- Add_To_Names -- ------------------ procedure Add_To_Names (NL : Name_Location) is begin Names.Increment_Last; Names.Table (Names.Last) := NL; end Add_To_Names; ------------------------- -- Attribute_Reference -- ------------------------- procedure Attribute_Reference (In_Tree : Project_Node_Tree_Ref; Reference : out Project_Node_Id; First_Attribute : Attribute_Node_Id; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; Flags : Processing_Flags) is Current_Attribute : Attribute_Node_Id := First_Attribute; begin -- Declare the node of the attribute reference Reference := Default_Project_Node (Of_Kind => N_Attribute_Reference, In_Tree => In_Tree); Set_Location_Of (Reference, In_Tree, To => Token_Ptr); Scan (In_Tree); -- past apostrophe -- Body may be an attribute name if Token = Tok_Body then Token := Tok_Identifier; Token_Name := Snames.Name_Body; end if; Expect (Tok_Identifier, "identifier"); if Token = Tok_Identifier then Set_Name_Of (Reference, In_Tree, To => Token_Name); -- Check if the identifier is one of the attribute identifiers in the -- context (package or project level attributes). Current_Attribute := Attribute_Node_Id_Of (Token_Name, Starting_At => First_Attribute); -- If the identifier is not allowed, report an error if Current_Attribute = Empty_Attribute then if No (Current_Package) or else Is_Package_Known (Package_Id_Of (Current_Package, In_Tree)) then Error_Msg_Name_1 := Token_Name; Error_Msg (Flags, "unknown attribute %%", Token_Ptr); end if; Reference := Empty_Project_Node; -- Scan past the attribute name Scan (In_Tree); -- Skip a possible index for an associative array if Token = Tok_Left_Paren then Scan (In_Tree); if Token = Tok_String_Literal then Scan (In_Tree); if Token = Tok_Right_Paren then Scan (In_Tree); end if; end if; end if; else -- Give its characteristics to this attribute reference Set_Project_Node_Of (Reference, In_Tree, To => Current_Project); Set_Package_Node_Of (Reference, In_Tree, To => Current_Package); Set_Expression_Kind_Of (Reference, In_Tree, To => Variable_Kind_Of (Current_Attribute)); Set_Case_Insensitive (Reference, In_Tree, To => Attribute_Kind_Of (Current_Attribute) in All_Case_Insensitive_Associative_Array); Set_Default_Of (Reference, In_Tree, To => Attribute_Default_Of (Current_Attribute)); Set_Is_Config_Concatenable (Reference, In_Tree, To => Is_Config_Concatenable (Current_Attribute)); -- Scan past the attribute name Scan (In_Tree); -- If the attribute is an associative array, get the index if Attribute_Kind_Of (Current_Attribute) /= Single then Expect (Tok_Left_Paren, "`(`"); if Token = Tok_Left_Paren then Scan (In_Tree); if Others_Allowed_For (Current_Attribute) and then Token = Tok_Others then Set_Associative_Array_Index_Of (Reference, In_Tree, To => All_Other_Names); Scan (In_Tree); else if Others_Allowed_For (Current_Attribute) then Expect (Tok_String_Literal, "literal string or others"); else Expect (Tok_String_Literal, "literal string"); end if; if Token = Tok_String_Literal then Set_Associative_Array_Index_Of (Reference, In_Tree, To => Token_Name); -- Check if index contains a dot. If it does not, -- then it is probably a language name, so set it to -- case-insenstitve. if Index (Source => Get_Name_String (Token_Name), Pattern => ".") = 0 then Set_Case_Insensitive (Reference, In_Tree, To => True); end if; Scan (In_Tree); end if; end if; end if; Expect (Tok_Right_Paren, "`)`"); if Token = Tok_Right_Paren then Scan (In_Tree); end if; end if; end if; -- Change name of obsolete attributes if Present (Reference) then declare Name : constant Name_Id := Name_Of (Reference, In_Tree); begin if Name = Snames.Name_Specification then Set_Name_Of (Reference, In_Tree, To => Snames.Name_Spec); elsif Name = Snames.Name_Specification_Suffix then Set_Name_Of (Reference, In_Tree, To => Snames.Name_Spec_Suffix); elsif Name = Snames.Name_Implementation then Set_Name_Of (Reference, In_Tree, To => Snames.Name_Body); elsif Name = Snames.Name_Implementation_Suffix then Set_Name_Of (Reference, In_Tree, To => Snames.Name_Body_Suffix); end if; end; end if; end if; end Attribute_Reference; --------------------------- -- End_Case_Construction -- --------------------------- procedure End_Case_Construction (Check_All_Labels : Boolean; Case_Location : Source_Ptr; Flags : Processing_Flags; String_Type : Boolean) is Non_Used : Natural := 0; First_Non_Used : Choice_Node_Id := First_Choice_Node_Id; begin -- First, if Check_All_Labels is True, check if all values of the string -- type have been used. if Check_All_Labels then if String_Type then for Choice in Choice_First .. Choices.Last loop if not Choices.Table (Choice).Already_Used then Non_Used := Non_Used + 1; if Non_Used = 1 then First_Non_Used := Choice; end if; end if; end loop; -- If only one is not used, report a single warning for this value if Non_Used = 1 then Error_Msg_Name_1 := Choices.Table (First_Non_Used).The_String; Error_Msg (Flags, "?value %% is not used as label", Case_Location); -- If several are not used, report a warning for each one of them elsif Non_Used > 1 then Error_Msg (Flags, "?the following values are not used as labels:", Case_Location); for Choice in First_Non_Used .. Choices.Last loop if not Choices.Table (Choice).Already_Used then Error_Msg_Name_1 := Choices.Table (Choice).The_String; Error_Msg (Flags, "\?%%", Case_Location); end if; end loop; end if; else Error_Msg (Flags, "?no when others for this case construction", Case_Location); end if; end if; -- If this is the only case construction, empty the tables if Choice_Lasts.Last = 1 then Choice_Lasts.Set_Last (0); Choices.Set_Last (First_Choice_Node_Id); Choice_First := 0; -- Second case construction, set the tables to the first elsif Choice_Lasts.Last = 2 then Choice_Lasts.Set_Last (1); Choices.Set_Last (Choice_Lasts.Table (1)); Choice_First := 1; -- Third or more case construction, set the tables to the previous one else Choice_Lasts.Decrement_Last; Choices.Set_Last (Choice_Lasts.Table (Choice_Lasts.Last)); Choice_First := Choice_Lasts.Table (Choice_Lasts.Last - 1) + 1; end if; end End_Case_Construction; ------------------------ -- External_Reference -- ------------------------ procedure External_Reference (In_Tree : Project_Node_Tree_Ref; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; External_Value : out Project_Node_Id; Expr_Kind : in out Variable_Kind; Flags : Processing_Flags) is Field_Id : Project_Node_Id := Empty_Project_Node; Ext_List : Boolean := False; begin External_Value := Default_Project_Node (Of_Kind => N_External_Value, In_Tree => In_Tree); Set_Location_Of (External_Value, In_Tree, To => Token_Ptr); -- The current token is either external or external_as_list Ext_List := Token = Tok_External_As_List; Scan (In_Tree); if Ext_List then Set_Expression_Kind_Of (External_Value, In_Tree, To => List); else Set_Expression_Kind_Of (External_Value, In_Tree, To => Single); end if; if Expr_Kind = Undefined then if Ext_List then Expr_Kind := List; else Expr_Kind := Single; end if; end if; Expect (Tok_Left_Paren, "`(`"); -- Scan past the left parenthesis if Token = Tok_Left_Paren then Scan (In_Tree); end if; -- Get the name of the external reference Expect (Tok_String_Literal, "literal string"); if Token = Tok_String_Literal then Field_Id := Default_Project_Node (Of_Kind => N_Literal_String, In_Tree => In_Tree, And_Expr_Kind => Single); Set_String_Value_Of (Field_Id, In_Tree, To => Token_Name); Set_External_Reference_Of (External_Value, In_Tree, To => Field_Id); -- Scan past the first argument Scan (In_Tree); case Token is when Tok_Right_Paren => if Ext_List then Error_Msg (Flags, "`,` expected", Token_Ptr); end if; Scan (In_Tree); -- scan past right paren when Tok_Comma => Scan (In_Tree); -- scan past comma -- Get the string expression for the default declare Loc : constant Source_Ptr := Token_Ptr; begin Parse_Expression (In_Tree => In_Tree, Expression => Field_Id, Flags => Flags, Current_Project => Current_Project, Current_Package => Current_Package, Optional_Index => False); if Expression_Kind_Of (Field_Id, In_Tree) = List then Error_Msg (Flags, "expression must be a single string", Loc); else Set_External_Default_Of (External_Value, In_Tree, To => Field_Id); end if; end; Expect (Tok_Right_Paren, "`)`"); if Token = Tok_Right_Paren then Scan (In_Tree); -- scan past right paren end if; when others => if Ext_List then Error_Msg (Flags, "`,` expected", Token_Ptr); else Error_Msg (Flags, "`,` or `)` expected", Token_Ptr); end if; end case; end if; end External_Reference; ----------------------- -- Parse_Choice_List -- ----------------------- procedure Parse_Choice_List (In_Tree : Project_Node_Tree_Ref; First_Choice : out Project_Node_Id; Flags : Processing_Flags; String_Type : Boolean := True) is Current_Choice : Project_Node_Id := Empty_Project_Node; Next_Choice : Project_Node_Id := Empty_Project_Node; Choice_String : Name_Id := No_Name; Found : Boolean := False; begin -- Declare the node of the first choice First_Choice := Default_Project_Node (Of_Kind => N_Literal_String, In_Tree => In_Tree, And_Expr_Kind => Single); -- Initially Current_Choice is the same as First_Choice Current_Choice := First_Choice; loop Expect (Tok_String_Literal, "literal string"); exit when Token /= Tok_String_Literal; Set_Location_Of (Current_Choice, In_Tree, To => Token_Ptr); Choice_String := Token_Name; -- Give the string value to the current choice Set_String_Value_Of (Current_Choice, In_Tree, To => Choice_String); if String_Type then -- Check if the label is part of the string type and if it has not -- been already used. Found := False; for Choice in Choice_First .. Choices.Last loop if Choices.Table (Choice).The_String = Choice_String then -- This label is part of the string type Found := True; if Choices.Table (Choice).Already_Used then -- But it has already appeared in a choice list for this -- case construction so report an error. Error_Msg_Name_1 := Choice_String; Error_Msg (Flags, "duplicate case label %%", Token_Ptr); else Choices.Table (Choice).Already_Used := True; end if; exit; end if; end loop; -- If the label is not part of the string list, report an error if not Found then Error_Msg_Name_1 := Choice_String; Error_Msg (Flags, "illegal case label %%", Token_Ptr); end if; end if; -- Scan past the label Scan (In_Tree); -- If there is no '|', we are done if Token = Tok_Vertical_Bar then -- Otherwise, declare the node of the next choice, link it to -- Current_Choice and set Current_Choice to this new node. Next_Choice := Default_Project_Node (Of_Kind => N_Literal_String, In_Tree => In_Tree, And_Expr_Kind => Single); Set_Next_Literal_String (Current_Choice, In_Tree, To => Next_Choice); Current_Choice := Next_Choice; Scan (In_Tree); else exit; end if; end loop; end Parse_Choice_List; ---------------------- -- Parse_Expression -- ---------------------- procedure Parse_Expression (In_Tree : Project_Node_Tree_Ref; Expression : out Project_Node_Id; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; Optional_Index : Boolean; Flags : Processing_Flags) is First_Term : Project_Node_Id := Empty_Project_Node; Expression_Kind : Variable_Kind := Undefined; begin -- Declare the node of the expression Expression := Default_Project_Node (Of_Kind => N_Expression, In_Tree => In_Tree); Set_Location_Of (Expression, In_Tree, To => Token_Ptr); -- Parse the term or terms of the expression Terms (In_Tree => In_Tree, Term => First_Term, Expr_Kind => Expression_Kind, Flags => Flags, Current_Project => Current_Project, Current_Package => Current_Package, Optional_Index => Optional_Index); -- Set the first term and the expression kind Set_First_Term (Expression, In_Tree, To => First_Term); Set_Expression_Kind_Of (Expression, In_Tree, To => Expression_Kind); end Parse_Expression; ----------------- -- Parse_Split -- ----------------- procedure Parse_Split (In_Tree : Project_Node_Tree_Ref; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; Split_Value : out Project_Node_Id; Flags : Processing_Flags) is String_Argument : Project_Node_Id; Separator : Project_Node_Id; begin Split_Value := Default_Project_Node (Of_Kind => N_Split, In_Tree => In_Tree, And_Expr_Kind => List); Set_Location_Of (Split_Value, In_Tree, To => Token_Ptr); Scan (In_Tree); Expect (Tok_Left_Paren, "`(`"); -- Scan past the left parenthesis if Token = Tok_Left_Paren then Scan (In_Tree); end if; Parse_Expression (In_Tree => In_Tree, Expression => String_Argument, Current_Project => Current_Project, Current_Package => Current_Package, Optional_Index => False, Flags => Flags); Expect (Tok_Comma, "`,`"); if Token = Tok_Comma then Scan (In_Tree); end if; Parse_Expression (In_Tree => In_Tree, Expression => Separator, Current_Project => Current_Project, Current_Package => Current_Package, Optional_Index => False, Flags => Flags); Expect (Tok_Right_Paren, "')'"); if Token = Tok_Right_Paren then Scan (In_Tree); end if; Set_String_Argument_Of (Split_Value, In_Tree, To => String_Argument); Set_Separator_Of (Split_Value, In_Tree, To => Separator); end Parse_Split; ---------------------------- -- Parse_String_Type_List -- ---------------------------- procedure Parse_String_Type_List (In_Tree : Project_Node_Tree_Ref; First_String : out Project_Node_Id; Flags : Processing_Flags) is Last_String : Project_Node_Id := Empty_Project_Node; Next_String : Project_Node_Id := Empty_Project_Node; String_Value : Name_Id := No_Name; begin -- Declare the node of the first string First_String := Default_Project_Node (Of_Kind => N_Literal_String, In_Tree => In_Tree, And_Expr_Kind => Single); -- Initially, Last_String is the same as First_String Last_String := First_String; loop Expect (Tok_String_Literal, "literal string"); exit when Token /= Tok_String_Literal; String_Value := Token_Name; -- Give its string value to Last_String Set_String_Value_Of (Last_String, In_Tree, To => String_Value); Set_Location_Of (Last_String, In_Tree, To => Token_Ptr); -- Now, check if the string is already part of the string type declare Current : Project_Node_Id := First_String; begin while Current /= Last_String loop if String_Value_Of (Current, In_Tree) = String_Value then -- This is a repetition, report an error Error_Msg_Name_1 := String_Value; Error_Msg (Flags, "duplicate value %% in type", Token_Ptr); exit; end if; Current := Next_Literal_String (Current, In_Tree); end loop; end; -- Scan past the literal string Scan (In_Tree); -- If there is no comma following the literal string, we are done if Token /= Tok_Comma then exit; else -- Declare the next string, link it to Last_String and set -- Last_String to its node. Next_String := Default_Project_Node (Of_Kind => N_Literal_String, In_Tree => In_Tree, And_Expr_Kind => Single); Set_Next_Literal_String (Last_String, In_Tree, To => Next_String); Last_String := Next_String; Scan (In_Tree); end if; end loop; end Parse_String_Type_List; ------------------------------ -- Parse_Variable_Reference -- ------------------------------ procedure Parse_Variable_Reference (In_Tree : Project_Node_Tree_Ref; Variable : out Project_Node_Id; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; Flags : Processing_Flags; Allow_Attribute : Boolean := True) is Current_Variable : Project_Node_Id := Empty_Project_Node; The_Package : Project_Node_Id := Current_Package; The_Project : Project_Node_Id := Current_Project; Specified_Project : Project_Node_Id := Empty_Project_Node; Specified_Package : Project_Node_Id := Empty_Project_Node; Look_For_Variable : Boolean := True; First_Attribute : Attribute_Node_Id := Empty_Attribute; Variable_Name : Name_Id; begin Variable := Empty_Project_Node; Names.Init; loop Expect (Tok_Identifier, "identifier"); if Token /= Tok_Identifier then Look_For_Variable := False; exit; end if; Add_To_Names (NL => (Name => Token_Name, Location => Token_Ptr)); Scan (In_Tree); exit when Token /= Tok_Dot; Scan (In_Tree); end loop; if Look_For_Variable then if Token = Tok_Apostrophe then if not Allow_Attribute then Error_Msg (Flags, "attribute reference not allowed here", Names.Table (1).Location); end if; -- Attribute reference case Names.Last is when 0 => -- Cannot happen null; when 1 => -- This may be a project name or a package name. -- Project name have precedence. -- First, look if it can be a package name First_Attribute := First_Attribute_Of (Package_Node_Id_Of (Names.Table (1).Name)); -- Now, look if it can be a project name if Names.Table (1).Name = Name_Of (Current_Project, In_Tree) then The_Project := Current_Project; else The_Project := Imported_Or_Extended_Project_Of (Current_Project, In_Tree, Names.Table (1).Name); end if; if No (The_Project) then -- If it is neither a project name nor a package name, -- report an error. if First_Attribute = Empty_Attribute then Error_Msg_Name_1 := Names.Table (1).Name; Error_Msg (Flags, "unknown project %", Names.Table (1).Location); First_Attribute := Attribute_First; else -- If it is a package name, check if the package has -- already been declared in the current project. The_Package := First_Package_Of (Current_Project, In_Tree); while Present (The_Package) and then Name_Of (The_Package, In_Tree) /= Names.Table (1).Name loop The_Package := Next_Package_In_Project (The_Package, In_Tree); end loop; -- If it has not been already declared, report an -- error. if No (The_Package) then Error_Msg_Name_1 := Names.Table (1).Name; Error_Msg (Flags, "package % not yet defined", Names.Table (1).Location); end if; end if; else -- It is a project name First_Attribute := Attribute_First; The_Package := Empty_Project_Node; end if; when others => -- We have either a project name made of several simple -- names (long project), or a project name (short project) -- followed by a package name. The long project name has -- precedence. declare Short_Project : Name_Id; Long_Project : Name_Id; begin -- Clear the Buffer Buffer_Last := 0; -- Get the name of the short project for Index in 1 .. Names.Last - 1 loop Add_To_Buffer (Get_Name_String (Names.Table (Index).Name), Buffer, Buffer_Last); if Index /= Names.Last - 1 then Add_To_Buffer (".", Buffer, Buffer_Last); end if; end loop; Name_Len := Buffer_Last; Name_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last); Short_Project := Name_Find; -- Now, add the last simple name to get the name of the -- long project. Add_To_Buffer (".", Buffer, Buffer_Last); Add_To_Buffer (Get_Name_String (Names.Table (Names.Last).Name), Buffer, Buffer_Last); Name_Len := Buffer_Last; Name_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last); Long_Project := Name_Find; -- Check if the long project is imported or extended if Long_Project = Name_Of (Current_Project, In_Tree) then The_Project := Current_Project; else The_Project := Imported_Or_Extended_Project_Of (Current_Project, In_Tree, Long_Project); end if; -- If the long project exists, then this is the prefix -- of the attribute. if Present (The_Project) then First_Attribute := Attribute_First; The_Package := Empty_Project_Node; else -- Otherwise, check if the short project is imported -- or extended. if Short_Project = Name_Of (Current_Project, In_Tree) then The_Project := Current_Project; else The_Project := Imported_Or_Extended_Project_Of (Current_Project, In_Tree, Short_Project); end if; -- If short project does not exist, report an error if No (The_Project) then Error_Msg_Name_1 := Long_Project; Error_Msg_Name_2 := Short_Project; Error_Msg (Flags, "unknown projects % or %", Names.Table (1).Location); The_Package := Empty_Project_Node; First_Attribute := Attribute_First; else -- Now, we check if the package has been declared -- in this project. The_Package := First_Package_Of (The_Project, In_Tree); while Present (The_Package) and then Name_Of (The_Package, In_Tree) /= Names.Table (Names.Last).Name loop The_Package := Next_Package_In_Project (The_Package, In_Tree); end loop; -- If it has not, then we report an error if No (The_Package) then Error_Msg_Name_1 := Names.Table (Names.Last).Name; Error_Msg_Name_2 := Short_Project; Error_Msg (Flags, "package % not declared in project %", Names.Table (Names.Last).Location); First_Attribute := Attribute_First; else -- Otherwise, we have the correct project and -- package. First_Attribute := First_Attribute_Of (Package_Id_Of (The_Package, In_Tree)); end if; end if; end if; end; end case; Attribute_Reference (In_Tree, Variable, Flags => Flags, Current_Project => The_Project, Current_Package => The_Package, First_Attribute => First_Attribute); return; end if; end if; Variable := Default_Project_Node (Of_Kind => N_Variable_Reference, In_Tree => In_Tree); if Look_For_Variable then case Names.Last is when 0 => -- Cannot happen (so why null instead of raise PE???) null; when 1 => -- Simple variable name Set_Name_Of (Variable, In_Tree, To => Names.Table (1).Name); when 2 => -- Variable name with a simple name prefix that can be -- a project name or a package name. Project names have -- priority over package names. Set_Name_Of (Variable, In_Tree, To => Names.Table (2).Name); -- Check if it can be a package name The_Package := First_Package_Of (Current_Project, In_Tree); while Present (The_Package) and then Name_Of (The_Package, In_Tree) /= Names.Table (1).Name loop The_Package := Next_Package_In_Project (The_Package, In_Tree); end loop; -- Now look for a possible project name The_Project := Imported_Or_Extended_Project_Of (Current_Project, In_Tree, Names.Table (1).Name); if Present (The_Project) then Specified_Project := The_Project; elsif No (The_Package) then Error_Msg_Name_1 := Names.Table (1).Name; Error_Msg (Flags, "unknown package or project %", Names.Table (1).Location); Look_For_Variable := False; else Specified_Package := The_Package; end if; when others => -- Variable name with a prefix that is either a project name -- made of several simple names, or a project name followed -- by a package name. Set_Name_Of (Variable, In_Tree, To => Names.Table (Names.Last).Name); declare Short_Project : Name_Id; Long_Project : Name_Id; begin -- First, we get the two possible project names -- Clear the buffer Buffer_Last := 0; -- Add all the simple names, except the last two for Index in 1 .. Names.Last - 2 loop Add_To_Buffer (Get_Name_String (Names.Table (Index).Name), Buffer, Buffer_Last); if Index /= Names.Last - 2 then Add_To_Buffer (".", Buffer, Buffer_Last); end if; end loop; Name_Len := Buffer_Last; Name_Buffer (1 .. Name_Len) := Buffer (1 .. Buffer_Last); Short_Project := Name_Find; -- Add the simple name before the name of the variable Add_To_Buffer (".", Buffer, Buffer_Last); Add_To_Buffer (Get_Name_String (Names.Table (Names.Last - 1).Name), Buffer, Buffer_Last); Name_Len := Buffer_Last; Name_Buffer (1 .. Name_Len) := Buffer (1 .. Buffer_Last); Long_Project := Name_Find; -- Check if the prefix is the name of an imported or -- extended project. The_Project := Imported_Or_Extended_Project_Of (Current_Project, In_Tree, Long_Project); if Present (The_Project) then Specified_Project := The_Project; else -- Now check if the prefix may be a project name followed -- by a package name. -- First check for a possible project name The_Project := Imported_Or_Extended_Project_Of (Current_Project, In_Tree, Short_Project); if No (The_Project) then -- Unknown prefix, report an error Error_Msg_Name_1 := Long_Project; Error_Msg_Name_2 := Short_Project; Error_Msg (Flags, "unknown projects % or %", Names.Table (1).Location); Look_For_Variable := False; else Specified_Project := The_Project; -- Now look for the package in this project The_Package := First_Package_Of (The_Project, In_Tree); while Present (The_Package) and then Name_Of (The_Package, In_Tree) /= Names.Table (Names.Last - 1).Name loop The_Package := Next_Package_In_Project (The_Package, In_Tree); end loop; if No (The_Package) then -- The package does not exist, report an error Error_Msg_Name_1 := Names.Table (2).Name; Error_Msg (Flags, "unknown package %", Names.Table (Names.Last - 1).Location); Look_For_Variable := False; else Specified_Package := The_Package; end if; end if; end if; end; end case; end if; if Look_For_Variable then Variable_Name := Name_Of (Variable, In_Tree); Set_Project_Node_Of (Variable, In_Tree, To => Specified_Project); Set_Package_Node_Of (Variable, In_Tree, To => Specified_Package); if Present (Specified_Project) then The_Project := Specified_Project; else The_Project := Current_Project; end if; Current_Variable := Empty_Project_Node; -- Look for this variable -- If a package was specified, check if the variable has been -- declared in this package. if Present (Specified_Package) then Current_Variable := First_Variable_Of (Specified_Package, In_Tree); while Present (Current_Variable) and then Name_Of (Current_Variable, In_Tree) /= Variable_Name loop Current_Variable := Next_Variable (Current_Variable, In_Tree); end loop; else -- Otherwise, if no project has been specified and we are in -- a package, first check if the variable has been declared in -- the package. if No (Specified_Project) and then Present (Current_Package) then Current_Variable := First_Variable_Of (Current_Package, In_Tree); while Present (Current_Variable) and then Name_Of (Current_Variable, In_Tree) /= Variable_Name loop Current_Variable := Next_Variable (Current_Variable, In_Tree); end loop; end if; -- If we have not found the variable in the package, check if the -- variable has been declared in the project, or in any of its -- ancestors, or in any of the project it extends. if No (Current_Variable) then declare Proj : Project_Node_Id := The_Project; begin loop Current_Variable := First_Variable_Of (Proj, In_Tree); while Present (Current_Variable) and then Name_Of (Current_Variable, In_Tree) /= Variable_Name loop Current_Variable := Next_Variable (Current_Variable, In_Tree); end loop; exit when Present (Current_Variable); -- If the current project is a child project, check if -- the variable is declared in its parent. Otherwise, if -- the current project extends another project, check if -- the variable is declared in one of the projects the -- current project extends. if No (Parent_Project_Of (Proj, In_Tree)) then Proj := Extended_Project_Of (Project_Declaration_Of (Proj, In_Tree), In_Tree); else Proj := Parent_Project_Of (Proj, In_Tree); end if; Set_Project_Node_Of (Variable, In_Tree, To => Proj); exit when No (Proj); end loop; end; end if; end if; -- If the variable was not found, report an error if No (Current_Variable) then Error_Msg_Name_1 := Variable_Name; Error_Msg (Flags, "unknown variable %", Names.Table (Names.Last).Location); end if; end if; if Present (Current_Variable) then Set_Expression_Kind_Of (Variable, In_Tree, To => Expression_Kind_Of (Current_Variable, In_Tree)); if Kind_Of (Current_Variable, In_Tree) = N_Typed_Variable_Declaration then Set_String_Type_Of (Variable, In_Tree, To => String_Type_Of (Current_Variable, In_Tree)); end if; end if; -- If the variable is followed by a left parenthesis, report an error -- but attempt to scan the index. if Token = Tok_Left_Paren then Error_Msg (Flags, "\variables cannot be associative arrays", Token_Ptr); Scan (In_Tree); Expect (Tok_String_Literal, "literal string"); if Token = Tok_String_Literal then Scan (In_Tree); Expect (Tok_Right_Paren, "`)`"); if Token = Tok_Right_Paren then Scan (In_Tree); end if; end if; end if; end Parse_Variable_Reference; --------------------------------- -- Start_New_Case_Construction -- --------------------------------- procedure Start_New_Case_Construction (In_Tree : Project_Node_Tree_Ref; String_Type : Project_Node_Id) is Current_String : Project_Node_Id; begin -- Set Choice_First, depending on whether this is the first case -- construction or not. if Choice_First = 0 then Choice_First := 1; Choices.Set_Last (First_Choice_Node_Id); else Choice_First := Choices.Last + 1; end if; -- Add the literal of the string type to the Choices table if Present (String_Type) then Current_String := First_Literal_String (String_Type, In_Tree); while Present (Current_String) loop Add (This_String => String_Value_Of (Current_String, In_Tree)); Current_String := Next_Literal_String (Current_String, In_Tree); end loop; end if; -- Set the value of the last choice in table Choice_Lasts Choice_Lasts.Increment_Last; Choice_Lasts.Table (Choice_Lasts.Last) := Choices.Last; end Start_New_Case_Construction; ----------- -- Terms -- ----------- procedure Terms (In_Tree : Project_Node_Tree_Ref; Term : out Project_Node_Id; Expr_Kind : in out Variable_Kind; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; Optional_Index : Boolean; Flags : Processing_Flags) is Next_Term : Project_Node_Id := Empty_Project_Node; Term_Id : Project_Node_Id := Empty_Project_Node; Current_Expression : Project_Node_Id := Empty_Project_Node; Next_Expression : Project_Node_Id := Empty_Project_Node; Current_Location : Source_Ptr := No_Location; Reference : Project_Node_Id := Empty_Project_Node; begin -- Declare a new node for the term Term := Default_Project_Node (Of_Kind => N_Term, In_Tree => In_Tree); Set_Location_Of (Term, In_Tree, To => Token_Ptr); case Token is when Tok_Left_Paren => -- If we have a left parenthesis and we don't know the expression -- kind, then this is a string list. case Expr_Kind is when Undefined => Expr_Kind := List; when List => null; when Single => -- If we already know that this is a single string, report -- an error, but set the expression kind to string list to -- avoid several errors. Expr_Kind := List; Error_Msg (Flags, "literal string list cannot appear in a string", Token_Ptr); end case; -- Declare a new node for this literal string list Term_Id := Default_Project_Node (Of_Kind => N_Literal_String_List, In_Tree => In_Tree, And_Expr_Kind => List); Set_Current_Term (Term, In_Tree, To => Term_Id); Set_Location_Of (Term, In_Tree, To => Token_Ptr); -- Scan past the left parenthesis Scan (In_Tree); -- If the left parenthesis is immediately followed by a right -- parenthesis, the literal string list is empty. if Token = Tok_Right_Paren then Scan (In_Tree); else -- Otherwise parse the expression(s) in the literal string list loop Current_Location := Token_Ptr; Parse_Expression (In_Tree => In_Tree, Expression => Next_Expression, Flags => Flags, Current_Project => Current_Project, Current_Package => Current_Package, Optional_Index => Optional_Index); -- The expression kind is String list, report an error if Expression_Kind_Of (Next_Expression, In_Tree) = List then Error_Msg (Flags, "single expression expected", Current_Location); end if; -- If Current_Expression is empty, it means that the -- expression is the first in the string list. if No (Current_Expression) then Set_First_Expression_In_List (Term_Id, In_Tree, To => Next_Expression); else Set_Next_Expression_In_List (Current_Expression, In_Tree, To => Next_Expression); end if; Current_Expression := Next_Expression; -- If there is a comma, continue with the next expression exit when Token /= Tok_Comma; Scan (In_Tree); -- past the comma end loop; -- We expect a closing right parenthesis Expect (Tok_Right_Paren, "`)`"); if Token = Tok_Right_Paren then Scan (In_Tree); end if; end if; when Tok_String_Literal => -- If we don't know the expression kind (first term), then it is -- a simple string. if Expr_Kind = Undefined then Expr_Kind := Single; end if; -- Declare a new node for the string literal Term_Id := Default_Project_Node (Of_Kind => N_Literal_String, In_Tree => In_Tree); Set_Current_Term (Term, In_Tree, To => Term_Id); Set_String_Value_Of (Term_Id, In_Tree, To => Token_Name); -- Scan past the string literal Scan (In_Tree); -- Check for possible index expression if Token = Tok_At then if not Optional_Index then Error_Msg (Flags, "index not allowed here", Token_Ptr); Scan (In_Tree); if Token = Tok_Integer_Literal then Scan (In_Tree); end if; -- Set the index value else Scan (In_Tree); Expect (Tok_Integer_Literal, "integer literal"); if Token = Tok_Integer_Literal then declare Index : constant Int := Int_Literal_Value; begin if Index = 0 then Error_Msg (Flags, "index cannot be zero", Token_Ptr); else Set_Source_Index_Of (Term_Id, In_Tree, To => Index); end if; end; Scan (In_Tree); end if; end if; end if; when Tok_Identifier => Current_Location := Token_Ptr; -- Check if it is a built-in function declare Builtin : Boolean := False; Saved_State : Saved_Scan_State; begin Save_Scan_State (Saved_State); Scan (In_Tree); Builtin := Token = Tok_Left_Paren; Restore_Scan_State (Saved_State); if Builtin then if Token_Name = GPR.Snames.Name_Split then Parse_Split (In_Tree, Current_Project, Current_Package, Split_Value => Reference, Flags => Flags); Set_Current_Term (Term, In_Tree, To => Reference); if Expr_Kind = Undefined then Expr_Kind := List; elsif Expr_Kind = Single then Expr_Kind := List; Error_Msg (Flags, "function Split cannot appear " & "in single string expression", Current_Location); end if; else Error_Msg (Flags, "unknown built-in function " & Get_Name_String (Token_Name), Current_Location); end if; else -- Get the variable or attribute reference Parse_Variable_Reference (In_Tree => In_Tree, Variable => Reference, Flags => Flags, Current_Project => Current_Project, Current_Package => Current_Package); Set_Current_Term (Term, In_Tree, To => Reference); if Present (Reference) then -- If we don't know the expression kind (first term), -- then it has the kind of the variable or attribute -- reference. if Expr_Kind = Undefined then Expr_Kind := Expression_Kind_Of (Reference, In_Tree); elsif Expr_Kind = Single and then Expression_Kind_Of (Reference, In_Tree) = List then -- If the expression is a single list, and the -- reference is a string list, report an error, and -- set the expression kind to string list to avoid -- multiple errors. Expr_Kind := List; Error_Msg (Flags, "list variable cannot appear " & "in single string expression", Current_Location); end if; end if; end if; end; when Tok_Project => -- Project can appear in an expression as the prefix of an -- attribute reference of the current project. Current_Location := Token_Ptr; Scan (In_Tree); Expect (Tok_Apostrophe, "`'`"); if Token = Tok_Apostrophe then Attribute_Reference (In_Tree => In_Tree, Reference => Reference, Flags => Flags, First_Attribute => GPR.Attr.Attribute_First, Current_Project => Current_Project, Current_Package => Empty_Project_Node); Set_Current_Term (Term, In_Tree, To => Reference); end if; -- Same checks as above for the expression kind if Present (Reference) then if Expr_Kind = Undefined then Expr_Kind := Expression_Kind_Of (Reference, In_Tree); elsif Expr_Kind = Single and then Expression_Kind_Of (Reference, In_Tree) = List then Error_Msg (Flags, "lists cannot appear in single string expression", Current_Location); end if; end if; when Tok_External | Tok_External_As_List => External_Reference (In_Tree => In_Tree, Flags => Flags, Current_Project => Current_Project, Current_Package => Current_Package, Expr_Kind => Expr_Kind, External_Value => Reference); Set_Current_Term (Term, In_Tree, To => Reference); when others => Error_Msg (Flags, "cannot be part of an expression", Token_Ptr, One_Line => True); Term := Empty_Project_Node; return; end case; -- If there is an '&', call Terms recursively if Token = Tok_Ampersand then Scan (In_Tree); -- scan past ampersand Terms (In_Tree => In_Tree, Term => Next_Term, Expr_Kind => Expr_Kind, Flags => Flags, Current_Project => Current_Project, Current_Package => Current_Package, Optional_Index => Optional_Index); -- And link the next term to this term Set_Next_Term (Term, In_Tree, To => Next_Term); end if; end Terms; end GPR.Strt; gprbuild-25.0.0/gpr/src/gpr-strt.ads000066400000000000000000000133141470075373400172540ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2016, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package implements parsing of string expressions in project files private package GPR.Strt is procedure Parse_String_Type_List (In_Tree : Project_Node_Tree_Ref; First_String : out Project_Node_Id; Flags : Processing_Flags); -- Get the list of literal strings that are allowed for a typed string. -- On entry, the current token is the first literal string following -- a left parenthesis in a string type declaration such as: -- type Toto is ("string_1", "string_2", "string_3"); -- -- On exit, the current token is the right parenthesis. The parameter -- First_String is a node that contained the first literal string of the -- string type, linked with the following literal strings. -- -- Report an error if -- - a literal string is not found at the beginning of the list -- or after a comma -- - two literal strings in the list are equal procedure Start_New_Case_Construction (In_Tree : Project_Node_Tree_Ref; String_Type : Project_Node_Id); -- This procedure is called at the beginning of a case construction. The -- parameter String_Type is the node for the string type of the case label -- variable. The different literal strings of the string type are stored -- into a table to be checked against the labels of the case construction. procedure End_Case_Construction (Check_All_Labels : Boolean; Case_Location : Source_Ptr; Flags : Processing_Flags; String_Type : Boolean); -- This procedure is called at the end of a case construction to remove -- the case labels and to restore the previous state. In particular, in the -- case of nested case constructions, the case labels of the enclosing case -- construction are restored. If When_Others is False and we are not in -- quiet output, a warning is emitted for each value of the case variable -- string type that has not been specified. procedure Parse_Choice_List (In_Tree : Project_Node_Tree_Ref; First_Choice : out Project_Node_Id; Flags : Processing_Flags; String_Type : Boolean := True); -- Get the label for a choice list. -- Report an error if -- - a case label is not a literal string -- - a case label is not in the typed string list -- - the same case label is repeated in the same case construction procedure Parse_Expression (In_Tree : Project_Node_Tree_Ref; Expression : out Project_Node_Id; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; Optional_Index : Boolean; Flags : Processing_Flags); -- Parse a simple string expression or a string list expression -- -- Current_Project is the node of the project file being parsed -- -- Current_Package is the node of the package being parsed, or Empty_Node -- when we are at the project level (not in a package). On exit, Expression -- is the node of the expression that has been parsed. procedure Parse_Variable_Reference (In_Tree : Project_Node_Tree_Ref; Variable : out Project_Node_Id; Current_Project : Project_Node_Id; Current_Package : Project_Node_Id; Flags : Processing_Flags; Allow_Attribute : Boolean := True); -- Parse variable or attribute reference. Used internally (in expressions) -- and for case variables (in Prj.Dect). Current_Package is the node of -- the package being parsed, or Empty_Node when we are at the project -- level (not in a package). On exit, Variable is the node of the variable -- or attribute reference. A variable reference is made of one to three -- simple names. An attribute reference is made of one or two simple names, -- followed by an apostrophe, followed by the attribute simple name. If -- Allow_Attribute is False, it is illegal to parse an attribute reference. end GPR.Strt; gprbuild-25.0.0/gpr/src/gpr-tempdir.adb000066400000000000000000000215741470075373400177120ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2003-2017, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GPR.Names; use GPR.Names; with GPR.Opt; use GPR.Opt; with GPR.Output; use GPR.Output; with GNAT.Strings; with Ada.Directories; package body GPR.Tempdir is Tmpdir_Needs_To_Be_Displayed : Boolean := True; Tmpdir_Initialized : Boolean := False; Valid_Tmpdir : Boolean := False; Tmpdir : constant String := "TMPDIR"; Temp : constant String := "TEMP"; Tmp : constant String := "TMP"; Windows_List : constant GNAT.Strings.String_List (1 .. 4) := (new String'("C:\TEMP"), new String'("C:\TMP"), new String'("\TEMP"), new String'("\TMP")); Other_List : constant GNAT.Strings.String_List (1 .. 3) := (new String'("/tmp"), new String'("/var/tmp"), new String'("/usr/tmp")); Temp_Dir : String_Access := new String'(""); procedure Create_Temp_Dir; -- Creates a dedicated directory from Temp_Dir procedure Initialize_Tmpdir; -- Initialize tmpdir path and creates the directory --------------------- -- Create_Temp_Dir -- --------------------- procedure Create_Temp_Dir is Pid : constant String := Pid_To_Integer (Current_Process_Id)'Img; Dir : String_Access := new String'((if Temp_Dir.all /= "" then Temp_Dir.all else Get_Current_Dir)); begin Free (Temp_Dir); Temp_Dir := new String'(Dir.all & Directory_Separator & "GPR." & Pid (Pid'First + 1 .. Pid'Last)); if not Ada.Directories.Exists (Name => Temp_Dir.all) then begin Ada.Directories.Create_Path (New_Directory => Temp_Dir.all); Valid_Tmpdir := True; exception when others => Write_Line ("could not create temporary dir " & Temp_Dir.all); end; else if Current_Verbosity = High then Write_Line ("warning: temporary dir " & Temp_Dir.all & " already exists"); end if; Valid_Tmpdir := True; end if; Free (Dir); end Create_Temp_Dir; ---------------------- -- Create_Temp_File -- ---------------------- procedure Create_Temp_File (FD : out File_Descriptor; Name : out Path_Name_Type) is File_Name : String_Access; Current_Dir : constant String := Get_Current_Dir; function Directory return String; -- Returns Temp_Dir.all if not empty, else return current directory --------------- -- Directory -- --------------- function Directory return String is begin if Temp_Dir'Length /= 0 then return Temp_Dir.all; else return Current_Dir; end if; end Directory; -- Start of processing for Create_Temp_File begin if not Tmpdir_Initialized then Initialize_Tmpdir; Tmpdir_Initialized := True; end if; if Valid_Tmpdir then -- In verbose mode, display once the value of TMPDIR, so that -- if temp files cannot be created, it is easier to understand -- where temp files are supposed to be created. if Opt.Verbosity_Level > Opt.Low and then Tmpdir_Needs_To_Be_Displayed then Write_Str ("TMPDIR = """); Write_Str (Temp_Dir.all); Write_Line (""""); Tmpdir_Needs_To_Be_Displayed := False; end if; -- Change directory to TMPDIR before creating the temp file, -- then change back immediately to the previous directory. Change_Dir (Temp_Dir.all); Create_Temp_File (FD, File_Name); Change_Dir (Current_Dir); else FD := Invalid_FD; end if; if FD = Invalid_FD then Write_Line ("could not create temporary file in " & Directory); Name := No_Path; else declare Path_Name : constant String := Normalize_Pathname (Directory & Directory_Separator & File_Name.all); begin Name_Len := Path_Name'Length; Name_Buffer (1 .. Name_Len) := Path_Name; Name := Name_Find; Free (File_Name); end; end if; end Create_Temp_File; --------------------- -- Delete_Temp_Dir -- --------------------- procedure Delete_Temp_Dir is use Ada.Directories; begin if not Valid_Tmpdir then return; end if; if Current_Verbosity = High then Write_Line ("Removing temp dir: " & Temp_Dir.all); end if; if Ada.Directories.Exists (Name => Temp_Dir.all) then Delete_Directory (Directory => Temp_Dir.all); else if Current_Verbosity = High then Write_Line ("Temp dir " & Temp_Dir.all & " already removed"); end if; end if; exception when Use_Error => if Current_Verbosity = High then Write_Line ("Failed to remove temp dir " & Temp_Dir.all); end if; end Delete_Temp_Dir; ----------------------- -- Initialize_Tmpdir -- ----------------------- procedure Initialize_Tmpdir is begin Create_Temp_Dir; end Initialize_Tmpdir; ------------------------------ -- Temporary_Directory_Path -- ------------------------------ function Temporary_Directory_Path return String is begin if Temp_Dir /= null then return Temp_Dir.all; else return ""; end if; end Temporary_Directory_Path; ------------------ -- Use_Temp_Dir -- ------------------ procedure Use_Temp_Dir (Status : Boolean) is pragma Unreferenced (Status); Dir : String_Access := null; function Dir_Is_Temporary_Dir return Boolean is (Dir /= null and then Dir'Length > 0 and then Is_Absolute_Path (Dir.all) and then Is_Directory (Dir.all)); begin -- Checking environment variables. Dir := Getenv (Tmpdir); if not Dir_Is_Temporary_Dir then Free (Dir); Dir := Getenv (Temp); if not Dir_Is_Temporary_Dir then Free (Dir); Dir := Getenv (Tmp); end if; end if; Free (Temp_Dir); if Dir_Is_Temporary_Dir then Temp_Dir := new String'(Normalize_Pathname (Dir.all)); Free (Dir); return; end if; Free (Dir); if Directory_Separator = '\' then for I in Windows_List'Range loop Dir := Windows_List (I); if Dir_Is_Temporary_Dir then Temp_Dir := new String'(Normalize_Pathname (Dir.all)); return; end if; end loop; else for I in Other_List'Range loop Dir := Other_List (I); if Dir_Is_Temporary_Dir then Temp_Dir := new String'(Normalize_Pathname (Dir.all)); return; end if; end loop; end if; Temp_Dir := new String'(Get_Current_Dir); end Use_Temp_Dir; -- Start of elaboration for package Tempdir begin Use_Temp_Dir (Status => True); end GPR.Tempdir; gprbuild-25.0.0/gpr/src/gpr-tempdir.ads000066400000000000000000000066031470075373400177270ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2003-2017, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package is used by the Project Manager to create temporary files. If -- environment variable TMPDIR is defined and designates an absolute path, -- temporary files are create in this directory. Otherwise, temporary files -- are created in the current working directory. package GPR.Tempdir is procedure Create_Temp_File (FD : out File_Descriptor; Name : out Path_Name_Type); -- Create a temporary text file and return its file descriptor and its -- path name as a Name_Id. If one of the environment variables TMPDIR, TEMP -- or TMP is defined and its value is an absolute path, the temp file is -- created in the directory designated by the first of these environment -- variables that meet these conditions, otherwise, it is created in the -- current directory. If temporary file cannot be created, FD gets the -- value Invalid_FD and Name gets the value No_Name. procedure Delete_Temp_Dir; -- Delete the folder used to store all temp files procedure Use_Temp_Dir (Status : Boolean); -- Specify if the temp file should be created in the system temporary -- directory as specified by the corresponding environment variables. If -- Status is False, the temp files will be created into the current working -- directory. function Temporary_Directory_Path return String; -- Returns the full path of the temporary directory in use. -- Returns an empty string if there is no temporary directory in use, -- either because Use_Temp_Dir was called with Status set to False, -- or none of the environment variables are defined. end GPR.Tempdir; gprbuild-25.0.0/gpr/src/gpr-tree.adb000066400000000000000000002654741470075373400172160ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2021, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with GPR.Attr; use GPR.Attr; with GPR.Env; use GPR.Env; with GPR.Err; with GPR.Names; use GPR.Names; with GPR.Osint; use GPR.Osint; with GPR.Scans; use GPR.Scans; package body GPR.Tree is Node_With_Comments : constant array (Project_Node_Kind) of Boolean := (N_Project => True, N_With_Clause => True, N_Project_Declaration => False, N_Declarative_Item => False, N_Package_Declaration => True, N_String_Type_Declaration => True, N_Literal_String => False, N_Attribute_Declaration => True, N_Typed_Variable_Declaration => True, N_Variable_Declaration => True, N_Expression => False, N_Term => False, N_Literal_String_List => False, N_Variable_Reference => False, N_External_Value => False, N_Split => False, N_Attribute_Reference => False, N_Case_Construction => True, N_Case_Item => True, N_Comment_Zones => True, N_Comment => True); -- Indicates the kinds of node that may have associated comments package Next_End_Nodes is new GNAT.Table (Table_Component_Type => Project_Node_Id, Table_Index_Type => Natural, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 100); -- A stack of nodes to indicates to what node the next "end" is associated use Tree_Private_Part; End_Of_Line_Node : Project_Node_Id := Empty_Project_Node; -- The node an end of line comment may be associated with Previous_Line_Node : Project_Node_Id := Empty_Project_Node; -- The node an immediately following comment may be associated with Previous_End_Node : Project_Node_Id := Empty_Project_Node; -- The node comments immediately following an "end" line may be -- associated with. Unkept_Comments : Boolean := False; -- Set to True when some comments may not be associated with any node function Comment_Zones_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; -- Returns the ID of the N_Comment_Zones node associated with node Node. -- If there is not already an N_Comment_Zones node, create one and -- associate it with node Node. ------------------ -- Add_Comments -- ------------------ procedure Add_Comments (To : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; Where : Comment_Location) is Zone : Project_Node_Id := Empty_Project_Node; Previous : Project_Node_Id := Empty_Project_Node; begin pragma Assert (Present (To) and then In_Tree.Project_Nodes.Table (To).Kind /= N_Comment); Zone := In_Tree.Project_Nodes.Table (To).Comments; if No (Zone) then -- Create new N_Comment_Zones node Project_Node_Table.Increment_Last (In_Tree.Project_Nodes); In_Tree.Project_Nodes.Table (Project_Node_Table.Last (In_Tree.Project_Nodes)) := (Kind => N_Comment_Zones, others => <>); Zone := Project_Node_Table.Last (In_Tree.Project_Nodes); In_Tree.Project_Nodes.Table (To).Comments := Zone; end if; if Where = End_Of_Line then In_Tree.Project_Nodes.Table (Zone).Value := Comments.Table (1).Value; else -- Get each comments in the Comments table and link them to node To for J in 1 .. Comments.Last loop -- Create new N_Comment node if (Where = After or else Where = After_End) and then Token /= Tok_EOF and then Comments.Table (J).Follows_Empty_Line then Comments.Table (1 .. Comments.Last - J + 1) := Comments.Table (J .. Comments.Last); Comments.Set_Last (Comments.Last - J + 1); return; end if; Project_Node_Table.Increment_Last (In_Tree.Project_Nodes); In_Tree.Project_Nodes.Table (Project_Node_Table.Last (In_Tree.Project_Nodes)) := (Kind => N_Comment, Flag1 => Comments.Table (J).Follows_Empty_Line, Flag2 => Comments.Table (J).Is_Followed_By_Empty_Line, Value => Comments.Table (J).Value, others => <>); -- If this is the first comment, put it in the right field of -- the node Zone. if No (Previous) then case Where is when Before => In_Tree.Project_Nodes.Table (Zone).Field1 := Project_Node_Table.Last (In_Tree.Project_Nodes); when After => In_Tree.Project_Nodes.Table (Zone).Field2 := Project_Node_Table.Last (In_Tree.Project_Nodes); when Before_End => In_Tree.Project_Nodes.Table (Zone).Field3 := Project_Node_Table.Last (In_Tree.Project_Nodes); when After_End => In_Tree.Project_Nodes.Table (Zone).Comments := Project_Node_Table.Last (In_Tree.Project_Nodes); when End_Of_Line => null; end case; else -- When it is not the first, link it to the previous one In_Tree.Project_Nodes.Table (Previous).Comments := Project_Node_Table.Last (In_Tree.Project_Nodes); end if; -- This node becomes the previous one for the next comment, if -- there is one. Previous := Project_Node_Table.Last (In_Tree.Project_Nodes); end loop; end if; -- Empty the Comments table, so that there is no risk to link the same -- comments to another node. Comments.Set_Last (0); end Add_Comments; -------------------------------- -- Associative_Array_Index_Of -- -------------------------------- function Associative_Array_Index_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Name_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_Attribute_Declaration | N_Attribute_Reference); return In_Tree.Project_Nodes.Table (Node).Value; end Associative_Array_Index_Of; ---------------------------- -- Associative_Package_Of -- ---------------------------- function Associative_Package_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration); return In_Tree.Project_Nodes.Table (Node).Field3; end Associative_Package_Of; ---------------------------- -- Associative_Project_Of -- ---------------------------- function Associative_Project_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration); return In_Tree.Project_Nodes.Table (Node).Field2; end Associative_Project_Of; ---------------------- -- Case_Insensitive -- ---------------------- function Case_Insensitive (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Boolean is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_Attribute_Declaration | N_Attribute_Reference); return In_Tree.Project_Nodes.Table (Node).Flag1; end Case_Insensitive; -------------------------------- -- Case_Variable_Reference_Of -- -------------------------------- function Case_Variable_Reference_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Construction); return In_Tree.Project_Nodes.Table (Node).Field1; end Case_Variable_Reference_Of; ---------------------- -- Comment_Zones_Of -- ---------------------- function Comment_Zones_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is Zone : Project_Node_Id; begin pragma Assert (Present (Node)); Zone := In_Tree.Project_Nodes.Table (Node).Comments; -- If there is not already an N_Comment_Zones associated, create a new -- one and associate it with node Node. if No (Zone) then Project_Node_Table.Increment_Last (In_Tree.Project_Nodes); Zone := Project_Node_Table.Last (In_Tree.Project_Nodes); In_Tree.Project_Nodes.Table (Zone) := (Kind => N_Comment_Zones, others => <>); In_Tree.Project_Nodes.Table (Node).Comments := Zone; end if; return Zone; end Comment_Zones_Of; ----------------------- -- Current_Item_Node -- ----------------------- function Current_Item_Node (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Declarative_Item); return In_Tree.Project_Nodes.Table (Node).Field1; end Current_Item_Node; ------------------ -- Current_Term -- ------------------ function Current_Term (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Term); return In_Tree.Project_Nodes.Table (Node).Field1; end Current_Term; ---------------- -- Default_Of -- ---------------- function Default_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Attribute_Default_Value is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference); return In_Tree.Project_Nodes.Table (Node).Default; end Default_Of; -------------------------- -- Default_Project_Node -- -------------------------- function Default_Project_Node (In_Tree : Project_Node_Tree_Ref; Of_Kind : Project_Node_Kind; And_Expr_Kind : Variable_Kind := Undefined) return Project_Node_Id is Result : Project_Node_Id; Zone : Project_Node_Id; Previous : Project_Node_Id; begin -- Create new node with specified kind and expression kind Project_Node_Table.Increment_Last (In_Tree.Project_Nodes); In_Tree.Project_Nodes.Table (Project_Node_Table.Last (In_Tree.Project_Nodes)) := (Kind => Of_Kind, Expr_Kind => And_Expr_Kind, others => <>); -- Save the new node for the returned value Result := Project_Node_Table.Last (In_Tree.Project_Nodes); if Comments.Last > 0 then -- If this is not a node with comments, then set the flag if not Node_With_Comments (Of_Kind) then Unkept_Comments := True; elsif Of_Kind /= N_Comment and then Of_Kind /= N_Comment_Zones then Project_Node_Table.Increment_Last (In_Tree.Project_Nodes); In_Tree.Project_Nodes.Table (Project_Node_Table.Last (In_Tree.Project_Nodes)) := (Kind => N_Comment_Zones, others => <>); Zone := Project_Node_Table.Last (In_Tree.Project_Nodes); In_Tree.Project_Nodes.Table (Result).Comments := Zone; Previous := Empty_Project_Node; for J in 1 .. Comments.Last loop -- Create a new N_Comment node Project_Node_Table.Increment_Last (In_Tree.Project_Nodes); In_Tree.Project_Nodes.Table (Project_Node_Table.Last (In_Tree.Project_Nodes)) := (Kind => N_Comment, Flag1 => Comments.Table (J).Follows_Empty_Line, Flag2 => Comments.Table (J).Is_Followed_By_Empty_Line, Value => Comments.Table (J).Value, others => <>); -- Link it to the N_Comment_Zones node, if it is the first, -- otherwise to the previous one. if No (Previous) then In_Tree.Project_Nodes.Table (Zone).Field1 := Project_Node_Table.Last (In_Tree.Project_Nodes); else In_Tree.Project_Nodes.Table (Previous).Comments := Project_Node_Table.Last (In_Tree.Project_Nodes); end if; -- This new node will be the previous one for the next -- N_Comment node, if there is one. Previous := Project_Node_Table.Last (In_Tree.Project_Nodes); end loop; -- Empty the Comments table after all comments have been processed Comments.Set_Last (0); end if; end if; return Result; end Default_Project_Node; ------------------ -- Directory_Of -- ------------------ function Directory_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Path_Name_Type is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); return In_Tree.Project_Nodes.Table (Node).Directory; end Directory_Of; ------------------------- -- End_Of_Line_Comment -- ------------------------- function End_Of_Line_Comment (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Name_Id is Zone : Project_Node_Id := Empty_Project_Node; begin pragma Assert (Present (Node)); Zone := In_Tree.Project_Nodes.Table (Node).Comments; if No (Zone) then return No_Name; else return In_Tree.Project_Nodes.Table (Zone).Value; end if; end End_Of_Line_Comment; ------------------------ -- Expression_Kind_Of -- ------------------------ function Expression_Kind_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Variable_Kind is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_Literal_String | N_Attribute_Declaration | N_Variable_Declaration | N_Typed_Variable_Declaration | N_Package_Declaration | N_Expression | N_Term | N_Split | N_Variable_Reference | N_Attribute_Reference | N_External_Value); return In_Tree.Project_Nodes.Table (Node).Expr_Kind; end Expression_Kind_Of; ------------------- -- Expression_Of -- ------------------- function Expression_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_Attribute_Declaration | N_Typed_Variable_Declaration | N_Variable_Declaration); return In_Tree.Project_Nodes.Table (Node).Field1; end Expression_Of; ------------------------- -- Extended_Project_Of -- ------------------------- function Extended_Project_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration); return In_Tree.Project_Nodes.Table (Node).Field2; end Extended_Project_Of; ------------------------------ -- Extended_Project_Path_Of -- ------------------------------ function Extended_Project_Path_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Path_Name_Type is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); return Path_Name_Type (In_Tree.Project_Nodes.Table (Node).Value); end Extended_Project_Path_Of; -------------------------- -- Extending_Project_Of -- -------------------------- function Extending_Project_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration); return In_Tree.Project_Nodes.Table (Node).Field3; end Extending_Project_Of; --------------------------- -- External_Reference_Of -- --------------------------- function External_Reference_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value); return In_Tree.Project_Nodes.Table (Node).Field1; end External_Reference_Of; ------------------------- -- External_Default_Of -- ------------------------- function External_Default_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value); return In_Tree.Project_Nodes.Table (Node).Field2; end External_Default_Of; ------------------------ -- String_Argument_Of -- ------------------------ function String_Argument_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Split); return In_Tree.Project_Nodes.Table (Node).Field1; end String_Argument_Of; ------------------ -- Separator_Of -- ------------------ function Separator_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Split); return In_Tree.Project_Nodes.Table (Node).Field2; end Separator_Of; ------------------------ -- First_Case_Item_Of -- ------------------------ function First_Case_Item_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Construction); return In_Tree.Project_Nodes.Table (Node).Field2; end First_Case_Item_Of; --------------------- -- First_Choice_Of -- --------------------- function First_Choice_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item); return In_Tree.Project_Nodes.Table (Node).Field1; end First_Choice_Of; ------------------------- -- First_Comment_After -- ------------------------- function First_Comment_After (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is Zone : Project_Node_Id := Empty_Project_Node; begin pragma Assert (Present (Node)); Zone := In_Tree.Project_Nodes.Table (Node).Comments; if No (Zone) then return Empty_Project_Node; else return In_Tree.Project_Nodes.Table (Zone).Field2; end if; end First_Comment_After; ----------------------------- -- First_Comment_After_End -- ----------------------------- function First_Comment_After_End (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is Zone : Project_Node_Id := Empty_Project_Node; begin pragma Assert (Present (Node)); Zone := In_Tree.Project_Nodes.Table (Node).Comments; if No (Zone) then return Empty_Project_Node; else return In_Tree.Project_Nodes.Table (Zone).Comments; end if; end First_Comment_After_End; -------------------------- -- First_Comment_Before -- -------------------------- function First_Comment_Before (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is Zone : Project_Node_Id := Empty_Project_Node; begin pragma Assert (Present (Node)); Zone := In_Tree.Project_Nodes.Table (Node).Comments; if No (Zone) then return Empty_Project_Node; else return In_Tree.Project_Nodes.Table (Zone).Field1; end if; end First_Comment_Before; ------------------------------ -- First_Comment_Before_End -- ------------------------------ function First_Comment_Before_End (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is Zone : Project_Node_Id := Empty_Project_Node; begin pragma Assert (Present (Node)); Zone := In_Tree.Project_Nodes.Table (Node).Comments; if No (Zone) then return Empty_Project_Node; else return In_Tree.Project_Nodes.Table (Zone).Field3; end if; end First_Comment_Before_End; ------------------------------- -- First_Declarative_Item_Of -- ------------------------------- function First_Declarative_Item_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_Project_Declaration | N_Case_Item | N_Package_Declaration); if In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration then return In_Tree.Project_Nodes.Table (Node).Field1; else return In_Tree.Project_Nodes.Table (Node).Field2; end if; end First_Declarative_Item_Of; ------------------------------ -- First_Expression_In_List -- ------------------------------ function First_Expression_In_List (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String_List); return In_Tree.Project_Nodes.Table (Node).Field1; end First_Expression_In_List; -------------------------- -- First_Literal_String -- -------------------------- function First_Literal_String (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_String_Type_Declaration); return In_Tree.Project_Nodes.Table (Node).Field1; end First_Literal_String; ---------------------- -- First_Package_Of -- ---------------------- function First_Package_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Package_Declaration_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); return In_Tree.Project_Nodes.Table (Node).Packages; end First_Package_Of; -------------------------- -- First_String_Type_Of -- -------------------------- function First_String_Type_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); return In_Tree.Project_Nodes.Table (Node).Field3; end First_String_Type_Of; ---------------- -- First_Term -- ---------------- function First_Term (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Expression); return In_Tree.Project_Nodes.Table (Node).Field1; end First_Term; ----------------------- -- First_Variable_Of -- ----------------------- function First_Variable_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Variable_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_Project | N_Package_Declaration); return In_Tree.Project_Nodes.Table (Node).Variables; end First_Variable_Of; -------------------------- -- First_With_Clause_Of -- -------------------------- function First_With_Clause_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); return In_Tree.Project_Nodes.Table (Node).Field1; end First_With_Clause_Of; ------------------------ -- Follows_Empty_Line -- ------------------------ function Follows_Empty_Line (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Boolean is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Comment); return In_Tree.Project_Nodes.Table (Node).Flag1; end Follows_Empty_Line; ---------- -- Hash -- ---------- function Hash (N : Project_Node_Id) return Header_Num is begin return Header_Num (N mod Project_Node_Id (Header_Num'Last)); end Hash; ---------------- -- Initialize -- ---------------- procedure Initialize (Tree : Project_Node_Tree_Ref) is begin Project_Node_Table.Init (Tree.Project_Nodes); Projects_Htable.Reset (Tree.Projects_HT); end Initialize; ---------------------------- -- Is_Config_Concatenable -- ---------------------------- function Is_Config_Concatenable (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Boolean is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_Attribute_Declaration | N_Attribute_Reference); return In_Tree.Project_Nodes.Table (Node).Flag2; end Is_Config_Concatenable; -------------------- -- Override_Flags -- -------------------- procedure Override_Flags (Self : in out Environment; Flags : GPR.Processing_Flags) is begin Self.Flags := Flags; end Override_Flags; ---------------- -- Initialize -- ---------------- procedure Initialize (Self : out Environment; Flags : Processing_Flags) is begin -- Do not reset the external references, in case we are reloading a -- project, since we want to preserve the current environment. But we -- still need to ensure that the external references are properly -- initialized. GPR.Ext.Initialize (Self.External); Self.Flags := Flags; end Initialize; ------------------------- -- Initialize_And_Copy -- ------------------------- procedure Initialize_And_Copy (Self : out Environment; Copy_From : Environment) is begin Self.Flags := Copy_From.Flags; GPR.Ext.Initialize (Self.External, Copy_From => Copy_From.External); GPR.Env.Copy (From => Copy_From.Project_Path, To => Self.Project_Path); end Initialize_And_Copy; ---------- -- Free -- ---------- procedure Free (Self : in out Environment) is begin GPR.Ext.Free (Self.External); Free (Self.Project_Path); end Free; ------------------------------- -- Is_Followed_By_Empty_Line -- ------------------------------- function Is_Followed_By_Empty_Line (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Boolean is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Comment); return In_Tree.Project_Nodes.Table (Node).Flag2; end Is_Followed_By_Empty_Line; ---------------------- -- Is_Extending_All -- ---------------------- function Is_Extending_All (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Boolean is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_Project | N_With_Clause); return In_Tree.Project_Nodes.Table (Node).Flag2; end Is_Extending_All; ------------------------- -- Is_Not_Last_In_List -- ------------------------- function Is_Not_Last_In_List (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Boolean is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause); return In_Tree.Project_Nodes.Table (Node).Flag1; end Is_Not_Last_In_List; ------------------------------------- -- Imported_Or_Extended_Project_Of -- ------------------------------------- function Imported_Or_Extended_Project_Of (Project : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; With_Name : Name_Id) return Project_Node_Id is With_Clause : Project_Node_Id; Result : Project_Node_Id := Empty_Project_Node; Decl : Project_Node_Id; begin -- First check all the imported projects With_Clause := First_With_Clause_Of (Project, In_Tree); while Present (With_Clause) loop -- Only non limited imported project may be used as prefix of -- variables or attributes. Result := Non_Limited_Project_Node_Of (With_Clause, In_Tree); while Present (Result) loop if Name_Of (Result, In_Tree) = With_Name then return Result; end if; Decl := Project_Declaration_Of (Result, In_Tree); -- Do not try to check for an extended project, if the project -- does not have yet a project declaration. exit when No (Decl); Result := Extended_Project_Of (Decl, In_Tree); end loop; With_Clause := Next_With_Clause_Of (With_Clause, In_Tree); end loop; -- If it is not an imported project, it might be an extended project if No (With_Clause) then Result := Project; loop Result := Extended_Project_Of (Project_Declaration_Of (Result, In_Tree), In_Tree); exit when No (Result) or else Name_Of (Result, In_Tree) = With_Name; end loop; end if; return Result; end Imported_Or_Extended_Project_Of; ------------- -- Kind_Of -- ------------- function Kind_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Kind is begin pragma Assert (Present (Node)); return In_Tree.Project_Nodes.Table (Node).Kind; end Kind_Of; ----------------- -- Location_Of -- ----------------- function Location_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Source_Ptr is begin pragma Assert (Present (Node)); return In_Tree.Project_Nodes.Table (Node).Location; end Location_Of; ------------- -- Name_Of -- ------------- function Name_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Name_Id is begin pragma Assert (Present (Node)); return In_Tree.Project_Nodes.Table (Node).Name; end Name_Of; --------------------- -- Display_Name_Of -- --------------------- function Display_Name_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Name_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); return In_Tree.Project_Nodes.Table (Node).Display_Name; end Display_Name_Of; -------------------- -- Next_Case_Item -- -------------------- function Next_Case_Item (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item); return In_Tree.Project_Nodes.Table (Node).Field3; end Next_Case_Item; ------------------ -- Next_Comment -- ------------------ function Next_Comment (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Comment); return In_Tree.Project_Nodes.Table (Node).Comments; end Next_Comment; --------------------------- -- Next_Declarative_Item -- --------------------------- function Next_Declarative_Item (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Declarative_Item); return In_Tree.Project_Nodes.Table (Node).Field2; end Next_Declarative_Item; ----------------------------- -- Next_Expression_In_List -- ----------------------------- function Next_Expression_In_List (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Expression); return In_Tree.Project_Nodes.Table (Node).Field2; end Next_Expression_In_List; ------------------------- -- Next_Literal_String -- ------------------------- function Next_Literal_String (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String); return In_Tree.Project_Nodes.Table (Node).Field1; end Next_Literal_String; ----------------------------- -- Next_Package_In_Project -- ----------------------------- function Next_Package_In_Project (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); return In_Tree.Project_Nodes.Table (Node).Field3; end Next_Package_In_Project; ---------------------- -- Next_String_Type -- ---------------------- function Next_String_Type (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_String_Type_Declaration); return In_Tree.Project_Nodes.Table (Node).Field2; end Next_String_Type; --------------- -- Next_Term -- --------------- function Next_Term (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Term); return In_Tree.Project_Nodes.Table (Node).Field2; end Next_Term; ------------------- -- Next_Variable -- ------------------- function Next_Variable (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_Typed_Variable_Declaration | N_Variable_Declaration); return In_Tree.Project_Nodes.Table (Node).Field3; end Next_Variable; ------------------------- -- Next_With_Clause_Of -- ------------------------- function Next_With_Clause_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause); return In_Tree.Project_Nodes.Table (Node).Field2; end Next_With_Clause_Of; -------- -- No -- -------- function No (Node : Project_Node_Id) return Boolean is begin return Node = Empty_Project_Node; end No; --------------------------------- -- Non_Limited_Project_Node_Of -- --------------------------------- function Non_Limited_Project_Node_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause); return In_Tree.Project_Nodes.Table (Node).Field3; end Non_Limited_Project_Node_Of; ------------------- -- Package_Id_Of -- ------------------- function Package_Id_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Package_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); return In_Tree.Project_Nodes.Table (Node).Pkg_Id; end Package_Id_Of; --------------------- -- Package_Node_Of -- --------------------- function Package_Node_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_Variable_Reference | N_Attribute_Reference); return In_Tree.Project_Nodes.Table (Node).Field2; end Package_Node_Of; ------------------ -- Path_Name_Of -- ------------------ function Path_Name_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Path_Name_Type is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_Project | N_With_Clause); return In_Tree.Project_Nodes.Table (Node).Path_Name; end Path_Name_Of; ------------- -- Present -- ------------- function Present (Node : Project_Node_Id) return Boolean is begin return Node /= Empty_Project_Node; end Present; ---------------------------- -- Project_Declaration_Of -- ---------------------------- function Project_Declaration_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); return In_Tree.Project_Nodes.Table (Node).Field2; end Project_Declaration_Of; -------------------------- -- Project_Qualifier_Of -- -------------------------- function Project_Qualifier_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Qualifier is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); return In_Tree.Project_Nodes.Table (Node).Qualifier; end Project_Qualifier_Of; ----------------------- -- Parent_Project_Of -- ----------------------- function Parent_Project_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); return In_Tree.Project_Nodes.Table (Node).Field4; end Parent_Project_Of; ------------------------------------------- -- Project_File_Includes_Unkept_Comments -- ------------------------------------------- function Project_File_Includes_Unkept_Comments (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Boolean is Declaration : constant Project_Node_Id := Project_Declaration_Of (Node, In_Tree); begin return In_Tree.Project_Nodes.Table (Declaration).Flag1; end Project_File_Includes_Unkept_Comments; --------------------- -- Project_Node_Of -- --------------------- function Project_Node_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_With_Clause | N_Variable_Reference | N_Attribute_Reference | N_String_Type_Declaration | N_Typed_Variable_Declaration); declare The_Node : Project_Node_Record renames In_Tree.Project_Nodes.Table (Node); begin case The_Node.Kind is when N_With_Clause | N_Variable_Reference | N_Attribute_Reference => return The_Node.Field1; when N_String_Type_Declaration => return The_Node.Field3; when N_Typed_Variable_Declaration => return The_Node.Field4; when others => return Empty_Project_Node; end case; end; end Project_Node_Of; ----------------------------------- -- Project_Of_Renamed_Package_Of -- ----------------------------------- function Project_Of_Renamed_Package_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); return In_Tree.Project_Nodes.Table (Node).Field1; end Project_Of_Renamed_Package_Of; -------------------------- -- Remove_Next_End_Node -- -------------------------- procedure Remove_Next_End_Node is begin Next_End_Nodes.Decrement_Last; end Remove_Next_End_Node; ----------------- -- Reset_State -- ----------------- procedure Reset_State is begin End_Of_Line_Node := Empty_Project_Node; Previous_Line_Node := Empty_Project_Node; Previous_End_Node := Empty_Project_Node; Unkept_Comments := False; Comments.Set_Last (0); end Reset_State; ---------------------- -- Restore_And_Free -- ---------------------- procedure Restore_And_Free (S : in out Comment_State) is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Comment_Array, Comments_Ptr); begin End_Of_Line_Node := S.End_Of_Line_Node; Previous_Line_Node := S.Previous_Line_Node; Previous_End_Node := S.Previous_End_Node; Next_End_Nodes.Set_Last (0); Unkept_Comments := S.Unkept_Comments; Comments.Set_Last (0); for J in S.Comments'Range loop Comments.Increment_Last; Comments.Table (Comments.Last) := S.Comments (J); end loop; Unchecked_Free (S.Comments); end Restore_And_Free; ---------- -- Save -- ---------- procedure Save (S : out Comment_State) is Cmts : constant Comments_Ptr := new Comment_Array (1 .. Comments.Last); begin for J in 1 .. Comments.Last loop Cmts (J) := Comments.Table (J); end loop; S := (End_Of_Line_Node => End_Of_Line_Node, Previous_Line_Node => Previous_Line_Node, Previous_End_Node => Previous_End_Node, Unkept_Comments => Unkept_Comments, Comments => Cmts); end Save; ---------- -- Scan -- ---------- procedure Scan (In_Tree : Project_Node_Tree_Ref) is Empty_Line : Boolean := False; begin -- If there are comments, then they will not be kept. Set the flag and -- clear the comments. if Comments.Last > 0 then Unkept_Comments := True; Comments.Set_Last (0); end if; -- Loop until a token other that End_Of_Line or Comment is found loop GPR.Err.Scanner.Scan; case Token is when Tok_End_Of_Line => if Prev_Token = Tok_End_Of_Line then Empty_Line := True; if Comments.Last > 0 then Comments.Table (Comments.Last).Is_Followed_By_Empty_Line := True; end if; end if; when Tok_Comment => -- If this is a line comment, add it to the comment table if Prev_Token = Tok_End_Of_Line or else Prev_Token = No_Token then Comments.Increment_Last; Comments.Table (Comments.Last) := (Value => Comment_Id, Follows_Empty_Line => Empty_Line, Is_Followed_By_Empty_Line => False); -- Otherwise, it is an end of line comment. If there is an -- end of line node specified, associate the comment with -- this node. elsif Present (End_Of_Line_Node) then declare Zones : constant Project_Node_Id := Comment_Zones_Of (End_Of_Line_Node, In_Tree); begin In_Tree.Project_Nodes.Table (Zones).Value := Comment_Id; end; -- Otherwise, this end of line node cannot be kept else Unkept_Comments := True; Comments.Set_Last (0); end if; Empty_Line := False; when others => -- If there are comments, where the first comment is not -- following an empty line, put the initial uninterrupted -- comment zone with the node of the preceding line (either -- a Previous_Line or a Previous_End node), if any. if Comments.Last > 0 and then not Comments.Table (1).Follows_Empty_Line then if Present (Previous_Line_Node) then Add_Comments (To => Previous_Line_Node, Where => After, In_Tree => In_Tree); elsif Present (Previous_End_Node) then Add_Comments (To => Previous_End_Node, Where => After_End, In_Tree => In_Tree); end if; end if; -- If there are still comments and the token is "end", then -- put these comments with the Next_End node, if any; -- otherwise, these comments cannot be kept. Always clear -- the comments. if Comments.Last > 0 and then Token = Tok_End then if Next_End_Nodes.Last > 0 then Add_Comments (To => Next_End_Nodes.Table (Next_End_Nodes.Last), Where => Before_End, In_Tree => In_Tree); else Unkept_Comments := True; end if; Comments.Set_Last (0); end if; -- Reset the End_Of_Line, Previous_Line and Previous_End nodes -- so that they are not used again. End_Of_Line_Node := Empty_Project_Node; Previous_Line_Node := Empty_Project_Node; Previous_End_Node := Empty_Project_Node; -- And return exit; end case; end loop; end Scan; ------------------------------------ -- Set_Associative_Array_Index_Of -- ------------------------------------ procedure Set_Associative_Array_Index_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Name_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_Attribute_Declaration | N_Attribute_Reference); In_Tree.Project_Nodes.Table (Node).Value := To; end Set_Associative_Array_Index_Of; -------------------------------- -- Set_Associative_Package_Of -- -------------------------------- procedure Set_Associative_Package_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration); In_Tree.Project_Nodes.Table (Node).Field3 := To; end Set_Associative_Package_Of; -------------------------------- -- Set_Associative_Project_Of -- -------------------------------- procedure Set_Associative_Project_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration); In_Tree.Project_Nodes.Table (Node).Field2 := To; end Set_Associative_Project_Of; -------------------------- -- Set_Case_Insensitive -- -------------------------- procedure Set_Case_Insensitive (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Boolean) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_Attribute_Declaration | N_Attribute_Reference); In_Tree.Project_Nodes.Table (Node).Flag1 := To; end Set_Case_Insensitive; ------------------------------------ -- Set_Case_Variable_Reference_Of -- ------------------------------------ procedure Set_Case_Variable_Reference_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Construction); In_Tree.Project_Nodes.Table (Node).Field1 := To; end Set_Case_Variable_Reference_Of; --------------------------- -- Set_Current_Item_Node -- --------------------------- procedure Set_Current_Item_Node (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Declarative_Item); In_Tree.Project_Nodes.Table (Node).Field1 := To; end Set_Current_Item_Node; ---------------------- -- Set_Current_Term -- ---------------------- procedure Set_Current_Term (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Term); In_Tree.Project_Nodes.Table (Node).Field1 := To; end Set_Current_Term; -------------------- -- Set_Default_Of -- -------------------- procedure Set_Default_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Attribute_Default_Value) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference); In_Tree.Project_Nodes.Table (Node).Default := To; end Set_Default_Of; ---------------------- -- Set_Directory_Of -- ---------------------- procedure Set_Directory_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Path_Name_Type) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); In_Tree.Project_Nodes.Table (Node).Directory := To; end Set_Directory_Of; --------------------- -- Set_End_Of_Line -- --------------------- procedure Set_End_Of_Line (To : Project_Node_Id) is begin End_Of_Line_Node := To; end Set_End_Of_Line; ---------------------------- -- Set_Expression_Kind_Of -- ---------------------------- procedure Set_Expression_Kind_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Variable_Kind) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_Literal_String | N_Attribute_Declaration | N_Variable_Declaration | N_Typed_Variable_Declaration | N_Package_Declaration | N_Expression | N_Term | N_Variable_Reference | N_Attribute_Reference | N_External_Value); In_Tree.Project_Nodes.Table (Node).Expr_Kind := To; end Set_Expression_Kind_Of; ----------------------- -- Set_Expression_Of -- ----------------------- procedure Set_Expression_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_Attribute_Declaration | N_Typed_Variable_Declaration | N_Variable_Declaration); In_Tree.Project_Nodes.Table (Node).Field1 := To; end Set_Expression_Of; ------------------------------- -- Set_External_Reference_Of -- ------------------------------- procedure Set_External_Reference_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value); In_Tree.Project_Nodes.Table (Node).Field1 := To; end Set_External_Reference_Of; ----------------------------- -- Set_External_Default_Of -- ----------------------------- procedure Set_External_Default_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value); In_Tree.Project_Nodes.Table (Node).Field2 := To; end Set_External_Default_Of; ---------------------------- -- Set_String_Argument_Of -- ---------------------------- procedure Set_String_Argument_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Split); In_Tree.Project_Nodes.Table (Node).Field1 := To; end Set_String_Argument_Of; ---------------------- -- Set_Separator_Of -- ---------------------- procedure Set_Separator_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Split); In_Tree.Project_Nodes.Table (Node).Field2 := To; end Set_Separator_Of; ---------------------------- -- Set_First_Case_Item_Of -- ---------------------------- procedure Set_First_Case_Item_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Construction); In_Tree.Project_Nodes.Table (Node).Field2 := To; end Set_First_Case_Item_Of; ------------------------- -- Set_First_Choice_Of -- ------------------------- procedure Set_First_Choice_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item); In_Tree.Project_Nodes.Table (Node).Field1 := To; end Set_First_Choice_Of; ----------------------------- -- Set_First_Comment_After -- ----------------------------- procedure Set_First_Comment_After (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is Zone : constant Project_Node_Id := Comment_Zones_Of (Node, In_Tree); begin In_Tree.Project_Nodes.Table (Zone).Field2 := To; end Set_First_Comment_After; --------------------------------- -- Set_First_Comment_After_End -- --------------------------------- procedure Set_First_Comment_After_End (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is Zone : constant Project_Node_Id := Comment_Zones_Of (Node, In_Tree); begin In_Tree.Project_Nodes.Table (Zone).Comments := To; end Set_First_Comment_After_End; ------------------------------ -- Set_First_Comment_Before -- ------------------------------ procedure Set_First_Comment_Before (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is Zone : constant Project_Node_Id := Comment_Zones_Of (Node, In_Tree); begin In_Tree.Project_Nodes.Table (Zone).Field1 := To; end Set_First_Comment_Before; ---------------------------------- -- Set_First_Comment_Before_End -- ---------------------------------- procedure Set_First_Comment_Before_End (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is Zone : constant Project_Node_Id := Comment_Zones_Of (Node, In_Tree); begin In_Tree.Project_Nodes.Table (Zone).Field2 := To; end Set_First_Comment_Before_End; ------------------------ -- Set_Next_Case_Item -- ------------------------ procedure Set_Next_Case_Item (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item); In_Tree.Project_Nodes.Table (Node).Field3 := To; end Set_Next_Case_Item; ---------------------- -- Set_Next_Comment -- ---------------------- procedure Set_Next_Comment (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Comment); In_Tree.Project_Nodes.Table (Node).Comments := To; end Set_Next_Comment; ----------------------------------- -- Set_First_Declarative_Item_Of -- ----------------------------------- procedure Set_First_Declarative_Item_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_Project_Declaration | N_Case_Item | N_Package_Declaration); if In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration then In_Tree.Project_Nodes.Table (Node).Field1 := To; else In_Tree.Project_Nodes.Table (Node).Field2 := To; end if; end Set_First_Declarative_Item_Of; ---------------------------------- -- Set_First_Expression_In_List -- ---------------------------------- procedure Set_First_Expression_In_List (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String_List); In_Tree.Project_Nodes.Table (Node).Field1 := To; end Set_First_Expression_In_List; ------------------------------ -- Set_First_Literal_String -- ------------------------------ procedure Set_First_Literal_String (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_String_Type_Declaration); In_Tree.Project_Nodes.Table (Node).Field1 := To; end Set_First_Literal_String; -------------------------- -- Set_First_Package_Of -- -------------------------- procedure Set_First_Package_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Package_Declaration_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); In_Tree.Project_Nodes.Table (Node).Packages := To; end Set_First_Package_Of; ------------------------------ -- Set_First_String_Type_Of -- ------------------------------ procedure Set_First_String_Type_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); In_Tree.Project_Nodes.Table (Node).Field3 := To; end Set_First_String_Type_Of; -------------------- -- Set_First_Term -- -------------------- procedure Set_First_Term (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Expression); In_Tree.Project_Nodes.Table (Node).Field1 := To; end Set_First_Term; --------------------------- -- Set_First_Variable_Of -- --------------------------- procedure Set_First_Variable_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Variable_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_Project | N_Package_Declaration); In_Tree.Project_Nodes.Table (Node).Variables := To; end Set_First_Variable_Of; ------------------------------ -- Set_First_With_Clause_Of -- ------------------------------ procedure Set_First_With_Clause_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); In_Tree.Project_Nodes.Table (Node).Field1 := To; end Set_First_With_Clause_Of; -------------------------- -- Set_Is_Extending_All -- -------------------------- procedure Set_Is_Extending_All (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_Project | N_With_Clause); In_Tree.Project_Nodes.Table (Node).Flag2 := True; end Set_Is_Extending_All; ----------------------------- -- Set_Is_Not_Last_In_List -- ----------------------------- procedure Set_Is_Not_Last_In_List (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause); In_Tree.Project_Nodes.Table (Node).Flag1 := True; end Set_Is_Not_Last_In_List; ----------------- -- Set_Kind_Of -- ----------------- procedure Set_Kind_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Kind) is begin pragma Assert (Present (Node)); In_Tree.Project_Nodes.Table (Node).Kind := To; end Set_Kind_Of; --------------------- -- Set_Location_Of -- --------------------- procedure Set_Location_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Source_Ptr) is begin pragma Assert (Present (Node)); In_Tree.Project_Nodes.Table (Node).Location := To; end Set_Location_Of; ----------------------------- -- Set_Extended_Project_Of -- ----------------------------- procedure Set_Extended_Project_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration); In_Tree.Project_Nodes.Table (Node).Field2 := To; end Set_Extended_Project_Of; ---------------------------------- -- Set_Extended_Project_Path_Of -- ---------------------------------- procedure Set_Extended_Project_Path_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Path_Name_Type) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); In_Tree.Project_Nodes.Table (Node).Value := Name_Id (To); end Set_Extended_Project_Path_Of; ------------------------------ -- Set_Extending_Project_Of -- ------------------------------ procedure Set_Extending_Project_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration); In_Tree.Project_Nodes.Table (Node).Field3 := To; end Set_Extending_Project_Of; ----------------- -- Set_Name_Of -- ----------------- procedure Set_Name_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Name_Id) is begin pragma Assert (Present (Node)); In_Tree.Project_Nodes.Table (Node).Name := To; end Set_Name_Of; ------------------------- -- Set_Display_Name_Of -- ------------------------- procedure Set_Display_Name_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Name_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); In_Tree.Project_Nodes.Table (Node).Display_Name := To; end Set_Display_Name_Of; -------------------------------- -- Set_Is_Config_Concatenable -- -------------------------------- procedure Set_Is_Config_Concatenable (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Boolean) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_Attribute_Declaration | N_Attribute_Reference); In_Tree.Project_Nodes.Table (Node).Flag2 := To; end Set_Is_Config_Concatenable; ------------------------------- -- Set_Next_Declarative_Item -- ------------------------------- procedure Set_Next_Declarative_Item (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Declarative_Item); In_Tree.Project_Nodes.Table (Node).Field2 := To; end Set_Next_Declarative_Item; ----------------------- -- Set_Next_End_Node -- ----------------------- procedure Set_Next_End_Node (To : Project_Node_Id) is begin Next_End_Nodes.Increment_Last; Next_End_Nodes.Table (Next_End_Nodes.Last) := To; end Set_Next_End_Node; --------------------------------- -- Set_Next_Expression_In_List -- --------------------------------- procedure Set_Next_Expression_In_List (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Expression); In_Tree.Project_Nodes.Table (Node).Field2 := To; end Set_Next_Expression_In_List; ----------------------------- -- Set_Next_Literal_String -- ----------------------------- procedure Set_Next_Literal_String (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String); In_Tree.Project_Nodes.Table (Node).Field1 := To; end Set_Next_Literal_String; --------------------------------- -- Set_Next_Package_In_Project -- --------------------------------- procedure Set_Next_Package_In_Project (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); In_Tree.Project_Nodes.Table (Node).Field3 := To; end Set_Next_Package_In_Project; -------------------------- -- Set_Next_String_Type -- -------------------------- procedure Set_Next_String_Type (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_String_Type_Declaration); In_Tree.Project_Nodes.Table (Node).Field2 := To; end Set_Next_String_Type; ------------------- -- Set_Next_Term -- ------------------- procedure Set_Next_Term (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Term); In_Tree.Project_Nodes.Table (Node).Field2 := To; end Set_Next_Term; ----------------------- -- Set_Next_Variable -- ----------------------- procedure Set_Next_Variable (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_Typed_Variable_Declaration | N_Variable_Declaration); In_Tree.Project_Nodes.Table (Node).Field3 := To; end Set_Next_Variable; ----------------------------- -- Set_Next_With_Clause_Of -- ----------------------------- procedure Set_Next_With_Clause_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause); In_Tree.Project_Nodes.Table (Node).Field2 := To; end Set_Next_With_Clause_Of; ----------------------- -- Set_Package_Id_Of -- ----------------------- procedure Set_Package_Id_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Package_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); In_Tree.Project_Nodes.Table (Node).Pkg_Id := To; end Set_Package_Id_Of; ------------------------- -- Set_Package_Node_Of -- ------------------------- procedure Set_Package_Node_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_Variable_Reference | N_Attribute_Reference); In_Tree.Project_Nodes.Table (Node).Field2 := To; end Set_Package_Node_Of; ---------------------- -- Set_Path_Name_Of -- ---------------------- procedure Set_Path_Name_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Path_Name_Type) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_Project | N_With_Clause); In_Tree.Project_Nodes.Table (Node).Path_Name := To; end Set_Path_Name_Of; --------------------------- -- Set_Previous_End_Node -- --------------------------- procedure Set_Previous_End_Node (To : Project_Node_Id) is begin Previous_End_Node := To; end Set_Previous_End_Node; ---------------------------- -- Set_Previous_Line_Node -- ---------------------------- procedure Set_Previous_Line_Node (To : Project_Node_Id) is begin Previous_Line_Node := To; end Set_Previous_Line_Node; -------------------------------- -- Set_Project_Declaration_Of -- -------------------------------- procedure Set_Project_Declaration_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); In_Tree.Project_Nodes.Table (Node).Field2 := To; end Set_Project_Declaration_Of; ------------------------------ -- Set_Project_Qualifier_Of -- ------------------------------ procedure Set_Project_Qualifier_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Qualifier) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); In_Tree.Project_Nodes.Table (Node).Qualifier := To; end Set_Project_Qualifier_Of; --------------------------- -- Set_Parent_Project_Of -- --------------------------- procedure Set_Parent_Project_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project); In_Tree.Project_Nodes.Table (Node).Field4 := To; end Set_Parent_Project_Of; ----------------------------------------------- -- Set_Project_File_Includes_Unkept_Comments -- ----------------------------------------------- procedure Set_Project_File_Includes_Unkept_Comments (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Boolean) is Declaration : constant Project_Node_Id := Project_Declaration_Of (Node, In_Tree); begin In_Tree.Project_Nodes.Table (Declaration).Flag1 := To; end Set_Project_File_Includes_Unkept_Comments; ------------------------- -- Set_Project_Node_Of -- ------------------------- procedure Set_Project_Node_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id; Limited_With : Boolean := False) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_With_Clause | N_Variable_Reference | N_Attribute_Reference | N_String_Type_Declaration | N_Typed_Variable_Declaration); declare The_Node : Project_Node_Record renames In_Tree.Project_Nodes.Table (Node); begin case The_Node.Kind is when N_With_Clause => The_Node.Field1 := To; if not Limited_With then The_Node.Field3 := To; end if; when N_Variable_Reference | N_Attribute_Reference => The_Node.Field1 := To; when N_String_Type_Declaration => The_Node.Field3 := To; when N_Typed_Variable_Declaration => The_Node.Field4 := To; when others => null; end case; end; end Set_Project_Node_Of; --------------------------------------- -- Set_Project_Of_Renamed_Package_Of -- --------------------------------------- procedure Set_Project_Of_Renamed_Package_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration); In_Tree.Project_Nodes.Table (Node).Field1 := To; end Set_Project_Of_Renamed_Package_Of; ------------------------- -- Set_Source_Index_Of -- ------------------------- procedure Set_Source_Index_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Int) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_Literal_String | N_Attribute_Declaration); In_Tree.Project_Nodes.Table (Node).Src_Index := To; end Set_Source_Index_Of; ------------------------ -- Set_String_Type_Of -- ------------------------ procedure Set_String_Type_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_Variable_Reference | N_Typed_Variable_Declaration | N_String_Type_Declaration); if In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference then In_Tree.Project_Nodes.Table (Node).Field3 := To; else In_Tree.Project_Nodes.Table (Node).Field2 := To; end if; end Set_String_Type_Of; ------------------------- -- Set_String_Value_Of -- ------------------------- procedure Set_String_Value_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Name_Id) is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_With_Clause | N_Comment | N_Literal_String); In_Tree.Project_Nodes.Table (Node).Value := To; end Set_String_Value_Of; --------------------- -- Source_Index_Of -- --------------------- function Source_Index_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Int is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_Literal_String | N_Attribute_Declaration); return In_Tree.Project_Nodes.Table (Node).Src_Index; end Source_Index_Of; -------------------- -- String_Type_Of -- -------------------- function String_Type_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_Variable_Reference | N_Typed_Variable_Declaration); if In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference then return In_Tree.Project_Nodes.Table (Node).Field3; else return In_Tree.Project_Nodes.Table (Node).Field2; end if; end String_Type_Of; --------------------- -- String_Value_Of -- --------------------- function String_Value_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Name_Id is begin pragma Assert (Present (Node) and then In_Tree.Project_Nodes.Table (Node).Kind in N_With_Clause | N_Comment | N_Literal_String); return In_Tree.Project_Nodes.Table (Node).Value; end String_Value_Of; -------------------- -- Value_Is_Valid -- -------------------- function Value_Is_Valid (For_Typed_Variable : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; Value : Name_Id) return Boolean is begin pragma Assert (Present (For_Typed_Variable) and then In_Tree.Project_Nodes.Table (For_Typed_Variable).Kind = N_Typed_Variable_Declaration); declare Current_String : Project_Node_Id := First_Literal_String (String_Type_Of (For_Typed_Variable, In_Tree), In_Tree); begin while Present (Current_String) and then String_Value_Of (Current_String, In_Tree) /= Value loop Current_String := Next_Literal_String (Current_String, In_Tree); end loop; return Present (Current_String); end; end Value_Is_Valid; ------------------------------- -- There_Are_Unkept_Comments -- ------------------------------- function There_Are_Unkept_Comments return Boolean is begin return Unkept_Comments; end There_Are_Unkept_Comments; -------------------- -- Create_Project -- -------------------- function Create_Project (In_Tree : Project_Node_Tree_Ref; Name : Name_Id; Full_Path : Path_Name_Type; Is_Config_File : Boolean := False) return Project_Node_Id is Project : Project_Node_Id; Qualifier : Project_Qualifier := Unspecified; begin Project := Default_Project_Node (In_Tree, N_Project); Set_Name_Of (Project, In_Tree, Name); Set_Display_Name_Of (Project, In_Tree, Name); Set_Directory_Of (Project, In_Tree, Path_Name_Type (Get_Directory (File_Name_Type (Full_Path)))); Set_Path_Name_Of (Project, In_Tree, Full_Path); Set_Project_Declaration_Of (Project, In_Tree, Default_Project_Node (In_Tree, N_Project_Declaration)); if Is_Config_File then Qualifier := Configuration; end if; if not Is_Config_File then GPR.Tree_Private_Part.Projects_Htable.Set (In_Tree.Projects_HT, Name, GPR.Tree_Private_Part.Project_Name_And_Node' (Name => Name, Resolved_Path => No_Path, Node => Project, Extended => False, From_Extended => False, Proj_Qualifier => Qualifier)); end if; return Project; end Create_Project; ---------------- -- Add_At_End -- ---------------- procedure Add_At_End (Tree : Project_Node_Tree_Ref; Parent : Project_Node_Id; Expr : Project_Node_Id; Add_Before_First_Pkg : Boolean := False; Add_Before_First_Case : Boolean := False) is Real_Parent : Project_Node_Id; New_Decl, Decl, Next : Project_Node_Id; Last, L : Project_Node_Id; begin if Kind_Of (Expr, Tree) /= N_Declarative_Item then New_Decl := Default_Project_Node (Tree, N_Declarative_Item); Set_Current_Item_Node (New_Decl, Tree, Expr); else New_Decl := Expr; end if; if Kind_Of (Parent, Tree) = N_Project then Real_Parent := Project_Declaration_Of (Parent, Tree); else Real_Parent := Parent; end if; Decl := First_Declarative_Item_Of (Real_Parent, Tree); if No (Decl) then Set_First_Declarative_Item_Of (Real_Parent, Tree, New_Decl); else loop Next := Next_Declarative_Item (Decl, Tree); exit when No (Next) or else (Add_Before_First_Pkg and then Kind_Of (Current_Item_Node (Next, Tree), Tree) = N_Package_Declaration) or else (Add_Before_First_Case and then Kind_Of (Current_Item_Node (Next, Tree), Tree) = N_Case_Construction); Decl := Next; end loop; -- In case Expr is in fact a range of declarative items Last := New_Decl; loop L := Next_Declarative_Item (Last, Tree); exit when No (L); Last := L; end loop; -- In case Expr is in fact a range of declarative items Last := New_Decl; loop L := Next_Declarative_Item (Last, Tree); exit when No (L); Last := L; end loop; Set_Next_Declarative_Item (Last, Tree, Next); Set_Next_Declarative_Item (Decl, Tree, New_Decl); end if; end Add_At_End; --------------------------- -- Create_Literal_String -- --------------------------- function Create_Literal_String (Str : Name_Id; Tree : Project_Node_Tree_Ref) return Project_Node_Id is Node : Project_Node_Id; begin Node := Default_Project_Node (Tree, N_Literal_String, GPR.Single); Set_Next_Literal_String (Node, Tree, Empty_Project_Node); Set_String_Value_Of (Node, Tree, Str); return Node; end Create_Literal_String; --------------------------- -- Enclose_In_Expression -- --------------------------- function Enclose_In_Expression (Node : Project_Node_Id; Tree : Project_Node_Tree_Ref) return Project_Node_Id is Expr : Project_Node_Id; begin if Kind_Of (Node, Tree) /= N_Expression then Expr := Default_Project_Node (Tree, N_Expression, Single); Set_First_Term (Expr, Tree, Default_Project_Node (Tree, N_Term, Single)); Set_Current_Term (First_Term (Expr, Tree), Tree, Node); return Expr; else return Node; end if; end Enclose_In_Expression; -------------------- -- Create_Package -- -------------------- function Create_Package (Tree : Project_Node_Tree_Ref; Project : Project_Node_Id; Pkg : String) return Project_Node_Id is Pack : Project_Node_Id; N : Name_Id; begin Name_Len := Pkg'Length; Name_Buffer (1 .. Name_Len) := Pkg; N := Name_Find; -- Check if the package already exists Pack := First_Package_Of (Project, Tree); while Present (Pack) loop if GPR.Tree.Name_Of (Pack, Tree) = N then return Pack; end if; Pack := Next_Package_In_Project (Pack, Tree); end loop; -- Create the package and add it to the declarative item Pack := Default_Project_Node (Tree, N_Package_Declaration); Set_Name_Of (Pack, Tree, N); -- Find the correct package id to use Set_Package_Id_Of (Pack, Tree, Package_Node_Id_Of (N)); -- Add it to the list of packages Set_Next_Package_In_Project (Pack, Tree, First_Package_Of (Project, Tree)); Set_First_Package_Of (Project, Tree, Pack); Add_At_End (Tree, Project_Declaration_Of (Project, Tree), Pack); return Pack; end Create_Package; ---------------------- -- Create_Attribute -- ---------------------- function Create_Attribute (Tree : Project_Node_Tree_Ref; Prj_Or_Pkg : Project_Node_Id; Name : Name_Id; Index_Name : Name_Id := No_Name; Kind : Variable_Kind := List; At_Index : Integer := 0; Value : Project_Node_Id := Empty_Project_Node) return Project_Node_Id is Node : constant Project_Node_Id := Default_Project_Node (Tree, N_Attribute_Declaration, Kind); Case_Insensitive : Boolean; Pkg : Package_Node_Id; Start_At : Attribute_Node_Id; Expr : Project_Node_Id; begin Set_Name_Of (Node, Tree, Name); if Index_Name /= No_Name then Set_Associative_Array_Index_Of (Node, Tree, Index_Name); end if; if Present (Prj_Or_Pkg) then Add_At_End (Tree, Prj_Or_Pkg, Node); end if; -- Find out the case sensitivity of the attribute if Present (Prj_Or_Pkg) and then Kind_Of (Prj_Or_Pkg, Tree) = N_Package_Declaration then Pkg := GPR.Attr.Package_Node_Id_Of (Name_Of (Prj_Or_Pkg, Tree)); Start_At := First_Attribute_Of (Pkg); else Start_At := Attribute_First; end if; Start_At := Attribute_Node_Id_Of (Name, Start_At); Case_Insensitive := Attribute_Kind_Of (Start_At) = Case_Insensitive_Associative_Array; Tree.Project_Nodes.Table (Node).Flag1 := Case_Insensitive; if At_Index /= 0 then if Attribute_Kind_Of (Start_At) = Optional_Index_Associative_Array or else Attribute_Kind_Of (Start_At) = Optional_Index_Case_Insensitive_Associative_Array then -- Results in: for Name ("index" at index) use "value"; -- This is currently only used for executables. Set_Source_Index_Of (Node, Tree, To => Int (At_Index)); else -- Results in: for Name ("index") use "value" at index; -- ??? This limitation makes no sense, we should be able to -- set the source index on an expression. pragma Assert (Kind_Of (Value, Tree) = N_Literal_String); Set_Source_Index_Of (Value, Tree, To => Int (At_Index)); end if; end if; if Present (Value) then Expr := Enclose_In_Expression (Value, Tree); Set_Expression_Of (Node, Tree, Expr); end if; return Node; end Create_Attribute; end GPR.Tree; gprbuild-25.0.0/gpr/src/gpr-tree.ads000066400000000000000000001232551470075373400172250ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2017, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package defines the structure of the Project File tree with GNAT.Table; with GPR.Env; with GPR.Ext; package GPR.Tree is subtype Project_Node_Tree_Ref is GPR.Project_Node_Tree_Ref; ----------------- -- Environment -- ----------------- -- The following record contains the context in which projects are parsed -- and processed (finding importing project, resolving external values,..). type Environment is record External : GPR.Ext.External_References; -- External references are stored in this hash table (and manipulated -- through subprograms in prj-ext.ads). External references are -- project-tree specific so that one can load the same tree twice but -- have two views of it, for instance. Project_Path : aliased GPR.Env.Project_Search_Path; -- The project path is tree specific, since we might want to load -- simultaneously multiple projects, each with its own search path, in -- particular when using different compilers with different default -- search directories. Flags : Processing_Flags; -- Configure errors and warnings end record; procedure Initialize (Self : out Environment; Flags : Processing_Flags); -- Initialize a new environment procedure Initialize_And_Copy (Self : out Environment; Copy_From : Environment); -- Initialize a new environment, copying its values from Copy_From procedure Free (Self : in out Environment); -- Free the memory used by Self procedure Override_Flags (Self : in out Environment; Flags : Processing_Flags); -- Override the subprogram called in case there are parsing errors. This -- is needed in applications that do their own error handling, since the -- error handler is likely to be a local subprogram in this case (which -- can't be stored when the flags are created). function Present (Node : Project_Node_Id) return Boolean; pragma Inline (Present); -- Return True if Node /= Empty_Node function No (Node : Project_Node_Id) return Boolean; pragma Inline (No); -- Return True if Node = Empty_Node procedure Initialize (Tree : Project_Node_Tree_Ref); -- Initialize the Project File tree: empty the Project_Nodes table -- and reset the Projects_Htable. function Default_Project_Node (In_Tree : Project_Node_Tree_Ref; Of_Kind : Project_Node_Kind; And_Expr_Kind : Variable_Kind := Undefined) return Project_Node_Id; -- Returns a Project_Node_Record with the specified Kind and Expr_Kind. All -- the other components have default nil values. -- To create a node for a project itself, see Create_Project below instead function Hash (N : Project_Node_Id) return Header_Num; -- Used for hash tables where the key is a Project_Node_Id function Imported_Or_Extended_Project_Of (Project : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; With_Name : Name_Id) return Project_Node_Id; -- Return the node of a project imported or extended by project Project and -- whose name is With_Name. Return Empty_Node if there is no such project. -------------- -- Comments -- -------------- type Comment_State is private; -- A type to store the values of several global variables related to -- comments. procedure Save (S : out Comment_State); -- Save in variable S the comment state. Called before scanning a new -- project file. procedure Restore_And_Free (S : in out Comment_State); -- Restore the comment state to a previously saved value. Called after -- scanning a project file. Frees the memory occupied by S procedure Reset_State; -- Set the comment state to its initial value. Called before scanning a -- new project file. function There_Are_Unkept_Comments return Boolean; -- Indicates that some of the comments in a project file could not be -- stored in the parse tree. procedure Set_Previous_Line_Node (To : Project_Node_Id); -- Indicate the node on the previous line. If there are comments -- immediately following this line, then they should be associated with -- this node. procedure Set_Previous_End_Node (To : Project_Node_Id); -- Indicate that on the previous line the "end" belongs to node To. -- If there are comments immediately following this "end" line, they -- should be associated with this node. procedure Set_End_Of_Line (To : Project_Node_Id); -- Indicate the node on the current line. If there is an end of line -- comment, then it should be associated with this node. procedure Set_Next_End_Node (To : Project_Node_Id); -- Put node To on the top of the end node stack. When an END line is found -- with this node on the top of the end node stack, the comments, if any, -- immediately preceding this "end" line will be associated with this node. procedure Remove_Next_End_Node; -- Remove the top of the end node stack ------------------------ -- Comment Processing -- ------------------------ type Comment_Data is record Value : Name_Id := No_Name; Follows_Empty_Line : Boolean := False; Is_Followed_By_Empty_Line : Boolean := False; end record; -- Component type for Comments Table below package Comments is new GNAT.Table (Table_Component_Type => Comment_Data, Table_Index_Type => Natural, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 100); -- A table to store the comments that may be stored is the tree procedure Scan (In_Tree : Project_Node_Tree_Ref); -- Scan the tokens and accumulate comments type Comment_Location is (Before, After, Before_End, After_End, End_Of_Line); -- Used in call to Add_Comments below procedure Add_Comments (To : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; Where : Comment_Location); -- Add comments to this node ---------------------- -- Access Functions -- ---------------------- -- The following query functions are part of the abstract interface -- of the Project File tree. They provide access to fields of a project. -- The access functions should be called only with valid arguments. -- For each function the condition of validity is specified. If an access -- function is called with invalid arguments, then exception -- Assertion_Error is raised if assertions are enabled, otherwise the -- behaviour is not defined and may result in a crash. function Name_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Name_Id; pragma Inline (Name_Of); -- Valid for all non empty nodes. May return No_Name for nodes that have -- no names. function Display_Name_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Name_Id; pragma Inline (Display_Name_Of); -- Valid only for N_Project node. Returns the display name of the project. function Kind_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Kind; pragma Inline (Kind_Of); -- Valid for all non empty nodes function Location_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Source_Ptr; pragma Inline (Location_Of); -- Valid for all non empty nodes function First_Comment_After (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; -- Valid only for N_Comment_Zones nodes function First_Comment_After_End (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; -- Valid only for N_Comment_Zones nodes function First_Comment_Before (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; -- Valid only for N_Comment_Zones nodes function First_Comment_Before_End (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; -- Valid only for N_Comment_Zones nodes function Next_Comment (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; -- Valid only for N_Comment nodes function End_Of_Line_Comment (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Name_Id; -- Valid only for non empty nodes function Follows_Empty_Line (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Boolean; -- Valid only for N_Comment nodes function Is_Followed_By_Empty_Line (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Boolean; -- Valid only for N_Comment nodes function Parent_Project_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (Parent_Project_Of); -- Valid only for N_Project nodes function Project_File_Includes_Unkept_Comments (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Boolean; -- Valid only for N_Project nodes function Directory_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Path_Name_Type; pragma Inline (Directory_Of); -- Returns the directory that contains the project file. This always ends -- with a directory separator. Only valid for N_Project nodes. function Expression_Kind_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Variable_Kind; pragma Inline (Expression_Kind_Of); -- Only valid for N_Literal_String, N_Attribute_Declaration, -- N_Variable_Declaration, N_Typed_Variable_Declaration, N_Expression, -- N_Term, N_Variable_Reference, N_Attribute_Reference nodes or -- N_External_Value. function Is_Extending_All (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Boolean; pragma Inline (Is_Extending_All); -- Only valid for N_Project and N_With_Clause function Is_Not_Last_In_List (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Boolean; pragma Inline (Is_Not_Last_In_List); -- Only valid for N_With_Clause function First_Variable_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Variable_Node_Id; pragma Inline (First_Variable_Of); -- Only valid for N_Project or N_Package_Declaration nodes function First_Package_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Package_Declaration_Id; pragma Inline (First_Package_Of); -- Only valid for N_Project nodes function Package_Id_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Package_Node_Id; pragma Inline (Package_Id_Of); -- Only valid for N_Package_Declaration nodes function Path_Name_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Path_Name_Type; pragma Inline (Path_Name_Of); -- Only valid for N_Project and N_With_Clause nodes function String_Value_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Name_Id; pragma Inline (String_Value_Of); -- Only valid for N_With_Clause, N_Literal_String nodes or N_Comment. -- For a N_With_Clause created automatically for a virtual extending -- project, No_Name is returned. function Source_Index_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Int; pragma Inline (Source_Index_Of); -- Only valid for N_Literal_String and N_Attribute_Declaration nodes function First_With_Clause_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (First_With_Clause_Of); -- Only valid for N_Project nodes function Project_Declaration_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (Project_Declaration_Of); -- Only valid for N_Project nodes function Project_Qualifier_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Qualifier; pragma Inline (Project_Qualifier_Of); -- Only valid for N_Project nodes function Extending_Project_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (Extending_Project_Of); -- Only valid for N_Project_Declaration nodes function First_String_Type_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (First_String_Type_Of); -- Only valid for N_Project nodes function Extended_Project_Path_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Path_Name_Type; pragma Inline (Extended_Project_Path_Of); -- Only valid for N_With_Clause nodes function Project_Node_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (Project_Node_Of); -- Only valid for N_With_Clause, N_Variable_Reference, -- N_Attribute_Reference, N_String_Type_Declaration and -- N_Typed_Variable_Declaration nodes. function Non_Limited_Project_Node_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (Non_Limited_Project_Node_Of); -- Only valid for N_With_Clause nodes. Returns Empty_Node for limited -- imported project files, otherwise returns the same result as -- Project_Node_Of. function Next_With_Clause_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (Next_With_Clause_Of); -- Only valid for N_With_Clause nodes function First_Declarative_Item_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (First_Declarative_Item_Of); -- Only valid for N_Project_Declaration, N_Case_Item and -- N_Package_Declaration. function Extended_Project_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (Extended_Project_Of); -- Only valid for N_Project_Declaration nodes function Current_Item_Node (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (Current_Item_Node); -- Only valid for N_Declarative_Item nodes function Next_Declarative_Item (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (Next_Declarative_Item); -- Only valid for N_Declarative_Item node function Project_Of_Renamed_Package_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (Project_Of_Renamed_Package_Of); -- Only valid for N_Package_Declaration nodes. May return Empty_Node. function Next_Package_In_Project (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (Next_Package_In_Project); -- Only valid for N_Package_Declaration nodes function First_Literal_String (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (First_Literal_String); -- Only valid for N_String_Type_Declaration nodes function Next_String_Type (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (Next_String_Type); -- Only valid for N_String_Type_Declaration nodes function Next_Literal_String (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (Next_Literal_String); -- Only valid for N_Literal_String nodes function Expression_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (Expression_Of); -- Only valid for N_Attribute_Declaration, N_Typed_Variable_Declaration -- or N_Variable_Declaration nodes function Associative_Project_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (Associative_Project_Of); -- Only valid for N_Attribute_Declaration nodes function Associative_Package_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (Associative_Package_Of); -- Only valid for N_Attribute_Declaration nodes function Value_Is_Valid (For_Typed_Variable : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; Value : Name_Id) return Boolean; pragma Inline (Value_Is_Valid); -- Only valid for N_Typed_Variable_Declaration. Returns True if Value is -- in the list of allowed strings for For_Typed_Variable. False otherwise. function Associative_Array_Index_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Name_Id; pragma Inline (Associative_Array_Index_Of); -- Only valid for N_Attribute_Declaration and N_Attribute_Reference. -- Returns No_Name for non associative array attributes. function Next_Variable (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (Next_Variable); -- Only valid for N_Typed_Variable_Declaration or N_Variable_Declaration -- nodes. function First_Term (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (First_Term); -- Only valid for N_Expression nodes function Next_Expression_In_List (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (Next_Expression_In_List); -- Only valid for N_Expression nodes function Current_Term (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (Current_Term); -- Only valid for N_Term nodes function Next_Term (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (Next_Term); -- Only valid for N_Term nodes function First_Expression_In_List (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (First_Expression_In_List); -- Only valid for N_Literal_String_List nodes function Package_Node_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (Package_Node_Of); -- Only valid for N_Variable_Reference or N_Attribute_Reference nodes. -- May return Empty_Node. function Default_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Attribute_Default_Value; pragma Inline (Default_Of); -- Only valid for N_Attribute_Reference nodes function String_Type_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (String_Type_Of); -- Only valid for N_Variable_Reference or N_Typed_Variable_Declaration -- nodes. function External_Reference_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (External_Reference_Of); -- Only valid for N_External_Value nodes function External_Default_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (External_Default_Of); -- Only valid for N_External_Value nodes function String_Argument_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (String_Argument_Of); -- Only valid for N_Split nodes function Separator_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (Separator_Of); -- Only valid for N_Split nodes function Case_Variable_Reference_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (Case_Variable_Reference_Of); -- Only valid for N_Case_Construction nodes function First_Case_Item_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (First_Case_Item_Of); -- Only valid for N_Case_Construction nodes function First_Choice_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (First_Choice_Of); -- Only valid for N_Case_Item nodes. Return the first choice in a -- N_Case_Item, or Empty_Node if this is when others. function Is_Config_Concatenable (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Boolean; pragma Inline (Is_Config_Concatenable); -- Only valid for N_Attribute_Declaration and N_Attribute_Reference function Next_Case_Item (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Project_Node_Id; pragma Inline (Next_Case_Item); -- Only valid for N_Case_Item nodes function Case_Insensitive (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref) return Boolean; -- Only valid for N_Attribute_Declaration and N_Attribute_Reference nodes ----------------------- -- Create procedures -- ----------------------- -- The following procedures are used to edit a project file tree. They are -- slightly higher-level than the Set_* procedures below function Create_Project (In_Tree : Project_Node_Tree_Ref; Name : Name_Id; Full_Path : Path_Name_Type; Is_Config_File : Boolean := False) return Project_Node_Id; -- Create a new node for a project and register it in the tree so that it -- can be retrieved later on. function Create_Package (Tree : Project_Node_Tree_Ref; Project : Project_Node_Id; Pkg : String) return Project_Node_Id; -- Create a new package in Project. If the package already exists, it is -- returned. The name of the package *must* be lower-cases, or none of its -- attributes will be recognized. function Create_Attribute (Tree : Project_Node_Tree_Ref; Prj_Or_Pkg : Project_Node_Id; Name : Name_Id; Index_Name : Name_Id := No_Name; Kind : Variable_Kind := List; At_Index : Integer := 0; Value : Project_Node_Id := Empty_Project_Node) return Project_Node_Id; -- Create a new attribute. The new declaration is added at the end of the -- declarative item list for Prj_Or_Pkg (a project or a package), but -- before any package declaration). No addition is done if Prj_Or_Pkg is -- Empty_Node. If Index_Name is not "", then if creates an attribute value -- for a specific index. At_Index is used for the " at " in the naming -- exceptions. -- -- To set the value of the attribute, either provide a value for Value, or -- use Set_Expression_Of to set the value of the attribute (in which case -- Enclose_In_Expression might be useful). The former is recommended since -- it will more correctly handle cases where the index needs to be set on -- the expression rather than on the index of the attribute (i.e. 'for -- Specification ("unit") use "file" at 3', versus 'for Executable ("file" -- at 3) use "name"'). Value must be a N_String_Literal if an index will be -- added to it. function Create_Literal_String (Str : Name_Id; Tree : Project_Node_Tree_Ref) return Project_Node_Id; -- Create a literal string whose value is Str procedure Add_At_End (Tree : Project_Node_Tree_Ref; Parent : Project_Node_Id; Expr : Project_Node_Id; Add_Before_First_Pkg : Boolean := False; Add_Before_First_Case : Boolean := False); -- Add a new declarative item in the list in Parent. This new declarative -- item will contain Expr (unless Expr is already a declarative item, in -- which case it is added directly to the list). The new item is inserted -- at the end of the list, unless Add_Before_First_Pkg is True. In the -- latter case, it is added just before the first case construction is -- seen, or before the first package (this assumes that all packages are -- found at the end of the project, which isn't true in the general case -- unless you have normalized the project to match this description). function Enclose_In_Expression (Node : Project_Node_Id; Tree : Project_Node_Tree_Ref) return Project_Node_Id; -- Enclose the Node inside a N_Expression node, and return this expression. -- This does nothing if Node is already a N_Expression. -------------------- -- Set Procedures -- -------------------- -- The following procedures are part of the abstract interface of the -- Project File tree. -- Foe each Set_* procedure the condition of validity is specified. If an -- access function is called with invalid arguments, then exception -- Assertion_Error is raised if assertions are enabled, otherwise the -- behaviour is not defined and may result in a crash. -- These are very low-level, and manipulate the tree itself directly. You -- should look at the Create_* procedure instead if you want to use higher -- level constructs procedure Set_Name_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Name_Id); pragma Inline (Set_Name_Of); -- Valid for all non empty nodes procedure Set_Display_Name_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Name_Id); pragma Inline (Set_Display_Name_Of); -- Valid only for N_Project nodes procedure Set_Kind_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Kind); pragma Inline (Set_Kind_Of); -- Valid for all non empty nodes procedure Set_Location_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Source_Ptr); pragma Inline (Set_Location_Of); -- Valid for all non empty nodes procedure Set_First_Comment_After (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Comment_After); -- Valid only for N_Comment_Zones nodes procedure Set_First_Comment_After_End (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Comment_After_End); -- Valid only for N_Comment_Zones nodes procedure Set_First_Comment_Before (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Comment_Before); -- Valid only for N_Comment_Zones nodes procedure Set_First_Comment_Before_End (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Comment_Before_End); -- Valid only for N_Comment_Zones nodes procedure Set_Next_Comment (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_Comment); -- Valid only for N_Comment nodes procedure Set_Parent_Project_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); -- Valid only for N_Project nodes procedure Set_Project_File_Includes_Unkept_Comments (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Boolean); -- Valid only for N_Project nodes procedure Set_Directory_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Path_Name_Type); pragma Inline (Set_Directory_Of); -- Valid only for N_Project nodes procedure Set_Expression_Kind_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Variable_Kind); pragma Inline (Set_Expression_Kind_Of); -- Only valid for N_Literal_String, N_Attribute_Declaration, -- N_Variable_Declaration, N_Typed_Variable_Declaration, N_Expression, -- N_Term, N_Variable_Reference, N_Attribute_Reference or N_External_Value -- nodes. procedure Set_Is_Extending_All (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref); pragma Inline (Set_Is_Extending_All); -- Only valid for N_Project and N_With_Clause procedure Set_Is_Not_Last_In_List (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref); pragma Inline (Set_Is_Not_Last_In_List); -- Only valid for N_With_Clause procedure Set_First_Variable_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Variable_Node_Id); pragma Inline (Set_First_Variable_Of); -- Only valid for N_Project or N_Package_Declaration nodes procedure Set_First_Package_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Package_Declaration_Id); pragma Inline (Set_First_Package_Of); -- Only valid for N_Project nodes procedure Set_Package_Id_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Package_Node_Id); pragma Inline (Set_Package_Id_Of); -- Only valid for N_Package_Declaration nodes procedure Set_Path_Name_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Path_Name_Type); pragma Inline (Set_Path_Name_Of); -- Only valid for N_Project and N_With_Clause nodes procedure Set_String_Value_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Name_Id); pragma Inline (Set_String_Value_Of); -- Only valid for N_With_Clause, N_Literal_String nodes or N_Comment. procedure Set_Source_Index_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Int); pragma Inline (Set_Source_Index_Of); -- Only valid for N_Literal_String and N_Attribute_Declaration nodes. For -- N_Literal_String, set the source index of the literal string. For -- N_Attribute_Declaration, set the source index of the index of the -- associative array element. procedure Set_First_With_Clause_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_With_Clause_Of); -- Only valid for N_Project nodes procedure Set_Project_Declaration_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Project_Declaration_Of); -- Only valid for N_Project nodes procedure Set_Project_Qualifier_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Qualifier); pragma Inline (Set_Project_Qualifier_Of); -- Only valid for N_Project nodes procedure Set_Extending_Project_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Extending_Project_Of); -- Only valid for N_Project_Declaration nodes procedure Set_First_String_Type_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_String_Type_Of); -- Only valid for N_Project nodes procedure Set_Extended_Project_Path_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Path_Name_Type); pragma Inline (Set_Extended_Project_Path_Of); -- Only valid for N_With_Clause nodes procedure Set_Project_Node_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id; Limited_With : Boolean := False); pragma Inline (Set_Project_Node_Of); -- Only valid for N_With_Clause, N_Variable_Reference, -- N_Attribute_Reference, N_String_Type_Declaration and -- N_Typed_Variable_Declaration nodes. procedure Set_Next_With_Clause_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_With_Clause_Of); -- Only valid for N_With_Clause nodes procedure Set_First_Declarative_Item_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Declarative_Item_Of); -- Only valid for N_Project_Declaration, N_Case_Item and -- N_Package_Declaration. procedure Set_Extended_Project_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Extended_Project_Of); -- Only valid for N_Project_Declaration nodes procedure Set_Current_Item_Node (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Current_Item_Node); -- Only valid for N_Declarative_Item nodes procedure Set_Next_Declarative_Item (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_Declarative_Item); -- Only valid for N_Declarative_Item node procedure Set_Project_Of_Renamed_Package_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Project_Of_Renamed_Package_Of); -- Only valid for N_Package_Declaration nodes. procedure Set_Next_Package_In_Project (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_Package_In_Project); -- Only valid for N_Package_Declaration nodes procedure Set_First_Literal_String (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Literal_String); -- Only valid for N_String_Type_Declaration nodes procedure Set_Next_String_Type (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_String_Type); -- Only valid for N_String_Type_Declaration nodes procedure Set_Next_Literal_String (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_Literal_String); -- Only valid for N_Literal_String nodes procedure Set_Expression_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Expression_Of); -- Only valid for N_Attribute_Declaration, N_Typed_Variable_Declaration -- or N_Variable_Declaration nodes procedure Set_Associative_Project_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Associative_Project_Of); -- Only valid for N_Attribute_Declaration nodes procedure Set_Associative_Package_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Associative_Package_Of); -- Only valid for N_Attribute_Declaration nodes procedure Set_Associative_Array_Index_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Name_Id); pragma Inline (Set_Associative_Array_Index_Of); -- Only valid for N_Attribute_Declaration and N_Attribute_Reference. procedure Set_Next_Variable (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_Variable); -- Only valid for N_Typed_Variable_Declaration or N_Variable_Declaration -- nodes. procedure Set_First_Term (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Term); -- Only valid for N_Expression nodes procedure Set_Next_Expression_In_List (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_Expression_In_List); -- Only valid for N_Expression nodes procedure Set_Current_Term (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Current_Term); -- Only valid for N_Term nodes procedure Set_Next_Term (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_Term); -- Only valid for N_Term nodes procedure Set_First_Expression_In_List (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Expression_In_List); -- Only valid for N_Literal_String_List nodes procedure Set_Package_Node_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Package_Node_Of); -- Only valid for N_Variable_Reference or N_Attribute_Reference nodes procedure Set_Default_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Attribute_Default_Value); pragma Inline (Set_Default_Of); -- Only valid for N_Attribute_Reference nodes procedure Set_String_Type_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_String_Type_Of); -- Only valid for N_Variable_Reference or N_Typed_Variable_Declaration -- nodes. procedure Set_External_Reference_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_External_Reference_Of); -- Only valid for N_External_Value nodes procedure Set_External_Default_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_External_Default_Of); -- Only valid for N_External_Value nodes procedure Set_String_Argument_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_String_Argument_Of); -- Only valid for N_Split procedure Set_Separator_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Separator_Of); -- Only valid for N_Split procedure Set_Case_Variable_Reference_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Case_Variable_Reference_Of); -- Only valid for N_Case_Construction nodes procedure Set_First_Case_Item_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Case_Item_Of); -- Only valid for N_Case_Construction nodes procedure Set_Is_Config_Concatenable (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Boolean); pragma Inline (Set_Is_Config_Concatenable); -- Only valid for N_Attribute_Declaration and N_Attribute_Reference procedure Set_First_Choice_Of (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_First_Choice_Of); -- Only valid for N_Case_Item nodes. procedure Set_Next_Case_Item (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Project_Node_Id); pragma Inline (Set_Next_Case_Item); -- Only valid for N_Case_Item nodes. procedure Set_Case_Insensitive (Node : Project_Node_Id; In_Tree : Project_Node_Tree_Ref; To : Boolean); -- Only valid for N_Attribute_Declaration and N_Attribute_Reference nodes private type Comment_Array is array (Positive range <>) of Comment_Data; type Comments_Ptr is access Comment_Array; type Comment_State is record End_Of_Line_Node : Project_Node_Id := Empty_Project_Node; Previous_Line_Node : Project_Node_Id := Empty_Project_Node; Previous_End_Node : Project_Node_Id := Empty_Project_Node; Unkept_Comments : Boolean := False; Comments : Comments_Ptr := null; end record; end GPR.Tree; gprbuild-25.0.0/gpr/src/gpr-util-aux.adb000066400000000000000000000423611470075373400200130ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2017-2022, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; use Ada.Command_Line; with Ada.Directories; with Ada.Environment_Variables; use Ada.Environment_Variables; with Ada.Strings.Unbounded; with Ada.Text_IO; with GNAT.Regpat; use GNAT.Regpat; with GNAT.Sockets; with GPR.Names; use GPR.Names; with GPR.Opt; use GPR.Opt; with GPR.Tempdir; package body GPR.Util.Aux is -------------------------------- -- Create_Export_Symbols_File -- -------------------------------- procedure Create_Export_Symbols_File (Driver_Path : String; Options : Argument_List; Sym_Matcher : String; Format : Export_File_Format; Objects : String_List; Library_Symbol_File : String; Export_File_Name : out Path_Name_Type) is use Ada.Text_IO; use type Ada.Containers.Count_Type; package Syms_List renames String_Sets; procedure Get_Syms (Object_File : String); -- Read exported symbols from Object_File and add them into Syms procedure Write (Str : String); -- Write Str into the export file Pattern : constant Pattern_Matcher := Compile (Sym_Matcher); Syms : Syms_List.Set; FD : File_Descriptor; -------------- -- Get_Syms -- -------------- procedure Get_Syms (Object_File : String) is Success : Boolean; Ret : Integer; Opts : Argument_List (1 .. Options'Length + 1); File : File_Type; File_Name : Path_Name_Type; Matches : Match_Array (0 .. 1); function Filename return String is (Get_Name_String (File_Name)); -- Remove the ASCII.NUL from end of temporary file-name begin Opts (1 .. Options'Length) := Options; Opts (Opts'Last) := new String'(Object_File); GPR.Tempdir.Create_Temp_File (FD, File_Name); Record_Temp_File (null, File_Name); Close (FD); if Verbose_Mode then Put (Driver_Path); for O of Opts loop Put (' '); Put (O.all); end loop; New_Line; end if; Spawn (Driver_Path, Opts, Filename, Success, Ret); if Success then Open (File, In_File, Filename); while not End_Of_File (File) loop declare Buffer : constant String := Get_Line (File); begin Match (Pattern, Buffer, Matches); if Matches (1) /= No_Match then Syms.Include (Buffer (Matches (1).First .. Matches (1).Last)); end if; end; end loop; Close (File); end if; Free (Opts (Opts'Last)); end Get_Syms; ----------- -- Write -- ----------- procedure Write (Str : String) is S : constant String := Str & ASCII.LF; R : Integer with Unreferenced; begin R := Write (FD, S (S'First)'Address, S'Length); end Write; begin Export_File_Name := No_Path; if Format = None then return; end if; if Library_Symbol_File = "" then -- Get the exported symbols from every object files, first get the nm -- tool for the target. for K in Objects'Range loop Get_Syms (Objects (K).all); end loop; else -- Get the symbols from the symbol file, one symbol per line if Is_Readable_File (Library_Symbol_File) then declare File : File_Type; Line : String (1 .. 1_024); Last : Natural; begin Open (File, In_File, Library_Symbol_File); while not End_Of_File (File) loop Get_Line (File, Line, Last); if Last > 0 then Syms.Include (Line (1 .. Last)); end if; end loop; Close (File); end; else raise Constraint_Error with "unable to locate Library_Symbol_File""" & Library_Symbol_File & '"'; end if; end if; if Syms.Length = 0 then return; end if; -- Now create the export file, either GNU or DEF format Create_Export_File : declare File_Name : Path_Name_Type; Success : Boolean; begin -- Create (Export_File, Out_File); GPR.Tempdir.Create_Temp_File (FD, File_Name); Record_Temp_File (null, File_Name); Get_Name_String (File_Name); -- Always add .def at the end, this is needed for Windows Add_Str_To_Name_Buffer (".def"); Export_File_Name := Name_Find; Record_Temp_File (null, Export_File_Name); -- Header case Format is when GNU => Write ("SYMS {"); Write (" global:"); when Def => Write ("EXPORTS"); when None | Flat => null; end case; -- Symbols for Sym of Syms loop case Format is when GNU => Write (Sym & ";"); when Def | Flat => Write (Sym); when None => null; end case; end loop; -- Footer case Format is when GNU => Write (" local: *;"); Write ("};"); when None | Def | Flat => null; end case; Close (FD); Copy_File (Get_Name_String (File_Name), Get_Name_String (Export_File_Name), Success); if not Success then Fail_Program (null, "couldn't create an export file " & Get_Name_String (Export_File_Name)); end if; end Create_Export_File; end Create_Export_Symbols_File; -------------------------- -- Create_Response_File -- -------------------------- procedure Create_Response_File (Format : Response_File_Format; Objects : String_List; Other_Arguments : String_List; Resp_File_Options : String_List; Name_1 : out Path_Name_Type; Name_2 : out Path_Name_Type) is Objects_Vector : String_Vectors.Vector; Other_Args_Vector : String_Vectors.Vector; Resp_File_Options_Vector : String_Vectors.Vector; begin for J in Objects'Range loop Objects_Vector.Append (Objects (J).all); end loop; for J in Other_Arguments'Range loop Other_Args_Vector.Append (Other_Arguments (J).all); end loop; for J in Resp_File_Options'Range loop Resp_File_Options_Vector.Append (Resp_File_Options (J).all); end loop; Create_Response_File (Format, Objects_Vector, Other_Args_Vector, Resp_File_Options_Vector, Name_1, Name_2); end Create_Response_File; -------------------------- -- Create_Response_File -- -------------------------- procedure Create_Response_File (Format : Response_File_Format; Objects : String_Vectors.Vector; Other_Arguments : String_Vectors.Vector; Resp_File_Options : String_Vectors.Vector; Name_1 : out Path_Name_Type; Name_2 : out Path_Name_Type) is GNU_Header : aliased constant String := "INPUT ("; GNU_Opening : aliased constant String := """"; GNU_Closing : aliased constant String := '"' & ASCII.LF; GNU_Footer : aliased constant String := ')' & ASCII.LF; Resp_File : File_Descriptor; Status : Integer; pragma Warnings (Off, Status); Closing_Status : Boolean; pragma Warnings (Off, Closing_Status); function Modified_Argument (Arg : String) return String; -- If the argument includes a space, a backslash, or a double quote, -- escape the character with a preceding backsash. ----------------------- -- Modified_Argument -- ----------------------- function Modified_Argument (Arg : String) return String is Result : String (1 .. 2 * Arg'Length); Last : Natural := 0; procedure Add (C : Character); --------- -- Add -- --------- procedure Add (C : Character) is begin Last := Last + 1; Result (Last) := C; end Add; begin for J in Arg'Range loop if Arg (J) = '\' or else Arg (J) = ' ' or else Arg (J) = '"' then Add ('\'); end if; Add (Arg (J)); end loop; return Result (1 .. Last); end Modified_Argument; begin Name_2 := No_Path; Tempdir.Create_Temp_File (Resp_File, Name => Name_1); Record_Temp_File (null, Name_1); if Format = GNU or else Format = GCC_GNU then Status := Write (Resp_File, GNU_Header'Address, GNU_Header'Length); end if; for Object of Objects loop if Format = GNU or else Format = GCC_GNU then Status := Write (Resp_File, GNU_Opening'Address, GNU_Opening'Length); end if; Status := Write (Resp_File, Object (1)'Address, Object'Length); if Format = GNU or else Format = GCC_GNU then Status := Write (Resp_File, GNU_Closing'Address, GNU_Closing'Length); else Status := Write (Resp_File, ASCII.LF'Address, 1); end if; end loop; if Format = GNU or else Format = GCC_GNU then Status := Write (Resp_File, GNU_Footer'Address, GNU_Footer'Length); end if; case Format is when GCC_GNU | GCC_Object_List | GCC_Option_List => Close (Resp_File, Closing_Status); Name_2 := Name_1; Tempdir.Create_Temp_File (Resp_File, Name => Name_1); Record_Temp_File (null, Name_1); for Option of Resp_File_Options loop Status := Write (Resp_File, Option (1)'Address, Option'Length); if Option /= Resp_File_Options.Last_Element then Status := Write (Resp_File, ASCII.LF'Address, 1); end if; end loop; declare Arg : constant String := Modified_Argument (Get_Name_String (Name_2)); begin Status := Write (Resp_File, Arg (1)'Address, Arg'Length); end; Status := Write (Resp_File, ASCII.LF'Address, 1); when GCC => null; when others => Close (Resp_File, Closing_Status); end case; if Format = GCC or else Format = GCC_GNU or else Format = GCC_Object_List or else Format = GCC_Option_List then for Argument of Other_Arguments loop declare Arg : constant String := Modified_Argument (Argument); begin Status := Write (Resp_File, Arg (1)'Address, Arg'Length); end; Status := Write (Resp_File, ASCII.LF'Address, 1); end loop; Close (Resp_File, Closing_Status); end if; end Create_Response_File; ----------------------- -- Compute_Slave_Env -- ----------------------- function Compute_Slave_Env (Project : Project_Tree_Ref; Auto : Boolean) return String is User : String_Access := Getenv ("USER"); User_Name : String_Access := Getenv ("USERNAME"); Default : constant String := (if User = null then (if User_Name = null then "unknown" else User_Name.all) else User.all) & '@' & GNAT.Sockets.Host_Name; package S_Set renames String_Sets; Set : S_Set.Set; Ctx : Context; begin Free (User); Free (User_Name); if Auto then -- In this mode the slave environment is computed based on -- the project variable value and the command line arguments. -- First adds all command line arguments for K in 1 .. Argument_Count loop -- Skip arguments that are not changing the actual compilation and -- this will ensure that the same environment will be created for -- gprclean. if Argument (K) not in "-p" | "-d" | "-c" | "-q" and then (Argument (K)'Length < 2 or else Argument (K) (1 .. 2) /= "-j") then Set.Insert (Argument (K)); end if; end loop; -- Then all the global variables for the project tree for K in 1 .. Variable_Element_Table.Last (Project.Shared.Variable_Elements) loop declare V : constant Variable := Project.Shared.Variable_Elements.Table (K); begin if V.Value.Kind = Single then Set.Include (Get_Name_String (V.Name) & "=" & Get_Name_String (V.Value.Value)); end if; end; end loop; -- Compute the MD5 sum of the sorted elements in the set for S of Set loop Update (Ctx, S); end loop; return Default & "-" & Digest (Ctx); else -- Otherwise use the default & '@' & return Default; end if; end Compute_Slave_Env; ---------------------- -- Get_Slaves_Hosts -- ---------------------- function Get_Slaves_Hosts (Project_Tree : Project_Tree_Ref; Arg : String) return String is use Ada.Strings.Unbounded; Hosts : Unbounded_String; begin if Arg'Length > Distributed_Option'Length and then Arg (Arg'First + Distributed_Option'Length) = '=' then -- The hosts are specified on the command-line Hosts := To_Unbounded_String (Arg (Arg'First + Distributed_Option'Length + 1 .. Arg'Last)); elsif Environment_Variables.Exists ("GPR_SLAVES") then Hosts := To_Unbounded_String (Value ("GPR_SLAVES")); elsif Environment_Variables.Exists ("GPR_SLAVES_FILE") then declare F_Name : constant String := Value ("GPR_SLAVES_FILE"); F : Text_IO.File_Type; Buffer : String (1 .. 100); Last : Natural; begin if Directories.Exists (F_Name) then Text_IO.Open (F, Text_IO.In_File, F_Name); while not Text_IO.End_Of_File (F) loop Text_IO.Get_Line (F, Buffer, Last); if Last > 0 then if Hosts /= Null_Unbounded_String then Append (Hosts, ","); end if; Append (Hosts, Buffer (1 .. Last)); end if; end loop; Text_IO.Close (F); else Fail_Program (Project_Tree, "hosts distributed file " & F_Name & " not found", Exit_Code => E_General); end if; end; end if; return To_String (Hosts); end Get_Slaves_Hosts; end GPR.Util.Aux; gprbuild-25.0.0/gpr/src/gpr-util-aux.ads000066400000000000000000000106171470075373400200330ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2017-2019, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ package GPR.Util.Aux is procedure Create_Response_File (Format : Response_File_Format; Objects : String_Vectors.Vector; Other_Arguments : String_Vectors.Vector; Resp_File_Options : String_Vectors.Vector; Name_1 : out Path_Name_Type; Name_2 : out Path_Name_Type); -- Create a temporary file as a response file that contains either the list -- of Objects in the correct Format, or for Format GCC the list of all -- arguments. It is the responsibility of the caller to delete this -- temporary file if needed. procedure Create_Response_File (Format : Response_File_Format; Objects : String_List; Other_Arguments : String_List; Resp_File_Options : String_List; Name_1 : out Path_Name_Type; Name_2 : out Path_Name_Type); -- Same as above, but relying on String_List. Deprecated. procedure Create_Export_Symbols_File (Driver_Path : String; Options : Argument_List; Sym_Matcher : String; Format : Export_File_Format; Objects : String_List; Library_Symbol_File : String; Export_File_Name : out Path_Name_Type); -- Create an export symbols file for the linker. If Library_Symbol_File is -- defined the symbols will be read from this file (one per line) otherwise -- the symbols from the listed object files will get exported from a shared -- libraries. All other symbols will remain local to the shared library. -- Driver_Path is the tool used to list the symbols from an object file. -- Options are the options needed by the driver. Sym_Matcher is the regular -- expression used to match the symbol out of the tool output. Format -- is the export file format to generate. Objects is the list of object -- files to use. Finally the generated export filename is returned in -- Export_File. function Compute_Slave_Env (Project : Project_Tree_Ref; Auto : Boolean) return String; -- Compute a slave environment based on the command line parameter and -- the project variables. We want the same slave environment for identical -- build. Data is a string that must be taken into account in the returned -- value. function Get_Slaves_Hosts (Project_Tree : Project_Tree_Ref; Arg : String) return String; -- Given the actual argument "--distributed[=...]" return the coma -- separated list of slave hosts. This routine handle the GPR_SLAVE and -- GPR_SLAVES_FILE environment variables. end GPR.Util.Aux; gprbuild-25.0.0/gpr/src/gpr-util-knowledge.adb000066400000000000000000000065511470075373400211760ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2010-2019, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with GPR.Knowledge; use GPR.Knowledge; with GPR.Sdefault; use GPR.Sdefault; separate (GPR.Util) package body Knowledge is Base : Knowledge_Base; ------------------------- -- Normalized_Hostname -- ------------------------- function Normalized_Hostname return String is Id : Targets_Set_Id; begin Get_Targets_Set (Base, Hostname, Id); return Normalized_Target (Base, Id); end Normalized_Hostname; ----------------------- -- Normalized_Target -- ----------------------- function Normalized_Target (Target_Name : String) return String is Id : Targets_Set_Id; begin Get_Targets_Set (Base, Target_Name, Id); return Normalized_Target (Base, Id); end Normalized_Target; -------------------------- -- Parse_Knowledge_Base -- -------------------------- procedure Parse_Knowledge_Base (Project_Tree : Project_Tree_Ref; Directory : String := "") is function Dir return String; -- Returns Directory or if empty Default_Knowledge_Base_Directory pragma Inline (Dir); --------- -- Dir -- --------- function Dir return String is begin if Directory'Length = 0 then return Default_Knowledge_Base_Directory; else return Directory; end if; end Dir; begin Parse_Knowledge_Base (Base, Dir, Parse_Compiler_Info => False); exception when Invalid_Knowledge_Base => Fail_Program (Project_Tree, "could not parse the XML files in " & Dir); end Parse_Knowledge_Base; end Knowledge; gprbuild-25.0.0/gpr/src/gpr-util-put_resource_usage__null.adb000066400000000000000000000036111470075373400243050ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2022-2023, AdaCore -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ separate (GPR.Util) procedure Put_Resource_Usage (Filename : String) is begin null; end Put_Resource_Usage; gprbuild-25.0.0/gpr/src/gpr-util-put_resource_usage__unix.adb000066400000000000000000000111601470075373400243140ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2022-2023, AdaCore -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ pragma Warnings (Off, "is an internal GNAT unit"); with GNAT.Sockets.Thin_Common; pragma Warnings (On, "is an internal GNAT unit"); separate (GPR.Util) procedure Put_Resource_Usage (Filename : String) is package STC renames GNAT.Sockets.Thin_Common; type Rusage is record ru_utime : STC.Timeval; -- user time used ru_stime : STC.Timeval; -- system time used ru_maxrss : Long_Integer; -- maximum resident set size ru_ixrss : Long_Integer; -- integral shared memory size ru_idrss : Long_Integer; -- integral unshared data size ru_isrss : Long_Integer; -- integral unshared stack size ru_minflt : Long_Integer; -- page reclaims ru_majflt : Long_Integer; -- page faults ru_nswap : Long_Integer; -- swaps ru_inblock : Long_Integer; -- block input operations ru_oublock : Long_Integer; -- block output operations ru_msgsnd : Long_Integer; -- messages sent ru_msgrcv : Long_Integer; -- messages received ru_nsignals : Long_Integer; -- signals received ru_nvcsw : Long_Integer; -- voluntary context switches ru_nivcsw : Long_Integer; -- involuntary context switches end record with Convention => C; Log : File_Type; RUSAGE_SELF : constant := 0; RUSAGE_CHILDREN : constant := -1; RUSAGE_THREAD : constant := 1; procedure Print (Who : Integer); ----------- -- Print -- ----------- procedure Print (Who : Integer) is Usage : Rusage; Longs : array (1 .. 14) of Long_Integer with Import, Convention => C, Address => Usage.ru_maxrss'Address; procedure Print (This : STC.Timeval); function Getrusage (Who : Integer; usage : out Rusage) return Integer with Import, Convention => C; ----------- -- Print -- ----------- procedure Print (This : STC.Timeval) is function No_1st_Space (S : String) return String is (if S /= "" and then S (S'First) = ' ' then S (S'First + 1 .. S'Last) else S); Uimg : constant String := No_1st_Space (This.Tv_Usec'Img); begin Put (Log, This.Tv_Sec'Img); Put (Log, '.'); if Uimg'Length < 6 then Put (Log, (1 .. 6 - Uimg'Length => '0')); end if; Put (Log, Uimg); end Print; begin if Getrusage (Who, Usage) /= 0 then Put_Line (Log, "error: " & GNAT.OS_Lib.Errno_Message); return; end if; Print (Usage.ru_utime); Print (Usage.ru_stime); for L of Longs loop Put (Log, L'Img); end loop; New_Line (Log); pragma Assert (Longs (Longs'Last)'Address = Usage.ru_nivcsw'Address); end Print; begin Create (Log, Out_File, Filename); Print (RUSAGE_THREAD); Print (RUSAGE_SELF); Print (RUSAGE_CHILDREN); Close (Log); end Put_Resource_Usage; gprbuild-25.0.0/gpr/src/gpr-util.adb000066400000000000000000006065561470075373400172340ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2022, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Calendar; with Ada.Calendar.Time_Zones; use Ada.Calendar.Time_Zones; with Ada.Command_Line; use Ada.Command_Line; with Ada.Containers.Ordered_Sets; with Ada.Containers.Vectors; with Ada.Directories; use Ada.Directories; with Ada.Unchecked_Conversion; with Ada.Unchecked_Deallocation; with Ada.Strings.Fixed; use Ada.Strings.Fixed; with Ada.Strings.Maps; use Ada.Strings.Maps; with Ada.Text_IO; use Ada.Text_IO; with Ada.Streams.Stream_IO; use Ada.Streams; with Ada.Exceptions; with GNAT.Calendar.Time_IO; use GNAT.Calendar.Time_IO; with GNAT.Case_Util; use GNAT.Case_Util; with GNAT.HTable; with GNAT.Regexp; use GNAT.Regexp; with GNAT.Table; with GNAT.Calendar; use GNAT.Calendar; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with Interfaces.C.Strings; with System; use System; with GPR.ALI; use GPR.ALI; with GPR.Com; with GPR.Conf; with GPR.Debug; with GPR.Env; with GPR.Err; with GPR.Jobserver; with GPR.Names; use GPR.Names; with GPR.Opt; use GPR.Opt; with GPR.Output; use GPR.Output; with GPR.Sdefault; with GPR.Sinput; with GPR.Snames; use GPR.Snames; with GPR.Version; use GPR.Version; with Gpr_Build_Util; use Gpr_Build_Util; package body GPR.Util is use Ada.Containers; Program_Name : String_Access := null; type File_Stamp_Record is record Known : Boolean := False; TS : Time_Stamp_Type := Empty_Time_Stamp; end record; Unknow_File_Stamp : constant File_Stamp_Record := (False, Empty_Time_Stamp); package File_Stamp_HTable is new GNAT.HTable.Simple_HTable (Header_Num => GPR.Header_Num, Element => File_Stamp_Record, No_Element => Unknow_File_Stamp, Key => Path_Name_Type, Hash => GPR.Hash, Equal => "="); -- A hash table to cache time stamps of files package Source_Info_Table is new GNAT.Table (Table_Component_Type => Source_Info_Iterator, Table_Index_Type => Natural, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 100); package Source_Info_Project_HTable is new GNAT.HTable.Simple_HTable (Header_Num => GPR.Header_Num, Element => Natural, No_Element => 0, Key => Name_Id, Hash => GPR.Hash, Equal => "="); procedure Free is new Ada.Unchecked_Deallocation (Text_File_Data, Text_File); package Processed_ALIs is new GNAT.HTable.Simple_HTable (Header_Num => GPR.Header_Num, Element => Boolean, No_Element => False, Key => File_Name_Type, Hash => GPR.Hash, Equal => "="); True_Checksum : constant File_Name_Type := File_Name_Type (First_Name_Id); -- Special constant to declare that checksum in Source record is calculated -- from source file content. function To_Path_String_Access (Path_Addr : Address; Path_Len : Integer) return String_Access; -- Converts a C String to an Ada String. function Locate_Directory (Dir_Name : C_File_Name; Path : C_File_Name) return String_Access; function C_String_Length (S : Address) return Integer; -- Returns the length of C (null-terminated) string at S, or 0 for -- Null_Address. function File_Stamp (Path : Path_Name_Type) return Time_Stamp_Type; -- Get the time stamp of Path. Take it from File_Stamp_HTable if it is -- already there, otherwise get it from OS and put into File_Stamp_HTable -- to be able to get it next time. --------------------- -- C_String_Length -- --------------------- function C_String_Length (S : Address) return Integer is function strlen (A : Address) return size_t; pragma Import (Intrinsic, strlen, "strlen"); begin if S = Null_Address then return 0; else return Integer (strlen (S)); end if; end C_String_Length; ------------------------ -- Calculate_Checksum -- ------------------------ function Calculate_Checksum (Source : Source_Id) return Boolean is Source_Index : Source_File_Index; begin if Source.Checksum_Src = True_Checksum then -- Checksum already calculated return True; end if; Source_Index := Sinput.Load_File (Get_Name_String (Source.Path.Display_Name)); if Source_Index /= No_Source_File then Err.Scanner.Initialize_Scanner (Source_Index, Err.Scanner.Ada); -- Scan the complete file to compute its -- checksum. loop Err.Scanner.Scan; exit when Token = Tok_EOF; end loop; Source.Checksum := Scans.Checksum; Source.Checksum_Src := True_Checksum; -- If there were errors we can't Clear_Source_File_Table because the -- error messages refer to this table content. if Total_Errors_Detected = 0 then -- To avoid using too much memory, free the -- memory allocated. Sinput.Clear_Source_File_Table; end if; return True; end if; return False; end Calculate_Checksum; ------------------------ -- Calculate_Checksum -- ------------------------ function Calculate_Checksum (File : Path_Name_Type) return Word is Source_Index : Source_File_Index; Checksum : Word := 0; begin Source_Index := Sinput.Load_File (Get_Name_String (File)); if Source_Index /= No_Source_File then Err.Scanner.Initialize_Scanner (Source_Index, Err.Scanner.Ada); -- Scan the complete file to compute its -- checksum. loop Err.Scanner.Scan; exit when Token = Tok_EOF; end loop; Checksum := Scans.Checksum; -- If there were errors we can't Clear_Source_File_Table because the -- error messages refer to this table content. if Total_Errors_Detected = 0 then -- To avoid using too much memory, free the -- memory allocated. Sinput.Clear_Source_File_Table; end if; return Checksum; end if; return Checksum; end Calculate_Checksum; ---------------------------- -- Clear_Time_Stamp_Cache -- ---------------------------- procedure Clear_Time_Stamp_Cache is begin File_Stamp_HTable.Reset; end Clear_Time_Stamp_Cache; ---------------- -- File_Stamp -- ---------------- function File_Stamp (Path : Path_Name_Type) return Time_Stamp_Type is begin if Path = No_Path then return Empty_Time_Stamp; else declare FSR : File_Stamp_Record := File_Stamp_HTable.Get (Path); begin if FSR.Known then return FSR.TS; else declare Result : constant Time_Stamp_Type := Osint.File_Stamp (Path); begin FSR := (True, Result); File_Stamp_HTable.Set (Path, FSR); return Result; end; end if; end; end if; end File_Stamp; ----------------------- -- Update_File_Stamp -- ----------------------- procedure Update_File_Stamp (Path : Path_Name_Type; Stamp : Time_Stamp_Type) is begin if Path = No_Path then null; else File_Stamp_HTable.Set (Path, (True, Stamp)); end if; end Update_File_Stamp; ---------------------- -- Locate_Directory -- ---------------------- function Locate_Directory (Dir_Name : C_File_Name; Path : C_File_Name) return String_Access is function Is_Dir (Name : Address) return Integer; pragma Import (C, Is_Dir, "__gnat_is_directory"); function Locate_File_With_Predicate (File_Name, Path_Val, Predicate : Address) return Address; pragma Import (C, Locate_File_With_Predicate, "__gnat_locate_file_with_predicate"); Result_Addr : Address; Result_Len : Integer; Result : String_Access := null; begin Result_Addr := Locate_File_With_Predicate (Dir_Name, Path, Is_Dir'Address); Result_Len := C_String_Length (Result_Addr); if Result_Len /= 0 then Result := To_Path_String_Access (Result_Addr, Result_Len); end if; return Result; end Locate_Directory; function Locate_Directory (Dir_Name : String; Path : String) return String_Access is C_Dir_Name : String (1 .. Dir_Name'Length + 1); C_Path : String (1 .. Path'Length + 1); Result : String_Access; begin C_Dir_Name (1 .. Dir_Name'Length) := Dir_Name; C_Dir_Name (C_Dir_Name'Last) := ASCII.NUL; C_Path (1 .. Path'Length) := Path; C_Path (C_Path'Last) := ASCII.NUL; Result := Locate_Directory (C_Dir_Name'Address, C_Path'Address); if Result /= null and then not Is_Absolute_Path (Result.all) then declare Absolute_Path : constant String := Normalize_Pathname (Result.all); begin Free (Result); Result := new String'(Absolute_Path); end; end if; return Result; end Locate_Directory; --------------------------- -- To_Path_String_Access -- --------------------------- function To_Path_String_Access (Path_Addr : Address; Path_Len : Integer) return String_Access is subtype Path_String is String (1 .. Path_Len); type Path_String_Access is access Path_String; function Address_To_Access is new Ada.Unchecked_Conversion (Source => Address, Target => Path_String_Access); Path_Access : constant Path_String_Access := Address_To_Access (Path_Addr); Return_Val : String_Access; begin Return_Val := new String (1 .. Path_Len); for J in 1 .. Path_Len loop Return_Val (J) := Path_Access (J); end loop; return Return_Val; end To_Path_String_Access; -------------- -- Closures -- -------------- type Project_And_Tree is record Project : Project_Id; Tree : Project_Tree_Ref; end record; function "<" (Left, Right : Project_And_Tree) return Boolean; package Projects_And_Trees_Sets is new Ada.Containers.Indefinite_Ordered_Sets (Element_Type => Project_And_Tree); type Main_Project_Tree is record Main : Source_Id; Project : Project_Id; Tree : Project_Tree_Ref; end record; function "<" (Left, Right : Main_Project_Tree) return Boolean; package MPT_Sets is new Ada.Containers.Indefinite_Ordered_Sets (Element_Type => Main_Project_Tree); package File_Name_Vectors is new Ada.Containers.Vectors (Positive, File_Name_Type); subtype File_Names is File_Name_Vectors.Vector; package Path_Sets renames String_Sets; --------- -- "<" -- --------- function "<" (Left, Right : Project_And_Tree) return Boolean is begin return Left.Project.Name < Right.Project.Name; end "<"; function "<" (Left, Right : Main_Project_Tree) return Boolean is begin if Left.Project.Name /= Right.Project.Name then return Left.Project.Name < Right.Project.Name; else return Left.Main.File < Right.Main.File; end if; end "<"; ----------- -- Close -- ----------- procedure Close (File : in out Text_File) is Len : Integer; Status : Boolean; begin if File = null then GPR.Com.Fail ("Close attempted on an invalid Text_File"); end if; if File.Out_File then if File.Buffer_Len > 0 then Len := Write (File.FD, File.Buffer'Address, File.Buffer_Len); if Len /= File.Buffer_Len then GPR.Com.Fail ("Unable to write to an out Text_File"); end if; end if; Close (File.FD, Status); if not Status then GPR.Com.Fail ("Unable to close an out Text_File"); end if; else -- Close in file, no need to test status, since this is a file that -- we read, and the file was read successfully before we closed it. Close (File.FD); end if; Free (File); end Close; ------------------------------ -- Compilation_Phase_Failed -- ------------------------------ procedure Compilation_Phase_Failed (Project_Tree : Project_Tree_Ref; Exit_Code : Exit_Code_Type := E_Fatal; No_Message : Boolean := False) is begin Fail_Program (Project_Tree, "*** compilation phase failed", Exit_Code, No_Message => No_Message); end Compilation_Phase_Failed; ------------ -- Create -- ------------ procedure Create (File : out Text_File; Name : String) is FD : File_Descriptor; File_Name : String (1 .. Name'Length + 1); begin File_Name (1 .. Name'Length) := Name; File_Name (File_Name'Last) := ASCII.NUL; FD := Create_File (Name => File_Name'Address, Fmode => GNAT.OS_Lib.Text); if FD = Invalid_FD then File := null; else File := new Text_File_Data; File.FD := FD; File.Out_File := True; File.End_Of_File_Reached := True; end if; end Create; ------------------------------- -- Common_Path_Prefix_Length -- ------------------------------- function Common_Path_Prefix_Length (A, B : String) return Integer is Slash : Integer := A'First; -- At the last slash seen in A At_A : Integer := A'First; At_B : Integer := B'First; begin loop if At_A > A'Last then if At_B > B'Last or else B (At_B) = '/' then return A'Length; else return Slash - A'First; end if; elsif At_B > B'Last then if A (At_A) = '/' then -- A cannot be shorter than B here return B'Length; else return Slash - A'First; end if; elsif A (At_A) /= B (At_B) then return Slash - A'First; elsif A (At_A) = '/' then Slash := At_A; end if; At_A := At_A + 1; At_B := At_B + 1; end loop; end Common_Path_Prefix_Length; ------------------- -- Common_Prefix -- ------------------- function Common_Prefix (Pathname1, Pathname2 : String) return String is P1 : constant String := Normalize_Pathname (Pathname1); P2 : constant String := Normalize_Pathname (Pathname2); I1 : Positive := P1'First; I2 : Positive := P2'First; begin while I1 <= P1'Last and then I2 <= P2'Last and then P1 (I1) = P2 (I2) loop I1 := I1 + 1; I2 := I2 + 1; end loop; if I1 <= P1'Last or else I2 <= P2'Last then return P1 (P1'First .. I1 - 1); elsif I1 > P1'Last then return P2; else return P1; end if; end Common_Prefix; --------------- -- Duplicate -- --------------- procedure Duplicate (This : in out Name_List_Index; Shared : Shared_Project_Tree_Data_Access) is Old_Current : Name_List_Index; New_Current : Name_List_Index; begin if This /= No_Name_List then Old_Current := This; Name_List_Table.Increment_Last (Shared.Name_Lists); New_Current := Name_List_Table.Last (Shared.Name_Lists); This := New_Current; Shared.Name_Lists.Table (New_Current) := (Shared.Name_Lists.Table (Old_Current).Name, No_Name_List); loop Old_Current := Shared.Name_Lists.Table (Old_Current).Next; exit when Old_Current = No_Name_List; Shared.Name_Lists.Table (New_Current).Next := New_Current + 1; Name_List_Table.Increment_Last (Shared.Name_Lists); New_Current := New_Current + 1; Shared.Name_Lists.Table (New_Current) := (Shared.Name_Lists.Table (Old_Current).Name, No_Name_List); end loop; end if; end Duplicate; ----------------- -- End_Of_File -- ----------------- function End_Of_File (File : Text_File) return Boolean is begin if File = null then GPR.Com.Fail ("End_Of_File attempted on an invalid Text_File"); end if; return File.End_Of_File_Reached; end End_Of_File; ------------------- -- Executable_Of -- ------------------- function Executable_Of (Project : Project_Id; Shared : Shared_Project_Tree_Data_Access; Main : File_Name_Type; Index : Int; Language : String := ""; Include_Suffix : Boolean := True) return File_Name_Type is pragma Assert (Project /= No_Project); The_Packages : constant Package_Id := Project.Decl.Packages; Builder_Package : constant GPR.Package_Id := GPR.Util.Value_Of (Name => Name_Builder, In_Packages => The_Packages, Shared => Shared); Executable : Variable_Value := GPR.Util.Value_Of (Name => Name_Id (Main), Index => Index, Attribute_Or_Array_Name => Name_Executable, In_Package => Builder_Package, Shared => Shared); Lang : Language_Ptr; Spec_Suffix : Name_Id := No_Name; Body_Suffix : Name_Id := No_Name; Spec_Suffix_Length : Natural := 0; Body_Suffix_Length : Natural := 0; procedure Get_Suffixes (B_Suffix : File_Name_Type; S_Suffix : File_Name_Type); -- Get the non empty suffixes in variables Spec_Suffix and Body_Suffix function Add_Suffix (File : File_Name_Type) return File_Name_Type; -- Return the name of the executable, based on File, and adding the -- executable suffix if needed ------------------ -- Get_Suffixes -- ------------------ procedure Get_Suffixes (B_Suffix : File_Name_Type; S_Suffix : File_Name_Type) is begin if B_Suffix /= No_File then Body_Suffix := Name_Id (B_Suffix); Body_Suffix_Length := Natural (Length_Of_Name (Body_Suffix)); end if; if S_Suffix /= No_File then Spec_Suffix := Name_Id (S_Suffix); Spec_Suffix_Length := Natural (Length_Of_Name (Spec_Suffix)); end if; end Get_Suffixes; ---------------- -- Add_Suffix -- ---------------- function Add_Suffix (File : File_Name_Type) return File_Name_Type is Saved_EEOT : constant Name_Id := Executable_Extension_On_Target; Result : File_Name_Type; begin if Include_Suffix then if Project.Config.Executable_Suffix /= No_Name then Executable_Extension_On_Target := Project.Config.Executable_Suffix; end if; Result := Executable_Name (File); Executable_Extension_On_Target := Saved_EEOT; return Result; end if; return File; end Add_Suffix; -- Start of processing for Executable_Of begin if Language /= "" then Lang := Get_Language_From_Name (Project, Language); end if; if Lang /= null then Get_Suffixes (B_Suffix => Lang.Config.Naming_Data.Body_Suffix, S_Suffix => Lang.Config.Naming_Data.Spec_Suffix); end if; if Builder_Package /= No_Package then if Executable = Nil_Variable_Value then Get_Name_String (Main); -- Try as index the name minus the implementation suffix or minus -- the specification suffix. declare Name : constant String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); Last : Positive := Name_Len; Truncated : Boolean := False; begin if Body_Suffix /= No_Name and then Last > Natural (Length_Of_Name (Body_Suffix)) and then Name (Last - Body_Suffix_Length + 1 .. Last) = Get_Name_String (Body_Suffix) then Truncated := True; Last := Last - Body_Suffix_Length; end if; if Spec_Suffix /= No_Name and then not Truncated and then Last > Spec_Suffix_Length and then Name (Last - Spec_Suffix_Length + 1 .. Last) = Get_Name_String (Spec_Suffix) then Truncated := True; Last := Last - Spec_Suffix_Length; end if; if Truncated then Name_Len := Last; Name_Buffer (1 .. Name_Len) := Name (1 .. Last); Executable := GPR.Util.Value_Of (Name => Name_Find, Index => 0, Attribute_Or_Array_Name => Name_Executable, In_Package => Builder_Package, Shared => Shared); end if; end; end if; -- If we have found an Executable attribute, return its value, -- possibly suffixed by the executable suffix. if Executable /= Nil_Variable_Value and then Executable.Value /= No_Name and then Length_Of_Name (Executable.Value) /= 0 then return Add_Suffix (File_Name_Type (Executable.Value)); end if; end if; Get_Name_String (Main); -- If there is a body suffix or a spec suffix, remove this suffix, -- otherwise remove any suffix ('.' followed by other characters), if -- there is one. if Body_Suffix /= No_Name and then Name_Len > Body_Suffix_Length and then Name_Buffer (Name_Len - Body_Suffix_Length + 1 .. Name_Len) = Get_Name_String (Body_Suffix) then -- Found the body termination, remove it Name_Len := Name_Len - Body_Suffix_Length; elsif Spec_Suffix /= No_Name and then Name_Len > Spec_Suffix_Length and then Name_Buffer (Name_Len - Spec_Suffix_Length + 1 .. Name_Len) = Get_Name_String (Spec_Suffix) then -- Found the spec termination, remove it Name_Len := Name_Len - Spec_Suffix_Length; else -- Remove any suffix, if there is one Get_Name_String (Strip_Suffix (Main)); end if; return Add_Suffix (Name_Find); end Executable_Of; ---------------------------- -- Executable_Prefix_Path -- ---------------------------- function Executable_Prefix_Path return String is Exec_Name : constant String := Command_Name; function Get_Install_Dir (S : String) return String; -- S is the executable name preceded by the absolute or relative path, -- e.g. "c:\usr\bin\gcc.exe". Returns the absolute directory where "bin" -- lies (in the example "C:\usr"). If the executable is not in a "bin" -- directory, return "". --------------------- -- Get_Install_Dir -- --------------------- function Get_Install_Dir (S : String) return String is Exec : String := Normalize_Pathname (S, Resolve_Links => True); Path_Last : Integer := 0; begin for J in reverse Exec'Range loop if Is_Directory_Separator (Exec (J)) then Path_Last := J - 1; exit; end if; end loop; if Path_Last >= Exec'First + 2 then To_Lower (Exec (Path_Last - 2 .. Path_Last)); end if; if Path_Last < Exec'First + 2 or else Exec (Path_Last - 2 .. Path_Last) /= "bin" or else (Path_Last - 3 >= Exec'First and then not Is_Directory_Separator (Exec (Path_Last - 3))) then return ""; end if; return (Exec (Exec'First .. Path_Last - 4)) & Directory_Separator; end Get_Install_Dir; -- Beginning of Executable_Prefix_Path begin -- First determine if a path prefix was placed in front of the -- executable name. for J in reverse Exec_Name'Range loop if Is_Directory_Separator (Exec_Name (J)) then return Get_Install_Dir (Exec_Name); end if; end loop; -- If we get here, the user has typed the executable name with no -- directory prefix. declare Path : String_Access := Locate_Exec_On_Path (Exec_Name); begin if Path = null then return ""; else declare Dir : constant String := Get_Install_Dir (Path.all); begin Free (Path); return Dir; end; end if; end; end Executable_Prefix_Path; ------------ -- Expect -- ------------ procedure Expect (The_Token : Token_Type; Token_Image : String) is begin if Token /= The_Token then -- ??? Should pass user flags here instead Err.Error_Msg (Gprbuild_Flags, Token_Image & " expected", Token_Ptr, One_Line => True); end if; end Expect; ------------------ -- Fail_Program -- ------------------ procedure Fail_Program (Project_Tree : Project_Tree_Ref; Message : String; Exit_Code : Exit_Code_Type := E_Fatal; Flush_Messages : Boolean := True; No_Message : Boolean := False; Command : String := "") is begin if Flush_Messages and not No_Message then if Total_Errors_Detected /= 0 or else Warnings_Detected /= 0 then Err.Finalize; end if; end if; GPR.Jobserver.Unregister_All_Token_Id; Finish_Program (Project_Tree, Exit_Code => Exit_Code, Message => Message, No_Message => No_Message, Command => Command); end Fail_Program; -------------------- -- Finish_Program -- -------------------- procedure Finish_Program (Project_Tree : Project_Tree_Ref; Exit_Code : Exit_Code_Type := E_Success; Message : String := ""; No_Message : Boolean := False; Command : String := "") is begin Jobserver.Finalize; if not Opt.Keep_Temporary_Files then Delete_All_Temp_Files (if Project_Tree = null then null else Project_Tree.Shared); end if; if Message'Length > 0 and then not No_Message then if Exit_Code not in E_Success | E_Subtool then Set_Standard_Error; end if; Write_Program_Name; Write_Line (Message); if Command /= "" then Write_Program_Name; Write_Line (Command); end if; end if; Exit_Program (Exit_Code); end Finish_Program; --------------------------- -- For_Interface_Sources -- --------------------------- procedure For_Interface_Sources (Tree : Project_Tree_Ref; Project : Project_Id) is package Dep_Names renames String_Sets; function Less_Than (Left, Right : Source_Id) return Boolean is (Get_Name_String (Left.File) < Get_Name_String (Right.File)); package Interface_Source_Ids is new Ada.Containers.Ordered_Sets (Element_Type => Source_Id, "<" => Less_Than, "=" => "="); function Load_ALI (Filename : String) return ALI_Id; -- Load an ALI file and return its id -------------- -- Load_ALI -- -------------- function Load_ALI (Filename : String) return ALI_Id is Result : ALI_Id := No_ALI_Id; Text : Text_Buffer_Ptr; Lib_File : File_Name_Type; begin if Ada.Directories.Exists (Filename) then Lib_File := Get_File_Name_Id (Filename); Text := Osint.Read_Library_Info (Lib_File); Result := ALI.Scan_ALI (Lib_File, Text, Ignore_ED => False, Err => True, Read_Lines => "UD"); Free (Text); end if; return Result; end Load_ALI; -- Local declarations Iter : Source_Iterator; Sid : Source_Id; ALI : ALI_Id; First_Unit : Unit_Id; Second_Unit : Unit_Id; Body_Needed : Boolean; Deps : Dep_Names.Set; Sids : Interface_Source_Ids.Set; -- Start of processing for For_Interface_Sources begin if Project.Qualifier = Aggregate_Library then Iter := For_Each_Source (Tree); else Iter := For_Each_Source (Tree, Project); end if; -- First look at each spec, check if the body is needed loop Sid := Element (Iter); exit when Sid = No_Source; -- Skip sources that are removed/excluded and sources not part of -- the interface for standalone libraries. if Sid.Kind = Spec and then (not Sid.Project.Externally_Built or else Sid.Project = Project) and then not Sid.Locally_Removed and then (Project.Standalone_Library = No or else Sid.Declared_In_Interfaces) -- Handle case of non-compilable languages and then Sid.Dep_Name /= No_File then Sids.Include (Sid); -- Check ALI for dependencies on body and sep ALI := Load_ALI (Get_Name_String (Get_Object_Directory (Sid.Project, True)) & Get_Name_String (Sid.Dep_Name)); if ALI /= No_ALI_Id then First_Unit := ALIs.Table (ALI).First_Unit; Second_Unit := No_Unit_Id; Body_Needed := True; -- If there is both a spec and a body, check if both needed if Units.Table (First_Unit).Utype = Is_Body then Second_Unit := ALIs.Table (ALI).Last_Unit; -- If the body is not needed, then reset First_Unit if not Units.Table (Second_Unit).Body_Needed_For_SAL then Body_Needed := False; end if; elsif Units.Table (First_Unit).Utype = Is_Spec_Only then Body_Needed := False; end if; -- Handle all the separates, if any if Body_Needed then if Other_Part (Sid) /= null then Deps.Include (Get_Name_String (Other_Part (Sid).File)); end if; for Dep in ALIs.Table (ALI).First_Sdep .. ALIs.Table (ALI).Last_Sdep loop if Sdep.Table (Dep).Subunit_Name /= No_Name then Deps.Include (Get_Name_String (Sdep.Table (Dep).Sfile)); end if; end loop; end if; end if; end if; Next (Iter); end loop; -- Now handle the bodies and separates if needed if Deps.Length /= 0 then if Project.Qualifier = Aggregate_Library then Iter := For_Each_Source (Tree); else Iter := For_Each_Source (Tree, Project); end if; loop Sid := Element (Iter); exit when Sid = No_Source; if Sid.Kind /= Spec and then Deps.Contains (Get_Name_String (Sid.File)) then Sids.Include (Sid); end if; Next (Iter); end loop; end if; -- Call Action for all the sources, in order for E of Sids loop Action (E); end loop; end For_Interface_Sources; ------------------ -- Get_Closures -- ------------------ procedure Get_Closures (Project : Project_Id; In_Tree : Project_Tree_Ref; Mains : String_Vectors.Vector; All_Projects : Boolean := True; Include_Externally_Built : Boolean := False; Status : out Status_Type; Result : out String_Vectors.Vector) is Closures : Path_Sets.Set; Projects_And_Trees : Projects_And_Trees_Sets.Set; Mains_Projects_Trees : MPT_Sets.Set; The_File_Names : File_Names := File_Name_Vectors.Empty_Vector; procedure Add_To_Projects (Proj : Project_Id; Tree : Project_Tree_Ref); -- Add project Proc with its Tree to the list of projects procedure Add_To_Mains (Main : Source_Id; Project : Project_Id; Tree : Project_Tree_Ref); -- Add main Main with its Project and Tree to the list of mains procedure Add_To_Closures (Source : Source_Id; Added : out Boolean); -- Add Source to the list of closures. Added is True when Source is -- effectively added. If Source was already in the list of closures, it -- is not added again and Added is False. procedure Look_For_Mains; -- Look for mains in the project trees. Status is Success only if -- all mains have been found. procedure Get_Aggregated (Proj : Project_Id); -- Get the non aggregated projects from Aggregate project Proj procedure Cleanup; -- Deallocate the local lists procedure Initialize_Sources; -- Initialize all the source records in all the trees procedure Process (Source : Source_Id; Project : Project_Id; Tree : Project_Tree_Ref); -- Get the sources in the closure of Main and add them to the list of -- closures. --------------------- -- Add_To_Closures -- --------------------- procedure Add_To_Closures (Source : Source_Id; Added : out Boolean) is Position : Path_Sets.Cursor; begin Added := False; if Source /= No_Source then Path_Sets.Insert (Container => Closures, New_Item => Get_Name_String (Source.Path.Display_Name), Position => Position, Inserted => Added); end if; end Add_To_Closures; ------------------ -- Add_To_Mains -- ------------------ procedure Add_To_Mains (Main : Source_Id; Project : Project_Id; Tree : Project_Tree_Ref) is Position : MPT_Sets.Cursor; Inserted : Boolean; begin Mains_Projects_Trees.Insert (New_Item => (Main, Project, Tree), Position => Position, Inserted => Inserted); end Add_To_Mains; --------------------- -- Add_To_Projects -- --------------------- procedure Add_To_Projects (Proj : Project_Id; Tree : Project_Tree_Ref) is begin Projects_And_Trees.Insert ((Proj, Tree)); end Add_To_Projects; ------------- -- Cleanup -- ------------- procedure Cleanup is begin Closures.Clear; Projects_And_Trees.Clear; Mains_Projects_Trees.Clear; The_File_Names.Clear; end Cleanup; -------------------- -- Get_Aggregated -- -------------------- procedure Get_Aggregated (Proj : Project_Id) is List : Aggregated_Project_List := null; Prj : Project_Id; begin if Proj.Qualifier = Aggregate then List := Proj.Aggregated_Projects; end if; while List /= null loop Prj := List.Project; case Prj.Qualifier is when Library | Configuration | Abstract_Project | Aggregate_Library => null; when Unspecified | Standard => if not Prj.Library and then not Prj.Externally_Built then Add_To_Projects (Prj, List.Tree); end if; when Aggregate => Get_Aggregated (Prj); end case; List := List.Next; end loop; end Get_Aggregated; ------------------------ -- Initialize_Sources -- ------------------------ procedure Initialize_Sources is Last : constant Projects_And_Trees_Sets.Cursor := Projects_And_Trees_Sets.Last (Projects_And_Trees); Position : Projects_And_Trees_Sets.Cursor := Projects_And_Trees_Sets.First (Projects_And_Trees); Iter : Source_Iterator; Src : Source_Id; The_Project_And_Tree : Project_And_Tree; use type Projects_And_Trees_Sets.Cursor; begin loop The_Project_And_Tree := Projects_And_Trees_Sets.Element (Position); -- Initialize all the Ada sources of the project tree, even if -- All_Projects is False. Iter := For_Each_Source (In_Tree => The_Project_And_Tree.Tree, Language => Name_Ada, Encapsulated_Libs => True, Locally_Removed => False); loop Src := Element (Iter); exit when Src = No_Source; Initialize_Source_Record (Src); Next (Iter); end loop; exit when Position = Last; Projects_And_Trees_Sets.Next (Position); end loop; end Initialize_Sources; -------------------- -- Look_For_Mains -- -------------------- procedure Look_For_Mains is begin for FName of The_File_Names loop declare Saved_Mains_Length : constant Ada.Containers.Count_Type := Mains_Projects_Trees.Length; Position : Projects_And_Trees_Sets.Cursor := Projects_And_Trees_Sets.First (Projects_And_Trees); Last : constant Projects_And_Trees_Sets.Cursor := Projects_And_Trees_Sets.Last (Projects_And_Trees); use type Projects_And_Trees_Sets.Cursor; The_PT : Project_And_Tree; begin loop The_PT := Projects_And_Trees_Sets.Element (Position); -- find the main in the project tree declare Source : Source_Id; The_Tree : constant Project_Tree_Ref := The_PT.Tree; The_Project : constant Project_Id := The_PT.Project; Sources : constant Source_Ids := Find_All_Sources (In_Tree => The_Tree, Project => The_Project, In_Imported_Only => False, In_Extended_Only => False, Base_Name => FName); begin for L in Sources'Range loop Source := Sources (L); if Source.Language.Config.Kind /= Unit_Based then Status := Invalid_Main; return; elsif Source.Project = The_Project then Add_To_Mains (Main => Source, Project => The_Project, Tree => The_Tree); elsif All_Projects then if not Source.Project.Externally_Built or else Include_Externally_Built then Add_To_Mains (Main => Source, Project => The_Project, Tree => The_Tree); end if; end if; end loop; end; exit when Position = Last; Projects_And_Trees_Sets.Next (Position); end loop; if Mains_Projects_Trees.Length = Saved_Mains_Length then Status := Invalid_Main; return; end if; end; end loop; end Look_For_Mains; ------------- -- Process -- ------------- procedure Process (Source : Source_Id; Project : Project_Id; Tree : Project_Tree_Ref) is -- Add Source to the closures, if not there yet, and continue with -- the sources it imports. Text : Text_Buffer_Ptr; Idread : ALI_Id; First_Unit : Unit_Id; Last_Unit : Unit_Id; Unit_Data : Unit_Record; The_ALI : File_Name_Type; Added : Boolean; procedure Find_Unit (Uname : String); -- Find the sources for this unit name --------------- -- Find_Unit -- --------------- procedure Find_Unit (Uname : String) is Iter : Source_Iterator; Src : Source_Id; Unit_Name : constant String := Uname (Uname'First .. Uname'Last - 2); Proj : Project_Id; begin if All_Projects then Proj := No_Project; else Proj := Project; end if; Iter := For_Each_Source (In_Tree => Tree, Project => Proj, Language => Name_Ada, Encapsulated_Libs => True, Locally_Removed => False); loop Src := Element (Iter); exit when Src = No_Source; if Src.Unit /= No_Unit_Index and then Get_Name_String (Src.Unit.Name) = Unit_Name then Process (Src, Src.Project, Tree); end if; Next (Iter); end loop; end Find_Unit; begin -- Nothing to do if the project is externally built and -- Include_Externally_Built is False. if Project.Externally_Built and then not Include_Externally_Built then return; end if; Add_To_Closures (Source, Added); if not Added then return; end if; The_ALI := File_Name_Type (Source.Dep_Path); if not Processed_ALIs.Get (The_ALI) then Processed_ALIs.Set (The_ALI, True); Text := Read_Library_Info (The_ALI); if Text = null then Status := Incomplete_Closure; else Idread := Scan_ALI (F => The_ALI, T => Text, Ignore_ED => False, Err => True, Read_Lines => "WD"); Free (Text); if Idread = No_ALI_Id then Status := Incomplete_Closure; else First_Unit := ALI.ALIs.Table (Idread).First_Unit; Last_Unit := ALI.ALIs.Table (Idread).Last_Unit; for Unit in First_Unit .. Last_Unit loop Unit_Data := ALI.Units.Table (Unit); if Unit = First_Unit then declare Uname : constant String := Get_Name_String (Unit_Data.Uname); begin Find_Unit (Uname); -- For a body, check if there are subunits if Uname (Uname'Last - 1 .. Uname'Last) = "%b" then for D in ALI.ALIs.Table (Idread).First_Sdep .. ALI.ALIs.Table (Idread).Last_Sdep loop declare Sdep : constant Sdep_Record := ALI.Sdep.Table (D); begin if Sdep.Subunit_Name /= No_Name then declare Subunit_Name : constant String := Get_Name_String (Sdep.Subunit_Name); File_Name : constant File_Name_Type := Sdep.Sfile; Iter : Source_Iterator; Src : Source_Id; begin if Subunit_Name'Length >= Uname'Length - 2 and then Subunit_Name (Subunit_Name'First .. Subunit_Name'First + Uname'Length - 3) = Uname (Uname'First .. Uname'Last - 2) and then Subunit_Name (Subunit_Name'First + Uname'Length - 2) = '.' then -- Add the subunit to the closure -- First, find the source Iter := For_Each_Source (In_Tree => Tree, Project => Project, Language => Name_Ada, Encapsulated_Libs => True, Locally_Removed => False); loop Src := Element (Iter); exit when Src = No_Source; exit when Src.File = File_Name; Next (Iter); end loop; -- If the source has been found, -- add it to the closure. if Src /= No_Source then Add_To_Closures (Src, Added); end if; end if; end; end if; end; end loop; end if; end; end if; for W in Unit_Data.First_With .. Unit_Data.Last_With loop Find_Unit (Get_Name_String (Withs.Table (W).Uname)); end loop; end loop; end if; end if; end if; end Process; begin Status := Success; Result := String_Vectors.Empty_Vector; -- Fail immediately if there are no Mains if Mains.Is_Empty then Status := No_Main; Cleanup; return; else The_File_Names.Clear; for Src of Mains loop if Src'Length = 0 then Status := No_Main; Cleanup; return; else Name_Len := Src'Length; Name_Buffer (1 .. Name_Len) := Src; The_File_Names.Append (Name_Find); end if; end loop; end if; -- First check if there are any valid project or projects if Project = No_Project or else In_Tree = No_Project_Tree then Err.Error_Msg (Gprbuild_Flags, "Project not found", Token_Ptr, Project => Project); Status := Invalid_Project; Cleanup; return; end if; if Project.Externally_Built then Err.Error_Msg (Gprbuild_Flags, "No closures for external projects", Token_Ptr, Project => Project); Status := Invalid_Project; Cleanup; return; end if; case Project.Qualifier is when Configuration | Abstract_Project => Err.Error_Msg (Gprbuild_Flags, "No closures for abstract or configuration", Token_Ptr, Project => Project); Status := Invalid_Project; Cleanup; return; when Standard | Library | Unspecified => Add_To_Projects (Project, In_Tree); when Aggregate | Aggregate_Library => if not All_Projects then Err.Error_Msg (Gprbuild_Flags, "Aggregate closure must be recursive", Token_Ptr, Project => Project); Status := Invalid_Project; Cleanup; return; end if; Get_Aggregated (Project); end case; if Projects_And_Trees.Length = 0 then Err.Error_Msg (Gprbuild_Flags, "No projects to closure", Token_Ptr, Project => Project); Status := Invalid_Project; Cleanup; return; end if; -- Initialize the source records for all sources in the project trees Initialize_Sources; -- Now that we have the valid project(s), look for the mains Look_For_Mains; if Status /= Success then Cleanup; return; end if; -- Now that we have the main sources, get their closures Processed_ALIs.Reset; declare Position : MPT_Sets.Cursor := MPT_Sets.First (Mains_Projects_Trees); Last : constant MPT_Sets.Cursor := MPT_Sets.Last (Mains_Projects_Trees); The_MPT : Main_Project_Tree; use type MPT_Sets.Cursor; begin loop The_MPT := MPT_Sets.Element (Position); Process (The_MPT.Main, The_MPT.Project, The_MPT.Tree); exit when Position = Last; MPT_Sets.Next (Position); end loop; end; for Closure of Closures loop Result.Append (Closure); end loop; Cleanup; exception when Ex : others => Debug_Output (Ada.Exceptions.Exception_Information (Ex)); Result.Clear; Status := Unknown_Error; end Get_Closures; -------------- -- Get_Line -- -------------- procedure Get_Line (File : Text_File; Line : out String; Last : out Natural) is C : Character; procedure Advance; ------------- -- Advance -- ------------- procedure Advance is begin if File.Cursor = File.Buffer_Len then File.Buffer_Len := Read (FD => File.FD, A => File.Buffer'Address, N => File.Buffer'Length); if File.Buffer_Len = 0 then File.End_Of_File_Reached := True; return; else File.Cursor := 1; end if; else File.Cursor := File.Cursor + 1; end if; end Advance; -- Start of processing for Get_Line begin if File = null then GPR.Com.Fail ("Get_Line attempted on an invalid Text_File"); elsif File.Out_File then GPR.Com.Fail ("Get_Line attempted on an out file"); end if; Last := Line'First - 1; if not File.End_Of_File_Reached then loop C := File.Buffer (File.Cursor); exit when C = ASCII.CR or else C = ASCII.LF; Last := Last + 1; Line (Last) := C; Advance; if File.End_Of_File_Reached then return; end if; exit when Last = Line'Last; end loop; if C = ASCII.CR or else C = ASCII.LF then Advance; if File.End_Of_File_Reached then return; end if; end if; if C = ASCII.CR and then File.Buffer (File.Cursor) = ASCII.LF then Advance; end if; end if; end Get_Line; -------------- -- Get_Line -- -------------- function Get_Line (File : Text_File; Max_Length : Positive := 4096) return String is Result : String (1 .. Max_Length); Last : Natural; begin Get_Line (File, Result, Last); return Result (1 .. Last); end Get_Line; ------------------ -- Get_Switches -- ------------------ procedure Get_Switches (Source : GPR.Source_Id; Pkg_Name : Name_Id; Project_Tree : Project_Tree_Ref; Value : out Variable_Value; Is_Default : out Boolean) is begin Get_Switches (Source_File => Source.File, Source_Lang => Source.Language.Name, Source_Prj => Source.Project, Pkg_Name => Pkg_Name, Project_Tree => Project_Tree, Value => Value, Is_Default => Is_Default); end Get_Switches; procedure Get_Switches (Source_File : File_Name_Type; Source_Lang : Name_Id; Source_Prj : Project_Id; Pkg_Name : Name_Id; Project_Tree : Project_Tree_Ref; Value : out Variable_Value; Is_Default : out Boolean; Test_Without_Suffix : Boolean := False; Check_ALI_Suffix : Boolean := False) is Project : constant Project_Id := Ultimate_Extending_Project_Of (Source_Prj); Pkg : constant Package_Id := GPR.Util.Value_Of (Name => Pkg_Name, In_Packages => Project.Decl.Packages, Shared => Project_Tree.Shared); Lang : Language_Ptr; begin Is_Default := False; if Source_File /= No_File then Value := GPR.Util.Value_Of (Name => Name_Id (Source_File), Attribute_Or_Array_Name => Name_Switches, In_Package => Pkg, Shared => Project_Tree.Shared, Allow_Wildcards => True); end if; if Value = Nil_Variable_Value and then Test_Without_Suffix then Lang := Get_Language_From_Name (Project, Get_Name_String (Source_Lang)); if Lang /= null then declare Naming : Lang_Naming_Data renames Lang.Config.Naming_Data; SF_Name : constant String := Get_Name_String (Source_File); Last : Positive := SF_Name'Length; Name : String (1 .. Last + 3); Spec_Suffix : String := Get_Name_String (Naming.Spec_Suffix); Body_Suffix : String := Get_Name_String (Naming.Body_Suffix); Truncated : Boolean := False; begin Canonical_Case_File_Name (Spec_Suffix); Canonical_Case_File_Name (Body_Suffix); Name (1 .. Last) := SF_Name; if Last > Body_Suffix'Length and then Name (Last - Body_Suffix'Length + 1 .. Last) = Body_Suffix then Truncated := True; Last := Last - Body_Suffix'Length; end if; if not Truncated and then Last > Spec_Suffix'Length and then Name (Last - Spec_Suffix'Length + 1 .. Last) = Spec_Suffix then Truncated := True; Last := Last - Spec_Suffix'Length; end if; if Truncated then Value := GPR.Util.Value_Of (Name => Get_Name_Id (Name (1 .. Last)), Attribute_Or_Array_Name => Name_Switches, In_Package => Pkg, Shared => Project_Tree.Shared, Allow_Wildcards => True); end if; if Value = Nil_Variable_Value and then Check_ALI_Suffix then Last := SF_Name'Length; while Name (Last) /= '.' loop Last := Last - 1; end loop; Value := GPR.Util.Value_Of (Get_Name_Id (Name (1 .. Last) & "ali"), Attribute_Or_Array_Name => Name_Switches, In_Package => Pkg, Shared => Project_Tree.Shared, Allow_Wildcards => True); end if; end; end if; end if; if Value = Nil_Variable_Value then Is_Default := True; Value := GPR.Util.Value_Of (Name => Source_Lang, Attribute_Or_Array_Name => Name_Switches, In_Package => Pkg, Shared => Project_Tree.Shared, Force_Lower_Case_Index => True); end if; if Value = Nil_Variable_Value then Value := GPR.Util.Value_Of (Name => All_Other_Names, Attribute_Or_Array_Name => Name_Switches, In_Package => Pkg, Shared => Project_Tree.Shared, Force_Lower_Case_Index => True); end if; if Value = Nil_Variable_Value then Value := GPR.Util.Value_Of (Name => Source_Lang, Attribute_Or_Array_Name => Name_Default_Switches, In_Package => Pkg, Shared => Project_Tree.Shared); end if; end Get_Switches; ---------------- -- Initialize -- ---------------- procedure Initialize (Iter : out Source_Info_Iterator; For_Project : Name_Id) is Ind : constant Natural := Source_Info_Project_HTable.Get (For_Project); begin if Ind = 0 then Iter := (No_Source_Info, 0); else Iter := Source_Info_Table.Table (Ind); end if; end Initialize; ------------------------------ -- Initialize_Source_Record -- ------------------------------ procedure Initialize_Source_Record (Source : GPR.Source_Id; Always : Boolean := False) is Main_Source_File : File_Name_Type := Source.File; procedure Set_Object_Project (Obj_Dir : String; Obj_Proj : Project_Id; Obj_Path : Path_Name_Type; Stamp : Time_Stamp_Type); -- Update information about object file, switches file,... ------------------------ -- Set_Object_Project -- ------------------------ procedure Set_Object_Project (Obj_Dir : String; Obj_Proj : Project_Id; Obj_Path : Path_Name_Type; Stamp : Time_Stamp_Type) is begin Source.Object_Project := Obj_Proj; Source.Object_Path := Obj_Path; Source.Object_TS := Stamp; if Source.Language.Config.Dependency_Kind /= None then declare Dep_Path : constant String := Normalize_Pathname (Get_Name_String (Source.Dep_Name), Resolve_Links => Opt.Follow_Links_For_Files, Directory => Obj_Dir); begin if not Gprls_Mode or else Obj_Proj.Extends = No_Project or else Is_Regular_File (Dep_Path) then Source.Dep_Path := Create_Name (Dep_Path); Source.Dep_TS := Unknown_Attributes; end if; end; end if; -- Get the path of the switches file, even if Opt.Check_Switches is -- not set, as switch -s may be in the Builder switches that have not -- been scanned yet. declare Switches_Path : constant String := Normalize_Pathname (Get_Name_String (Source.Switches), Resolve_Links => Opt.Follow_Links_For_Files, Directory => Obj_Dir); begin Source.Switches_Path := Create_Name (Switches_Path); if Stamp /= Empty_Time_Stamp then Source.Switches_TS := File_Stamp (Source.Switches_Path); end if; end; end Set_Object_Project; Obj_Proj : Project_Id; begin -- Nothing to do if source record has already been fully initialized if Source.Initialized and not Always then return; end if; -- Systematically recompute the time stamp Source.Source_TS := File_Stamp (Source.Path.Display_Name); -- Parse the source file to check whether we have a subunit if Source.Language.Config.Kind = Unit_Based and then Source.Kind = Impl and then Is_Subunit (Source) then Source.Kind := Sep; end if; if Source.Language.Config.Object_Generated and then Is_Compilable (Source) then -- First, get the correct object file name and dependency file if Source.Unit /= No_Unit_Index and then Source.Kind = Spec and then Other_Part (Source) /= No_Source then Main_Source_File := Other_Part (Source).File; Source.Object := Object_Name (Main_Source_File, Source.Language.Config.Object_File_Suffix); Source.Dep_Name := Dependency_Name (Source.Object, Source.Language.Config.Dependency_Kind); end if; if Source.Index /= 0 then Source.Object := Object_Name (Source_File_Name => Main_Source_File, Source_Index => Source.Index, Index_Separator => Source.Language.Config.Multi_Unit_Object_Separator, Object_File_Suffix => Source.Language.Config.Object_File_Suffix); Source.Dep_Name := Dependency_Name (Source.Object, Source.Language.Config.Dependency_Kind); end if; -- Find the object file for that source. It could be either in the -- current project or in an extended project (it might actually not -- exist yet in the ultimate extending project, but if not found -- elsewhere that's where we'll expect to find it). Obj_Proj := Source.Project; while Obj_Proj /= No_Project loop if Obj_Proj.Object_Directory /= No_Path_Information then declare Dir : constant String := Get_Name_String (Obj_Proj.Object_Directory.Display_Name); Object_Path : constant String := Normalize_Pathname (Name => Get_Name_String (Source.Object), Resolve_Links => Opt.Follow_Links_For_Files, Directory => Dir); Obj_Path : constant Path_Name_Type := Create_Name (Object_Path); Stamp : Time_Stamp_Type := Empty_Time_Stamp; begin -- For specs, we do not check object files if there is a -- body. This saves a system call. On the other hand, we do -- need to know the object_path, in case the user has passed -- the .ads on the command line to compile the spec only. if Source.Kind /= Spec or else Source.Unit = No_Unit_Index or else Source.Unit.File_Names (Impl) = No_Source then Stamp := File_Stamp (Obj_Path); end if; if Stamp /= Empty_Time_Stamp or else (Obj_Proj.Extended_By = No_Project and then Source.Object_Project = No_Project) then Set_Object_Project (Dir, Obj_Proj, Obj_Path, Stamp); end if; end; end if; Obj_Proj := Obj_Proj.Extended_By; end loop; if Source.Language.Config.Dependency_Kind /= None and then Source.Dep_Path = No_Path then -- If we have not found a dependency file in the object -- project, it means that the Source.Project is extended and that -- we are in gprls node. We need to look for an actual dependency -- file in the extended projects. If none is found, the dependency -- file is set in the ultimate extending project. Obj_Proj := Source.Project; while Obj_Proj /= No_Project loop if Obj_Proj.Object_Directory /= No_Path_Information then declare Dir : constant String := Get_Name_String (Obj_Proj.Object_Directory.Display_Name); Dep_Path_Name : constant String := Normalize_Pathname (Name => Get_Name_String (Source.Dep_Name), Resolve_Links => Opt.Follow_Links_For_Files, Directory => Dir); Dep_Path : constant Path_Name_Type := Create_Name (Dep_Path_Name); Stamp : Time_Stamp_Type := Empty_Time_Stamp; begin if Source.Kind /= Spec or else Source.Unit = No_Unit_Index or else Source.Unit.File_Names (Impl) = No_Source then Stamp := File_Stamp (Dep_Path); end if; if Stamp /= Empty_Time_Stamp or else (Source.Dep_Path = No_Path and then Obj_Proj.Extended_By = No_Project) then Source.Dep_Path := Dep_Path; Source.Dep_TS := Unknown_Attributes; end if; end; end if; Obj_Proj := Obj_Proj.Extended_By; end loop; end if; elsif Source.Language.Config.Dependency_Kind = Makefile then declare Object_Dir : constant String := Get_Name_String (Source.Project.Object_Directory.Display_Name); Dep_Path : constant String := Normalize_Pathname (Name => Get_Name_String (Source.Dep_Name), Resolve_Links => Opt.Follow_Links_For_Files, Directory => Object_Dir); begin Source.Dep_Path := Create_Name (Dep_Path); Source.Dep_TS := Unknown_Attributes; end; end if; Source.Initialized := True; end Initialize_Source_Record; --------------------------------- -- Is_Ada_Predefined_File_Name -- --------------------------------- function Is_Ada_Predefined_File_Name (Fname : File_Name_Type) return Boolean is subtype Str8 is String (1 .. 8); Predef_Names : constant array (1 .. 12) of Str8 := ("ada ", -- Ada "interfac", -- Interfaces "system ", -- System "gnat ", -- GNAT "calendar", -- Calendar "machcode", -- Machine_Code "unchconv", -- Unchecked_Conversion "unchdeal", -- Unchecked_Deallocation "directio", -- Direct_IO "ioexcept", -- IO_Exceptions "sequenio", -- Sequential_IO "text_io "); -- Text_IO begin Get_Name_String (Fname); -- Check for extension (not .ads/.adb) if Name_Len > 4 and then Name_Buffer (Name_Len - 3) = '.' then if not (Name_Buffer (Name_Len - 3 .. Name_Len) = ".ads" or Name_Buffer (Name_Len - 3 .. Name_Len) = ".adb") then return False; end if; end if; -- Remove extension (.ads/.adb) if present if Name_Len > 4 and then Name_Buffer (Name_Len - 3) = '.' then Name_Len := Name_Len - 4; end if; -- Definitely predefined if prefix is a- i- or s- followed by letter if Name_Len >= 3 and then Name_Buffer (2) = '-' and then (Name_Buffer (1) = 'a' or else Name_Buffer (1) = 'g' or else Name_Buffer (1) = 'i' or else Name_Buffer (1) = 's') and then (Name_Buffer (3) in 'a' .. 'z' or else Name_Buffer (3) in 'A' .. 'Z') then return True; -- Definitely false if longer than 12 characters (8.3) elsif Name_Len > 8 then return False; end if; -- Otherwise check against special list, first padding to 8 characters while Name_Len < 8 loop Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := ' '; end loop; for J in Predef_Names'Range loop if Name_Buffer (1 .. 8) = Predef_Names (J) then return True; end if; end loop; return False; end Is_Ada_Predefined_File_Name; ---------------------------- -- Is_Ada_Predefined_Unit -- ---------------------------- function Is_Ada_Predefined_Unit (Unit : String) return Boolean is Lower_Unit : String := Unit; begin To_Lower (Lower_Unit); return Lower_Unit in "ada" | "gnat" | "interfaces" | "system" | "calendar" | "machine_code" | "unchecked_conversion" | "unchecked_deallocation" | "direct_io" | "io_exceptions" | "sequential_io" | "text_io" or else Starts_With (Lower_Unit, "ada.") or else Starts_With (Lower_Unit, "gnat.") or else Starts_With (Lower_Unit, "system.") or else Starts_With (Lower_Unit, "interfaces."); end Is_Ada_Predefined_Unit; ---------------------------- -- Is_Pragmas_Config_File -- ---------------------------- function Is_Pragmas_Config_File (Fname : File_Name_Type) return Boolean is Filename : constant String := Get_Name_String (Fname); Pragma_Config_File_Suffix : constant String := ".adc"; E_First : constant Integer := Filename'Last - Pragma_Config_File_Suffix'Length + 1; E_Last : constant Integer := Filename'Last; begin if Filename'Length > Pragma_Config_File_Suffix'Length then return (Filename (E_First .. E_Last) = Pragma_Config_File_Suffix); else return False; end if; end Is_Pragmas_Config_File; ---------------- -- Is_Subunit -- ---------------- function Is_Subunit (Source : GPR.Source_Id) return Boolean is Src_Ind : Source_File_Index; begin if Source.Kind = Sep then return True; -- A Spec, a file based language source or a body with a spec cannot be -- a subunit. elsif Source.Kind = Spec or else Source.Unit = No_Unit_Index or else Other_Part (Source) /= No_Source then return False; end if; -- Here, we are assuming that the language is Ada, as it is the only -- unit based language that we know. pragma Assert (Source.Path /= No_Path_Information, "no path information for " & Get_Name_String_Safe (Source.File) & ' ' & Source.Locally_Removed'Img); Src_Ind := Sinput.Load_File (Get_Name_String (Source.Path.Display_Name)); return Sinput.Source_File_Is_Subunit (Src_Ind); end Is_Subunit; -------------- -- Is_Valid -- -------------- function Is_Valid (File : Text_File) return Boolean is begin return File /= null; end Is_Valid; ---------- -- Next -- ---------- procedure Next (Iter : in out Source_Info_Iterator) is begin if Iter.Next = 0 then Iter.Info := No_Source_Info; else Iter := Source_Info_Table.Table (Iter.Next); end if; end Next; -------------------- -- Object_Project -- -------------------- function Object_Project (Project : Project_Id; Must_Be_Writable : Boolean := False) return Project_Id is Result : Project_Id := No_Project; procedure Check_Project (P : Project_Id); -- Find a project with an object dir ------------------- -- Check_Project -- ------------------- procedure Check_Project (P : Project_Id) is begin if P.Qualifier = Aggregate or else P.Qualifier = Aggregate_Library then declare List : Aggregated_Project_List := P.Aggregated_Projects; begin -- Look for a non aggregate project until one is found while Result = No_Project and then List /= null loop Check_Project (List.Project); List := List.Next; end loop; end; elsif P.Object_Directory.Name /= No_Path then if not Must_Be_Writable or else Is_Writable_File (Get_Name_String (P.Object_Directory.Display_Name)) then Result := P; end if; end if; end Check_Project; begin Check_Project (Project); return Result; end Object_Project; ---------- -- Open -- ---------- procedure Open (File : out Text_File; Name : String) is FD : File_Descriptor; File_Name : String (1 .. Name'Length + 1); begin File_Name (1 .. Name'Length) := Name; File_Name (File_Name'Last) := ASCII.NUL; FD := Open_Read (Name => File_Name'Address, Fmode => GNAT.OS_Lib.Text); if FD = Invalid_FD then File := null; else File := new Text_File_Data; File.FD := FD; File.Buffer_Len := Read (FD => FD, A => File.Buffer'Address, N => File.Buffer'Length); if File.Buffer_Len = 0 then File.End_Of_File_Reached := True; else File.Cursor := 1; end if; end if; end Open; --------- -- Put -- --------- procedure Put (Into_List : in out Name_List_Index; From_List : String_List_Id; In_Tree : Project_Tree_Ref; Lower_Case : Boolean := False) is Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared; Current_Name : Name_List_Index; List : String_List_Id; Element : String_Element; Last : Name_List_Index := Name_List_Table.Last (Shared.Name_Lists); Value : Name_Id; begin Current_Name := Into_List; while Current_Name /= No_Name_List and then Shared.Name_Lists.Table (Current_Name).Next /= No_Name_List loop Current_Name := Shared.Name_Lists.Table (Current_Name).Next; end loop; List := From_List; while List /= Nil_String loop Element := Shared.String_Elements.Table (List); Value := Element.Value; if Lower_Case then Get_Name_String (Value); To_Lower (Name_Buffer (1 .. Name_Len)); Value := Name_Find; end if; Name_List_Table.Append (Shared.Name_Lists, (Name => Value, Next => No_Name_List)); Last := Last + 1; if Current_Name = No_Name_List then Into_List := Last; else Shared.Name_Lists.Table (Current_Name).Next := Last; end if; Current_Name := Last; List := Element.Next; end loop; end Put; procedure Put (File : Text_File; S : String) is Len : Integer; begin if File = null then GPR.Com.Fail ("Attempted to write on an invalid Text_File"); elsif not File.Out_File then GPR.Com.Fail ("Attempted to write an in Text_File"); end if; if File.Buffer_Len + S'Length > File.Buffer'Last then -- Write buffer Len := Write (File.FD, File.Buffer'Address, File.Buffer_Len); if Len /= File.Buffer_Len then GPR.Com.Fail ("Failed to write to an out Text_File"); end if; File.Buffer_Len := 0; end if; File.Buffer (File.Buffer_Len + 1 .. File.Buffer_Len + S'Length) := S; File.Buffer_Len := File.Buffer_Len + S'Length; end Put; -------------- -- Put_Line -- -------------- procedure Put_Line (File : Text_File; Line : String) is L : String (1 .. Line'Length + 1); begin L (1 .. Line'Length) := Line; L (L'Last) := ASCII.LF; Put (File, L); end Put_Line; --------------------------- -- Read_Source_Info_File -- --------------------------- procedure Read_Source_Info_File (Tree : Project_Tree_Ref) is File : Text_File; Info : Source_Info_Iterator; Proj : Name_Id; procedure Report_Error; ------------------ -- Report_Error -- ------------------ procedure Report_Error is begin Write_Line ("errors in source info file """ & Tree.Source_Info_File_Name.all & '"'); Tree.Source_Info_File_Exists := False; end Report_Error; begin Source_Info_Project_HTable.Reset; Source_Info_Table.Init; if Tree.Source_Info_File_Name = null then Tree.Source_Info_File_Exists := False; return; end if; Open (File, Tree.Source_Info_File_Name.all); if not Is_Valid (File) then if Opt.Verbosity_Level > Opt.Low then Write_Line ("source info file " & Tree.Source_Info_File_Name.all & " does not exist"); end if; Tree.Source_Info_File_Exists := False; return; end if; Tree.Source_Info_File_Exists := True; if Opt.Verbosity_Level > Opt.Low then Write_Line ("Reading source info file " & Tree.Source_Info_File_Name.all); end if; Source_Loop : while not End_Of_File (File) loop Info := (new Source_Info_Data, 0); Source_Info_Table.Increment_Last; -- project name Get_Line (File, Name_Buffer, Name_Len); Proj := Name_Find; Info.Info.Project := Proj; Info.Next := Source_Info_Project_HTable.Get (Proj); Source_Info_Project_HTable.Set (Proj, Source_Info_Table.Last); if End_Of_File (File) then Report_Error; exit Source_Loop; end if; -- language name Get_Line (File, Name_Buffer, Name_Len); Info.Info.Language := Name_Find; if End_Of_File (File) then Report_Error; exit Source_Loop; end if; -- kind Get_Line (File, Name_Buffer, Name_Len); Info.Info.Kind := Source_Kind'Value (Name_Buffer (1 .. Name_Len)); if End_Of_File (File) then Report_Error; exit Source_Loop; end if; -- display path name Get_Line (File, Name_Buffer, Name_Len); Info.Info.Display_Path_Name := Name_Find; Info.Info.Path_Name := Info.Info.Display_Path_Name; if End_Of_File (File) then Report_Error; exit Source_Loop; end if; -- optional fields Option_Loop : loop Get_Line (File, Name_Buffer, Name_Len); exit Option_Loop when Name_Len = 0; if Name_Len <= 2 then Report_Error; exit Source_Loop; else if Name_Buffer (1 .. 2) = "P=" then Name_Buffer (1 .. Name_Len - 2) := Name_Buffer (3 .. Name_Len); Name_Len := Name_Len - 2; Info.Info.Path_Name := Name_Find; elsif Name_Buffer (1 .. 2) = "U=" then Name_Buffer (1 .. Name_Len - 2) := Name_Buffer (3 .. Name_Len); Name_Len := Name_Len - 2; Info.Info.Unit_Name := Name_Find; elsif Name_Buffer (1 .. 2) = "I=" then Info.Info.Index := Int'Value (Name_Buffer (3 .. Name_Len)); elsif Name_Buffer (1 .. Name_Len) = "N=Y" then Info.Info.Naming_Exception := Yes; elsif Name_Buffer (1 .. Name_Len) = "N=I" then Info.Info.Naming_Exception := Inherited; else Report_Error; exit Source_Loop; end if; end if; end loop Option_Loop; Source_Info_Table.Table (Source_Info_Table.Last) := Info; end loop Source_Loop; Close (File); exception when others => Close (File); Report_Error; end Read_Source_Info_File; ------------------- -- Relative_Path -- ------------------- function Relative_Path (Pathname : String; To : String; Directory : Boolean := True) return String is function Ensure_Directory (Path : String) return String; -- Returns Path with an added directory separator if needed ---------------------- -- Ensure_Directory -- ---------------------- function Ensure_Directory (Path : String) return String is begin if Path'Length = 0 then return "./"; elsif not Directory or else Is_Directory_Separator (Path (Path'Last)) then return Path; else return Path & Directory_Separator; end if; end Ensure_Directory; -- Local variables Dir_Sep_Map : constant Character_Mapping := To_Mapping ("\", "/"); P : String (1 .. Pathname'Length) := Pathname; T : String (1 .. To'Length) := To; Pi : Natural; -- common prefix ending N : Natural := 0; -- Start of processing for Relative_Path begin pragma Assert (Is_Absolute_Path (Pathname)); pragma Assert (Is_Absolute_Path (To)); -- Use canonical directory separator Translate (Source => P, Mapping => Dir_Sep_Map); Translate (Source => T, Mapping => Dir_Sep_Map); -- First check for common prefix Pi := 1; while Pi < P'Last and then Pi < T'Last and then P (Pi) = T (Pi) loop Pi := Pi + 1; end loop; -- Cut common prefix at a directory separator while Pi > P'First and then P (Pi) /= '/' loop Pi := Pi - 1; end loop; -- Count directory under prefix in P, these will be replaced by the -- corresponding number of "..". N := Ada.Strings.Fixed.Count (T (Pi + 1 .. T'Last), "/"); if T (T'Last) /= '/' then N := N + 1; end if; return N * "../" & Ensure_Directory (P (Pi + 1 .. P'Last)); end Relative_Path; ---------------------- -- Set_Program_Name -- ---------------------- procedure Set_Program_Name (N : String) is begin Program_Name := new String'(N); end Set_Program_Name; ------------------- -- Source_Dir_Of -- ------------------- function Source_Dir_Of (Source : Source_Id) return String is Path : constant String := Get_Name_String (Source.Path.Name); begin return Path (Path'First .. Path'Last - Natural (Length_Of_Name (Source.File))); end Source_Dir_Of; -------------------- -- Source_Info_Of -- -------------------- function Source_Info_Of (Iter : Source_Info_Iterator) return Source_Info is begin return Iter.Info; end Source_Info_Of; ----------- -- Split -- ----------- function Split (Source : String; Separator : String) return Name_Array_Type is Start : Positive := Source'First; Finish : Positive; package Name_Ids is new Ada.Containers.Vectors (Positive, Name_Id); List : Name_Ids.Vector; procedure Add_String (S : String); ---------------- -- Add_String -- ---------------- procedure Add_String (S : String) is begin if S'Length > 0 then List.Append (Get_Name_Id (S)); end if; end Add_String; begin if Separator'Length = 0 or else Index (Source, Separator) = 0 then -- List with one string = Argument Add_String (Source); else if Index (Source, Separator) = Start then Start := Start + Separator'Length; end if; loop if Index (Source (Start .. Source'Last), Separator) = 0 then Add_String (Source (Start .. Source'Last)); exit; else Finish := Index (Source (Start .. Source'Last), Separator) - 1; Add_String (Source (Start .. Finish)); Start := Finish + 1 + Separator'Length; exit when Start > Source'Last; end if; end loop; end if; return Result : Name_Array_Type (1 .. Integer (List.Length)) do for J in Result'Range loop Result (J) := List.Element (J); end loop; end return; end Split; ------------------- -- To_Time_Stamp -- ------------------- function To_Time_Stamp (Time : Calendar.Time) return Stamps.Time_Stamp_Type is begin return Time_Stamp_Type (Image (Time, "%Y%m%d%H%M%S")); end To_Time_Stamp; ---------------------- -- To_UTC_Timestamp -- ---------------------- function To_UTC_Time_Stamp (Time : Calendar.Time) return Stamps.Time_Stamp_Type is use type Ada.Calendar.Time; begin return To_Time_Stamp (Time - Duration (UTC_Time_Offset (Time)) * 60); end To_UTC_Time_Stamp; -------------- -- UTC_Time -- -------------- function UTC_Time return Time_Stamp_Type is begin return To_UTC_Time_Stamp (Ada.Calendar.Clock); end UTC_Time; -------------- -- Value_Of -- -------------- function Value_Of (Variable : Variable_Value; Default : String) return String is begin if Variable.Kind /= Single or else Variable.Default or else Variable.Value = No_Name then return Default; else return Get_Name_String (Variable.Value); end if; end Value_Of; function Value_Of (Index : Name_Id; In_Array : Array_Element_Id; Shared : Shared_Project_Tree_Data_Access) return Name_Id is Current : Array_Element_Id; Element : Array_Element; Real_Index : Name_Id := Index; begin Current := In_Array; if Current = No_Array_Element then return No_Name; end if; Element := Shared.Array_Elements.Table (Current); if not Element.Index_Case_Sensitive then Get_Name_String (Index); To_Lower (Name_Buffer (1 .. Name_Len)); Real_Index := Name_Find; end if; while Current /= No_Array_Element loop Element := Shared.Array_Elements.Table (Current); if Real_Index = Element.Index then exit when Element.Value.Kind /= Single; exit when Element.Value.Value = Empty_String; return Element.Value.Value; else Current := Element.Next; end if; end loop; return No_Name; end Value_Of; function Value_Of (Index : Name_Id; Src_Index : Int := 0; In_Array : Array_Element_Id; Shared : Shared_Project_Tree_Data_Access; Force_Lower_Case_Index : Boolean := False; Allow_Wildcards : Boolean := False) return Variable_Value is Current : Array_Element_Id; Element : Array_Element; Real_Index_1 : Name_Id; Real_Index_2 : Name_Id; begin Current := In_Array; if Current = No_Array_Element then return Nil_Variable_Value; end if; Element := Shared.Array_Elements.Table (Current); Real_Index_1 := Index; if (not Element.Index_Case_Sensitive or else Force_Lower_Case_Index) and then Index /= All_Other_Names then Get_Name_String (Index); To_Lower (Name_Buffer (1 .. Name_Len)); Real_Index_1 := Name_Find; end if; while Current /= No_Array_Element loop Element := Shared.Array_Elements.Table (Current); Real_Index_2 := Element.Index; if (not Element.Index_Case_Sensitive or else Force_Lower_Case_Index) and then Element.Index /= All_Other_Names then Get_Name_String (Element.Index); To_Lower (Name_Buffer (1 .. Name_Len)); Real_Index_2 := Name_Find; end if; if Src_Index = Element.Src_Index and then (Real_Index_1 = Real_Index_2 or else (Real_Index_2 /= All_Other_Names and then Allow_Wildcards and then Match (Get_Name_String (Real_Index_1), Compile (Get_Name_String (Real_Index_2), Glob => True)))) then return Element.Value; else Current := Element.Next; end if; end loop; return Nil_Variable_Value; end Value_Of; function Value_Of (Name : Name_Id; Index : Int := 0; Attribute_Or_Array_Name : Name_Id; In_Package : Package_Id; Shared : Shared_Project_Tree_Data_Access; Force_Lower_Case_Index : Boolean := False; Allow_Wildcards : Boolean := False) return Variable_Value is The_Array : Array_Element_Id; The_Attribute : Variable_Value := Nil_Variable_Value; begin if In_Package /= No_Package then -- First, look if there is an array element that fits The_Array := Value_Of (Name => Attribute_Or_Array_Name, In_Arrays => Shared.Packages.Table (In_Package).Decl.Arrays, Shared => Shared); The_Attribute := Value_Of (Index => Name, Src_Index => Index, In_Array => The_Array, Shared => Shared, Force_Lower_Case_Index => Force_Lower_Case_Index, Allow_Wildcards => Allow_Wildcards); -- If there is no array element, look for a variable if The_Attribute = Nil_Variable_Value then The_Attribute := Value_Of (Variable_Name => Attribute_Or_Array_Name, In_Variables => Shared.Packages.Table (In_Package).Decl.Attributes, Shared => Shared); end if; end if; return The_Attribute; end Value_Of; function Value_Of (Index : Name_Id; In_Array : Name_Id; In_Arrays : Array_Id; Shared : Shared_Project_Tree_Data_Access) return Name_Id is Current : Array_Id; The_Array : Array_Data; begin Current := In_Arrays; while Current /= No_Array loop The_Array := Shared.Arrays.Table (Current); if The_Array.Name = In_Array then return Value_Of (Index, In_Array => The_Array.Value, Shared => Shared); else Current := The_Array.Next; end if; end loop; return No_Name; end Value_Of; function Value_Of (Name : Name_Id; In_Arrays : Array_Id; Shared : Shared_Project_Tree_Data_Access) return Array_Element_Id is Current : Array_Id; The_Array : Array_Data; begin Current := In_Arrays; while Current /= No_Array loop The_Array := Shared.Arrays.Table (Current); if The_Array.Name = Name then return The_Array.Value; else Current := The_Array.Next; end if; end loop; return No_Array_Element; end Value_Of; function Value_Of (Name : Name_Id; In_Packages : Package_Id; Shared : Shared_Project_Tree_Data_Access) return Package_Id is Current : Package_Id; The_Package : Package_Element; begin Current := In_Packages; while Current /= No_Package loop The_Package := Shared.Packages.Table (Current); exit when The_Package.Name /= No_Name and then The_Package.Name = Name; Current := The_Package.Next; end loop; return Current; end Value_Of; function Value_Of (Variable_Name : Name_Id; In_Variables : Variable_Id; Shared : Shared_Project_Tree_Data_Access) return Variable_Value is Current : Variable_Id; The_Variable : Variable; begin Current := In_Variables; while Current /= No_Variable loop The_Variable := Shared.Variable_Elements.Table (Current); if Variable_Name = The_Variable.Name then return The_Variable.Value; else Current := The_Variable.Next; end if; end loop; return Nil_Variable_Value; end Value_Of; ------------------------ -- Write_Program_Name -- ------------------------ procedure Write_Program_Name is begin if Program_Name /= null then Write_Str (Program_Name.all & ": "); end if; end Write_Program_Name; ---------------------------- -- Write_Source_Info_File -- ---------------------------- procedure Write_Source_Info_File (Tree : Project_Tree_Ref) is Iter : Source_Iterator := For_Each_Source (Tree); Source : GPR.Source_Id; File : Text_File; begin if Opt.Verbosity_Level > Opt.Low then Write_Line ("Writing new source info file " & Tree.Source_Info_File_Name.all); end if; Create (File, Tree.Source_Info_File_Name.all); if not Is_Valid (File) then Write_Line ("warning: unable to create source info file """ & Tree.Source_Info_File_Name.all & '"'); return; end if; loop Source := Element (Iter); exit when Source = No_Source; if not Source.Locally_Removed and then Source.Replaced_By = No_Source then -- Project name Put_Line (File, Get_Name_String (Source.Project.Name)); -- Language name Put_Line (File, Get_Name_String (Source.Language.Name)); -- Kind Put_Line (File, Source.Kind'Img); -- Display path name Put_Line (File, Get_Name_String (Source.Path.Display_Name)); -- Optional lines: -- Path name (P=) if Source.Path.Name /= Source.Path.Display_Name then Put (File, "P="); Put_Line (File, Get_Name_String (Source.Path.Name)); end if; -- Unit name (U=) if Source.Unit /= No_Unit_Index then Put (File, "U="); Put_Line (File, Get_Name_String (Source.Unit.Name)); end if; -- Multi-source index (I=) if Source.Index /= 0 then Put (File, "I="); Put_Line (File, Source.Index'Img); end if; -- Naming exception ("N=T"); if Source.Naming_Exception = Yes then Put_Line (File, "N=Y"); elsif Source.Naming_Exception = Inherited then Put_Line (File, "N=I"); end if; -- Empty line to indicate end of info on this source Put_Line (File, ""); end if; Next (Iter); end loop; Close (File); end Write_Source_Info_File; --------------- -- Write_Str -- --------------- procedure Write_Str (S : String; Max_Length : Positive; Separator : Character) is First : Positive := S'First; Last : Natural := S'Last; begin -- Nothing to do for empty strings if S'Length > 0 then -- Start on a new line if current line is already longer than -- Max_Length. if Positive (Column) >= Max_Length then Write_Eol; end if; -- If length of remainder is longer than Max_Length, we need to -- cut the remainder in several lines. while Positive (Column) + S'Last - First > Max_Length loop -- Try the maximum length possible Last := First + Max_Length - Positive (Column); -- Look for last Separator in the line while Last >= First and then S (Last) /= Separator loop Last := Last - 1; end loop; -- If we do not find a separator, we output the maximum length -- possible. if Last < First then Last := First + Max_Length - Positive (Column); end if; Write_Line (S (First .. Last)); -- Set the beginning of the new remainder First := Last + 1; end loop; -- What is left goes to the buffer, without EOL Write_Str (S (First .. S'Last)); end if; end Write_Str; Libgcc_Subdir_Ptr : Interfaces.C.Strings.chars_ptr; pragma Import (C, Libgcc_Subdir_Ptr, "__gnat_default_libgcc_subdir"); -- Pointer to string indicating the installation subdirectory where a -- default shared libgcc might be found. package Project_Name_Boolean_Htable is new Simple_HTable (Header_Num => Header_Num, Element => Boolean, No_Element => False, Key => Name_Id, Hash => Hash, Equal => "="); Project_Failure : Project_Name_Boolean_Htable.Instance := Project_Name_Boolean_Htable.Nil; -- Record a boolean for project having failed to compile cleanly ------------------------------- -- Binder_Exchange_File_Name -- ------------------------------- function Binder_Exchange_File_Name (Main_Base_Name : File_Name_Type; Prefix : Name_Id) return String_Access is File_Name : constant String := Get_Name_String (Main_Base_Name); begin Get_Name_String (Prefix); Add_Str_To_Name_Buffer (File_Name); Add_Str_To_Name_Buffer (Binder_Exchange_Suffix); return new String'(Name_Buffer (1 .. Name_Len)); end Binder_Exchange_File_Name; ------------------------------ -- Check_Version_And_Help_G -- ------------------------------ -- Common switches for GNU tools Version_Switch : constant String := "--version"; Help_Switch : constant String := "--help"; procedure Check_Version_And_Help_G (Tool_Name : String; Initial_Year : String) is Version_Switch_Present : Boolean := False; Help_Switch_Present : Boolean := False; Next_Arg : Natural; begin -- First check for --version or --help Next_Arg := 1; while Next_Arg <= Argument_Count loop declare Next_Argv : constant String := Argument (Next_Arg); begin if Next_Argv = Version_Switch then Version_Switch_Present := True; elsif Next_Argv = Help_Switch then Help_Switch_Present := True; end if; Next_Arg := Next_Arg + 1; end; end loop; -- If --version was used, display version and exit if Version_Switch_Present then Display_Version (Tool_Name, Initial_Year); Put_Line (Free_Software); New_Line; OS_Exit (0); end if; -- If --help was used, display help and exit if Help_Switch_Present then Usage; New_Line; Put_Line ("Report bugs to report@adacore.com"); OS_Exit (0); end if; end Check_Version_And_Help_G; --------------------- -- Create_Sym_Link -- --------------------- procedure Create_Sym_Link (From, To : String) is function Symlink (Oldpath : System.Address; Newpath : System.Address) return Integer; pragma Import (C, Symlink, "__gnat_symlink"); C_From : constant String := From & ASCII.NUL; C_To : constant String := Relative_Path (Containing_Directory (To), Containing_Directory (From)) & Ada.Directories.Simple_Name (To) & ASCII.NUL; Result : Integer; Success : Boolean; pragma Unreferenced (Result); begin Delete_File (From, Success); Result := Symlink (C_To'Address, C_From'Address); end Create_Sym_Link; ---------------------- -- Create_Sym_Links -- ---------------------- procedure Create_Sym_Links (Lib_Path : String; Lib_Version : String; Lib_Dir : String; Maj_Version : String) is function Symlink (Oldpath : System.Address; Newpath : System.Address) return Integer; pragma Import (C, Symlink, "__gnat_symlink"); Version_Path : String_Access; Success : Boolean; Result : Integer; pragma Unreferenced (Result); begin Version_Path := new String (1 .. Lib_Version'Length + 1); Version_Path (1 .. Lib_Version'Length) := Lib_Version; Version_Path (Version_Path'Last) := ASCII.NUL; if Maj_Version'Length = 0 then declare Newpath : String (1 .. Lib_Path'Length + 1); begin Newpath (1 .. Lib_Path'Length) := Lib_Path; Newpath (Newpath'Last) := ASCII.NUL; Delete_File (Lib_Path, Success); Result := Symlink (Version_Path (1)'Address, Newpath'Address); end; else declare Newpath1 : String (1 .. Lib_Path'Length + 1); Maj_Path : constant String := Lib_Dir & Directory_Separator & Maj_Version; Newpath2 : String (1 .. Maj_Path'Length + 1); Maj_Ver : String (1 .. Maj_Version'Length + 1); begin Newpath1 (1 .. Lib_Path'Length) := Lib_Path; Newpath1 (Newpath1'Last) := ASCII.NUL; Newpath2 (1 .. Maj_Path'Length) := Maj_Path; Newpath2 (Newpath2'Last) := ASCII.NUL; Maj_Ver (1 .. Maj_Version'Length) := Maj_Version; Maj_Ver (Maj_Ver'Last) := ASCII.NUL; Delete_File (Maj_Path, Success); Result := Symlink (Version_Path (1)'Address, Newpath2'Address); Delete_File (Lib_Path, Success); Result := Symlink (Maj_Ver'Address, Newpath1'Address); end; end if; end Create_Sym_Links; ------------------------------------ -- Display_Usage_Version_And_Help -- ------------------------------------ procedure Display_Usage_Version_And_Help is begin Put_Line (" --version Display version and exit"); Put_Line (" --help Display usage and exit"); New_Line; end Display_Usage_Version_And_Help; --------------------- -- Display_Version -- --------------------- procedure Display_Version (Tool_Name : String; Initial_Year : String) is begin Put_Line (Tool_Name & " " & Gpr_Version_String); Put ("Copyright (C) "); Put (Initial_Year); Put ('-'); Put (Current_Year); Put (", "); Put (Copyright_Holder); New_Line; end Display_Version; ---------------------- -- Ensure_Directory -- ---------------------- function Ensure_Directory (Path : String) return String is begin if Path'Length = 0 or else Is_Directory_Separator (Path (Path'Last)) then return Path; else return Path & Directory_Separator; end if; end Ensure_Directory; ---------------------- -- Ensure_Extension -- ---------------------- function Ensure_Extension (Filename : String; Ext : String) return String is begin for Char of reverse Filename loop if Char = '.' then return Filename; elsif Is_Directory_Separator (Char) then exit; end if; end loop; return Filename & Ext; end Ensure_Extension; ------------------- -- Ensure_Suffix -- ------------------- function Ensure_Suffix (Item : String; Suffix : String) return String is begin if Item'Length >= Suffix'Length and then Item (Item'Last - Suffix'Length + 1 .. Item'Last) = Suffix then return Item; else return Item & Suffix; end if; end Ensure_Suffix; -- --------------- -- -- Error_Msg -- -- --------------- -- -- procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is -- pragma Warnings (Off, Msg); -- pragma Warnings (Off, Flag_Location); -- begin -- null; -- end Error_Msg; -- -- ----------------- -- -- Error_Msg_S -- -- ----------------- -- -- procedure Error_Msg_S (Msg : String) is -- pragma Warnings (Off, Msg); -- begin -- null; -- end Error_Msg_S; -- -- ------------------ -- -- Error_Msg_SC -- -- ------------------ -- -- procedure Error_Msg_SC (Msg : String) is -- pragma Warnings (Off, Msg); -- begin -- null; -- end Error_Msg_SC; -- -- ------------------ -- -- Error_Msg_SP -- -- ------------------ -- -- procedure Error_Msg_SP (Msg : String) is -- pragma Warnings (Off, Msg); -- begin -- null; -- end Error_Msg_SP; -------------- -- File_MD5 -- -------------- function File_MD5 (Pathname : String) return Message_Digest is use Stream_IO; C : Context; S : Stream_IO.File_Type; B : Stream_Element_Array (1 .. 100 * 1024); -- Buffer to read chunk of data L : Stream_Element_Offset; begin Open (S, In_File, Pathname); while not End_Of_File (S) loop Read (S, B, L); Update (C, B (1 .. L)); end loop; Close (S); return Digest (C); end File_MD5; -------------- -- As_RPath -- -------------- function As_RPath (Path : String; Case_Sensitive : Boolean) return String is Dir_Sep_Map : constant Character_Mapping := To_Mapping ("\", "/"); begin return Translate (Normalize_Pathname (Path, Resolve_Links => Opt.Follow_Links_For_Dirs, Case_Sensitive => Case_Sensitive), Mapping => Dir_Sep_Map); end As_RPath; -------------------- -- Relative_RPath -- -------------------- function Relative_RPath (Dest, Src, Origin : String) return String is -- Rpaths are always considered case sensitive, as it's a runtime -- property of dynamic objects, so in case of cross compilation is -- independent of the host's way of handling case sensitivity. RP_Src : constant String := As_RPath (Src, False); RP_Dest : constant String := As_RPath (Dest, True); RP_Dest_Insensitive : constant String := As_RPath (Dest, False); begin declare Len : constant Natural := Common_Path_Prefix_Length (RP_Src, RP_Dest_Insensitive); begin if Len = 0 then -- No common prefix: return an absolute path return RP_Dest; else declare Sep_Mode : Boolean := True; Subdir_Count : Natural := 0; begin -- Compute the relative path from Src to Dest. For this we -- need to find the number of subdirectories from the common -- prefix to Src. for I in RP_Src'First + Len .. RP_Src'Last loop if RP_Src (I) = '/' then Sep_Mode := True; elsif Sep_Mode then -- If the previous characters were separators, we are now -- reading a new subdir. Sep_Mode is initialy True so -- that we get here if the first character we see is not -- a separator. Subdir_Count := Subdir_Count + 1; Sep_Mode := False; end if; end loop; return Origin & "/" & Subdir_Count * "../" & RP_Dest (RP_Dest'First + Len .. RP_Dest'Last); end; end if; end; end Relative_RPath; ------------------ -- Concat_Paths -- ------------------ function Concat_Paths (List : String_Vectors.Vector; Separator : String) return String is Length : Natural := Natural (List.Length - 1) * Separator'Length; begin for Path of List loop Length := Length + Path'Length; end loop; declare Ret : String (1 .. Length); Idx : Integer := 1; begin for Path of List loop Ret (Idx .. Idx + Path'Length - 1) := Path; Idx := Idx + Path'Length; if Idx < Ret'Last then Ret (Idx .. Idx + Separator'Length - 1) := Separator; Idx := Idx + Separator'Length; end if; end loop; return Ret; end; end Concat_Paths; ---------------------- -- To_Argument_List -- ---------------------- function To_Argument_List (List : String_Vectors.Vector) return Argument_List is Ret : Argument_List (1 .. Natural (List.Length)); begin for J in 1 .. List.Last_Index loop Ret (J) := new String'(List (J)); end loop; return Ret; end To_Argument_List; ----------- -- Slice -- ----------- function Slice (List : String_Vectors.Vector; From, To : Positive) return String_Vectors.Vector is Ret : String_Vectors.Vector; begin for J in From .. To loop Ret.Append (List (J)); end loop; return Ret; end Slice; ------------------------------ -- Get_Compiler_Driver_Path -- ------------------------------ function Get_Compiler_Driver_Path (Project : Project_Id; Lang : Language_Ptr) return String_Access is begin if Lang.Config.Compiler_Driver_Path = null then declare CL : constant Language_Maps.Cursor := Compiler_Subst_HTable.Find (Lang.Name); Compiler : constant Name_Id := (if Language_Maps.Has_Element (CL) then Language_Maps.Element (CL) else Name_Id (Lang.Config.Compiler_Driver)); -- If --compiler-subst was used to specify an alternate compiler, -- then Language_Maps.Has_Element (CL). In other case set Compiler -- to the Compiler_Driver from the config file. begin -- No compiler found, return now if Compiler = No_Name then return null; end if; declare Compiler_Name : constant String := (if CodePeer_Mode then "codepeer-gcc" elsif GnatProve_Mode and then Lang.Name = Name_Ada then "gnat2why" else Get_Name_String (Compiler)); begin if Compiler_Name = "" then return null; end if; Lang.Config.Compiler_Driver_Path := Locate_Exec_On_Path (Compiler_Name); if Lang.Config.Compiler_Driver_Path = null then Err.Error_Msg (Gprbuild_Flags, "unable to locate """ & Compiler_Name & '"', Project => Project); return null; end if; end; end; end if; return Lang.Config.Compiler_Driver_Path; end Get_Compiler_Driver_Path; ---------------------------- -- Find_Binding_Languages -- ---------------------------- procedure Find_Binding_Languages (Tree : Project_Tree_Ref; Root_Project : Project_Id) is Data : constant Builder_Data_Access := Builder_Data (Tree); B_Index : Binding_Data; Language_Name : Name_Id; Binder_Driver_Name : File_Name_Type := No_File; Binder_Driver_Path : String_Access; Binder_Prefix : Name_Id; Language : Language_Ptr; Config : Language_Config; Project : Project_List; begin -- Have we already processed this tree ? if Data.There_Are_Binder_Drivers and then Data.Binding /= null then return; end if; if Current_Verbosity = High then Debug_Output ("Find_Binding_Languages for", Debug_Name (Tree)); end if; Data.There_Are_Binder_Drivers := False; Project := Tree.Projects; while Project /= null loop Language := Project.Project.Languages; while Language /= No_Language_Index loop Config := Language.Config; Binder_Driver_Name := Config.Binder_Driver; if Language.First_Source /= No_Source and then Binder_Driver_Name /= No_File then Data.There_Are_Binder_Drivers := True; Language_Name := Language.Name; B_Index := Data.Binding; while B_Index /= null and then B_Index.Language_Name /= Language_Name loop B_Index := B_Index.Next; end loop; if B_Index = null then Get_Name_String (Binder_Driver_Name); Binder_Driver_Path := Locate_Exec_On_Path (Name_Buffer (1 .. Name_Len)); if Binder_Driver_Path = null then Fail_Program (Tree, "unable to find binder driver " & Name_Buffer (1 .. Name_Len)); end if; if Current_Verbosity = High then Debug_Output ("Binder_Driver=" & Binder_Driver_Path.all & " for Lang", Language_Name); end if; if Config.Binder_Prefix = No_Name then Binder_Prefix := Empty_String; else Binder_Prefix := Config.Binder_Prefix; end if; B_Index := Data.Binding; while B_Index /= null loop if Binder_Prefix = B_Index.Binder_Prefix then Fail_Program (Tree, "binding prefix cannot be the same for" & " two languages", Exit_Code => E_General); end if; B_Index := B_Index.Next; end loop; Data.Binding := new Binding_Data_Record' (Language => Language, Language_Name => Language_Name, Binder_Driver_Name => Binder_Driver_Name, Binder_Driver_Path => Binder_Driver_Path, Binder_Prefix => Binder_Prefix, Next => Data.Binding); end if; end if; Language := Language.Next; end loop; Project := Project.Next; end loop; if Root_Project.Qualifier = Aggregate then declare Agg : Aggregated_Project_List := Root_Project.Aggregated_Projects; begin while Agg /= null loop Find_Binding_Languages (Agg.Tree, Agg.Project); Agg := Agg.Next; end loop; end; end if; end Find_Binding_Languages; ---------------- -- Get_Target -- ---------------- function Get_Target return String is begin if Target_Name = null or else Target_Name.all = "" then return Sdefault.Hostname; else return Target_Name.all; end if; end Get_Target; -------------------------- -- Has_Incomplete_Withs -- -------------------------- function Has_Incomplete_Withs (Flags : Processing_Flags) return Boolean is (Flags.Incomplete_Withs); -------------------- -- Locate_Runtime -- -------------------- procedure Locate_Runtime (Project_Tree : Project_Tree_Ref; Language : Name_Id) is function Is_RTS_Directory (Path : String) return Boolean; -- Returns True if Path is a directory for a runtime. This simply check -- that Path has a "adalib" subdirectoy, which is a property for -- runtimes on the project path. function Is_Base_Name (Path : String) return Boolean; -- Returns True if Path has no directory separator ---------------------- -- Is_RTS_Directory -- ---------------------- function Is_RTS_Directory (Path : String) return Boolean is begin return Is_Directory (Path & Directory_Separator & "adalib"); end Is_RTS_Directory; -- Local declarations function Find_Rts_In_Path is new GPR.Env.Find_Name_In_Path (Check_Filename => Is_RTS_Directory); ------------------ -- Is_Base_Name -- ------------------ function Is_Base_Name (Path : String) return Boolean is begin for I in Path'Range loop if Is_Directory_Separator (Path (I)) then return False; end if; end loop; return True; end Is_Base_Name; RTS_Name : constant String := GPR.Conf.Runtime_Name_For (Language); Full_Path : String_Access; begin Full_Path := Find_Rts_In_Path (Root_Environment.Project_Path, RTS_Name); if Full_Path /= null then GPR.Conf.Set_Runtime_For (Language, Normalize_Pathname (Full_Path.all)); Free (Full_Path); elsif not Is_Base_Name (RTS_Name) then Fail_Program (Project_Tree, "cannot find RTS " & RTS_Name, Exit_Code => E_General); end if; end Locate_Runtime; ------------------------------ -- Look_For_Default_Project -- ------------------------------ procedure Look_For_Default_Project (Never_Fail : Boolean := False) is begin if No_Project_File then No_Project_File_Found := True; else No_Project_File_Found := False; if Is_Regular_File (Default_Project_File_Name) then Project_File_Name := new String'(Default_Project_File_Name); else -- Check if there is a single project file in the current -- directory. If there is one and only one, use it. declare Dir : Dir_Type; Str : String (1 .. 255); Last : Natural; Single : String_Access := null; begin No_Project_File_Found := True; Open (Dir, "."); loop Read (Dir, Str, Last); exit when Last = 0; if Last > Project_File_Extension'Length and then Is_Regular_File (Str (1 .. Last)) then Canonical_Case_File_Name (Str (1 .. Last)); if Str (Last - Project_File_Extension'Length + 1 .. Last) = Project_File_Extension then No_Project_File_Found := False; if Single = null then Single := new String'(Str (1 .. Last)); else -- There are several project files in the current -- directory. Reset Single to null and exit. Single := null; exit; end if; end if; end if; end loop; Close (Dir); Project_File_Name := Single; end; end if; end if; if No_Project_File_Found or else (Never_Fail and then Project_File_Name = null) then Project_File_Name := new String'(Executable_Prefix_Path & Implicit_Project_File_Path); if not Is_Regular_File (Project_File_Name.all) then Project_File_Name := null; end if; end if; if not Quiet_Output and then Project_File_Name /= null then Put ("using project file "); Put_Line (Project_File_Name.all); end if; end Look_For_Default_Project; ------------------- -- Major_Id_Name -- ------------------- function Major_Id_Name (Lib_Filename : String; Lib_Version : String) return String is Maj_Version : constant String := Lib_Version; Last_Maj : Positive; Last : Positive; Ok_Maj : Boolean := False; begin Last_Maj := Maj_Version'Last; while Last_Maj > Maj_Version'First loop if Maj_Version (Last_Maj) in '0' .. '9' then Last_Maj := Last_Maj - 1; else Ok_Maj := Last_Maj /= Maj_Version'Last and then Maj_Version (Last_Maj) = '.'; if Ok_Maj then Last_Maj := Last_Maj - 1; end if; exit; end if; end loop; if Ok_Maj then Last := Last_Maj; while Last > Maj_Version'First loop if Maj_Version (Last) in '0' .. '9' then Last := Last - 1; else Ok_Maj := Last /= Last_Maj and then Maj_Version (Last) = '.'; if Ok_Maj then Last := Last - 1; Ok_Maj := Maj_Version (Maj_Version'First .. Last) = Lib_Filename; end if; exit; end if; end loop; end if; if Ok_Maj then return Maj_Version (Maj_Version'First .. Last_Maj); else return ""; end if; end Major_Id_Name; ------------------ -- Partial_Name -- ------------------ function Partial_Name (Lib_Name : String; Number : Natural; Object_Suffix : String) return String is Img : constant String := Number'Img; begin return Partial_Prefix & Lib_Name & '_' & Img (Img'First + 1 .. Img'Last) & Object_Suffix; end Partial_Name; ------------------------ -- Put_Resource_Usage -- ------------------------ procedure Put_Resource_Usage (Filename : String) is separate; -------------------------------- -- Project_Compilation_Failed -- -------------------------------- function Project_Compilation_Failed (Prj : Project_Id; Recursive : Boolean := True) return Boolean is use Project_Name_Boolean_Htable; begin if Get (Project_Failure, Prj.Name) then return True; elsif not Recursive then return False; else -- Check all imported projects directly or indirectly declare Plist : Project_List := Prj.All_Imported_Projects; begin while Plist /= null loop if Get (Project_Failure, Plist.Project.Name) then return True; else Plist := Plist.Next; end if; end loop; return False; end; end if; end Project_Compilation_Failed; ----------------------------------- -- Set_Failed_Compilation_Status -- ----------------------------------- procedure Set_Failed_Compilation_Status (Prj : Project_Id) is begin Project_Name_Boolean_Htable.Set (Project_Failure, Prj.Name, True); end Set_Failed_Compilation_Status; ----------------------- -- Shared_Libgcc_Dir -- ----------------------- function Shared_Libgcc_Dir (Run_Time_Dir : String) return String is Path : String (1 .. Run_Time_Dir'Length + 15); Path_Last : constant Natural := Run_Time_Dir'Length; GCC_Index : Natural := 0; begin Path (1 .. Path_Last) := Run_Time_Dir; GCC_Index := Index (Path (1 .. Path_Last), "gcc-lib"); if GCC_Index /= 0 then -- This is gcc 2.8.2: the shared version of libgcc is -- located in the parent directory of "gcc-lib". GCC_Index := GCC_Index - 1; else GCC_Index := Index (Path (1 .. Path_Last), "/lib/"); if GCC_Index = 0 then GCC_Index := Index (Path (1 .. Path_Last), Directory_Separator & "lib" & Directory_Separator); end if; if GCC_Index /= 0 then -- We have found "lib" as a subdirectory in the runtime dir path. -- The declare Subdir : constant String := Interfaces.C.Strings.Value (Libgcc_Subdir_Ptr); begin Path (GCC_Index + 1 .. GCC_Index + Subdir'Length) := Subdir; GCC_Index := GCC_Index + Subdir'Length; end; end if; end if; return Path (1 .. GCC_Index); end Shared_Libgcc_Dir; --------------------- -- Need_To_Compile -- --------------------- procedure Need_To_Compile (Source : GPR.Source_Id; Tree : Project_Tree_Ref; In_Project : Project_Id; Conf_Paths : Config_Paths; Target_Dep_Paths : Config_Paths; Must_Compile : out Boolean; The_ALI : out ALI.ALI_Id; Object_Check : Boolean; Always_Compile : Boolean) is Source_Path : constant String := Get_Name_String (Source.Path.Display_Name); C_Source_Path : constant String := Get_Name_String (Source.Path.Name); Runtime_Source_Dirs : constant Name_List_Index := Source.Language.Config.Runtime_Source_Dirs; Stamp : Time_Stamp_Type; Source_In_Dependencies : Boolean := False; -- Set True if source was found in dependency file of its object file C_Object_Name : String_Access := null; -- The canonical file name for the object file Switches_Name : String_Access := null; -- The file name of the file that contains the switches that were used -- in the last compilation. Num_Ext : Natural; -- Number of extending projects ALI_Project : Project_Id; -- If the ALI file is in the object directory of a project, this is -- the project id. Externally_Built : constant Boolean := In_Project.Externally_Built; -- True if the project of the source is externally built Processed : Name_Id_Set.Set; -- Source files processed for ALI_Closure mode function Process_Makefile_Deps (Dep_Name, Obj_Dir : String) return Boolean; function Process_ALI_Deps (Source : Source_Id; Closure : Boolean) return Boolean; -- Process the dependencies for the current source file for the various -- dependency modes. -- They return True if the file needs to be recompiled. procedure Cleanup; -- Cleanup local variables function Check_Object_File (Source : Source_Id) return Boolean; -- Check object file exists and consistent with source file function Check_Time_Stamps (Path : String; Stamp : Time_Stamp_Type) return Boolean; ----------------------- -- Check_Object_File -- ----------------------- function Check_Object_File (Source : Source_Id) return Boolean is begin -- If object file does not exist, of course source needs to be -- compiled. if Source.Object_TS = Empty_Time_Stamp then Source.Object_TS := File_Stamp (Get_Name_String (Source.Object_Path)); end if; if Source.Object_TS = Empty_Time_Stamp then if Opt.Verbosity_Level > Opt.Low then Put (" -> object file "); Put (Get_Name_String_Safe (Source.Object_Path)); Put_Line (" does not exist"); end if; return False; end if; -- If the object file has been created before the last modification -- of the source, the source needs to be recompiled. if not Opt.Minimal_Recompilation and then Source.Object_TS < Source.Source_TS then if Opt.Verbosity_Level > Opt.Low then Put (" -> object file "); Put (Get_Name_String_Safe (Source.Object_Path)); Put_Line (" has time stamp earlier than source"); end if; return False; end if; if Opt.Verbosity_Level > Opt.Low and then Debug.Debug_Flag_T then Put (" object file "); Put (Get_Name_String_Safe (Source.Object_Path)); Put (": "); Put_Line (String (Source.Object_TS)); Put (" source file: "); Put_Line (String (Source.Source_TS)); end if; return True; end Check_Object_File; ----------------------- -- Check_Time_Stamps -- ----------------------- function Check_Time_Stamps (Path : String; Stamp : Time_Stamp_Type) return Boolean is TS : constant Time_Stamp_Type := File_Stamp (Get_Path_Name_Id (Path)); begin if TS /= Empty_Time_Stamp and then TS /= Stamp then if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> different time stamp for " & Path); if Debug.Debug_Flag_T then Put_Line (" in ALI file: " & String (Stamp)); Put_Line (" actual file: " & String (TS)); end if; end if; return True; end if; return False; end Check_Time_Stamps; --------------------------- -- Process_Makefile_Deps -- --------------------------- function Process_Makefile_Deps (Dep_Name, Obj_Dir : String) return Boolean is Dep_File : GPR.Util.Text_File; Last_Source : String_Access; Last_TS : Time_Stamp_Type := Empty_Time_Stamp; Last_Obj : Natural; Start : Natural; Finish : Natural; Looping : Boolean := False; -- Set to True at the end of the first Big_Loop for Makefile -- fragments function Is_Time_Stamp (S : String) return Boolean; -- Return True iff S has the format of a Time_Stamp_Type OK : Boolean; ------------------- -- Is_Time_Stamp -- ------------------- function Is_Time_Stamp (S : String) return Boolean is Result : Boolean := False; begin if S'Length = Time_Stamp_Length then Result := True; for J in S'Range loop if S (J) not in '0' .. '9' then Result := False; exit; end if; end loop; end if; return Result; end Is_Time_Stamp; begin Open (Dep_File, Dep_Name); -- If dependency file cannot be open, we need to recompile -- the source. if not Is_Valid (Dep_File) then if Opt.Verbosity_Level > Opt.Low then Put (" -> could not open dependency file "); Put_Line (Dep_Name); end if; return True; end if; -- Loop Big_Loop is executed several times only when the -- dependency file contains several times -- : ... -- When there is only one of such occurence, Big_Loop is exited -- successfully at the beginning of the second loop. Big_Loop : loop declare End_Of_File_Reached : Boolean := False; begin Skip_Loop : loop if End_Of_File (Dep_File) then End_Of_File_Reached := True; exit Skip_Loop; end if; Get_Line (Dep_File, Name_Buffer, Name_Len); if Name_Len > 0 and then Name_Buffer (1) /= '#' then -- Skip a first line that is an empty continuation line for J in 1 .. Name_Len - 1 loop exit Skip_Loop when Name_Buffer (J) /= ' '; end loop; exit Skip_Loop when Name_Buffer (Name_Len) /= '\'; end if; end loop Skip_Loop; -- If dependency file contains only empty lines or comments, -- then dependencies are unknown, and the source needs to be -- recompiled. if End_Of_File_Reached then -- If we have reached the end of file after the first -- loop, there is nothing else to do. exit Big_Loop when Looping; if Opt.Verbosity_Level > Opt.Low then Put (" -> dependency file "); Put (Dep_Name); Put_Line (" is empty"); end if; Close (Dep_File); return True; end if; end; Start := 1; Finish := Index (Name_Buffer (1 .. Name_Len), ": "); if Finish = 0 then Finish := Index (Name_Buffer (1 .. Name_Len), (1 => ':', 2 => ASCII.HT)); end if; if Finish /= 0 then Last_Obj := Finish; loop Last_Obj := Last_Obj - 1; exit when Last_Obj = Start or else Name_Buffer (Last_Obj) /= ' '; end loop; while Start < Last_Obj and then Name_Buffer (Start) = ' ' loop Start := Start + 1; end loop; Canonical_Case_File_Name (Name_Buffer (Start .. Last_Obj)); end if; -- First line must start with simple name or path name of object -- file, followed by colon. if Finish = 0 then OK := False; else OK := C_Object_Name = null or else Name_Buffer (Start .. Last_Obj) = C_Object_Name.all; if not OK then declare Path : String := Name_Buffer (Start .. Last_Obj); begin Canonical_Case_File_Name (Path); OK := Path = Get_Name_String (Source.Object_Path); end; end if; end if; if not OK then if Opt.Verbosity_Level > Opt.Low then Put (" -> dependency file "); Put (Dep_Name); Put_Line (" has wrong format"); if Finish = 0 then Put_Line (" no colon"); else Put (" expected object file name "); Put (C_Object_Name.all); Put (", got "); Put_Line (Name_Buffer (Start .. Last_Obj)); end if; end if; Close (Dep_File); return True; else Start := Finish + 2; -- Process each line Line_Loop : loop declare Line : String := Name_Buffer (1 .. Name_Len); Last : Natural := Name_Len; begin Name_Loop : loop -- Find the beginning of the next source path name while Start <= Last and then Line (Start) = ' ' loop Start := Start + 1; end loop; exit Line_Loop when Start > Last; -- Go to next line when there is a continuation -- character \ at the end of the line. exit Name_Loop when Start = Last and then Line (Start) = '\'; -- We should not be at the end of the line, without -- a continuation character \. if Start = Last then if Opt.Verbosity_Level > Opt.Low then Put (" -> dependency file "); Put (Dep_Name); Put_Line (" has wrong format"); end if; Close (Dep_File); return True; end if; -- Look for the end of the source path name Finish := Start; while Finish < Last loop if Line (Finish) = '\' then -- On Windows, a '\' is part of the path name, -- except when it is not the first character -- followed by another '\' or by a space. -- On other platforms, when we are getting a '\' -- that is not the last character of the line, -- the next character is part of the path name, -- even if it is a space. if On_Windows and then Finish = Start and then Line (Finish + 1) = '\' then Finish := Finish + 2; if Finish > Last then if Opt.Verbosity_Level > Opt.Low then Put (" -> dependency file "); Put (Dep_Name); Put_Line (" has wrong format"); end if; Close (Dep_File); return True; end if; elsif On_Windows and then Line (Finish + 1) not in '\' | ' ' then Finish := Finish + 1; else Line (Finish .. Last - 1) := Line (Finish + 1 .. Last); Last := Last - 1; end if; else -- A space that is not preceded by '\' -- indicates the end of the path name. exit when Line (Finish + 1) = ' '; Finish := Finish + 1; end if; end loop; if Last_Source /= null and then Is_Time_Stamp (Line (Start .. Finish)) then -- If we have a time stamp, check if it is the -- same as the source time stamp. if String (Last_TS) = Line (Start .. Finish) then Free (Last_Source); else if Opt.Verbosity_Level > Opt.Low then Put (" -> source "); Put (Last_Source.all); Put_Line (" has modified time stamp"); end if; Free (Last_Source); Close (Dep_File); return True; end if; else -- Check this source declare Src_Name : constant String := Normalize_Pathname (Unescape (Line (Start .. Finish)), Directory => Obj_Dir, Resolve_Links => False); C_Src_Name : String := Src_Name; Src_TS : Time_Stamp_Type; Source_2 : GPR.Source_Id; begin Canonical_Case_File_Name (C_Src_Name); -- If it is original source, set -- Source_In_Dependencies. if C_Src_Name = C_Source_Path then Source_In_Dependencies := True; end if; -- Get the time stamp of the source, which is -- not necessarily a source of any project. Src_TS := File_Stamp (Get_Path_Name_Id (Src_Name)); -- If the source does not exist, we need to -- recompile. if Src_TS = Empty_Time_Stamp then if Opt.Verbosity_Level > Opt.Low then Put (" -> source "); Put (Src_Name); Put_Line (" does not exist"); end if; Close (Dep_File); return True; -- If the source has been modified after the -- object file, we need to recompile. elsif Object_Check and then Source.Language.Config.Object_Generated and then Src_TS > Source.Object_TS then if Opt.Verbosity_Level > Opt.Low then Put (" -> source "); Put (Src_Name); Put_Line (" more recent than object file"); end if; Close (Dep_File); return True; else Source_2 := Source_Paths_Htable.Get (Tree.Source_Paths_HT, Get_Path_Name_Id (C_Src_Name)); if Source_2 /= No_Source and then Source_2.Replaced_By /= No_Source then if Opt.Verbosity_Level > Opt.Low then Put (" -> source "); Put (Src_Name); Put_Line (" has been replaced"); end if; Close (Dep_File); return True; else Last_Source := new String'(Src_Name); Last_TS := Src_TS; end if; end if; end; end if; -- If the source path name ends the line, we are -- done. exit Line_Loop when Finish = Last; -- Go get the next source on the line Start := Finish + 1; end loop Name_Loop; end; -- If we are here, we had a continuation character \ at -- the end of the line, so we continue with the next -- line. Get_Line (Dep_File, Name_Buffer, Name_Len); Start := 1; Finish := 1; end loop Line_Loop; end if; -- Set Looping at the end of the first loop Looping := True; end loop Big_Loop; Close (Dep_File); -- If the original sources were not in the dependency file, then -- we need to recompile. It may mean that we are using a different -- source (different variant) for this object file. if not Source_In_Dependencies then if Opt.Verbosity_Level > Opt.Low then Put (" -> source "); Put (Source_Path); Put_Line (" is not in the dependencies"); end if; return True; end if; return False; end Process_Makefile_Deps; type Config_Paths_Found is array (Positive range <>) of Boolean; -- Type to record what config files are included in the ALI file ---------------------- -- Process_ALI_Deps -- ---------------------- function Process_ALI_Deps (Source : Source_Id; Closure : Boolean) return Boolean is Text : Text_Buffer_Ptr := Read_Library_Info_From_Full (File_Name_Type (Source.Dep_Path), Source.Dep_TS'Access); Proj : Project_Id; Found : Boolean := False; Preps : String_Sets.Set; -- Preprocessor data files to detect config pragma files by exclusion -- method. If file in D line is absolute filename then it is either -- config pragma file or preprocessor data file. We can detect that -- the file is preprocessor data files by the existence of the A line -- with -- -gnatep= prefix. Config pragma files in D line does not -- have any additional references. Conf_Paths_Found : Config_Paths_Found := (Conf_Paths'Range => False); The_ALI : ALI_Id; begin if Text = null then if Opt.Verbosity_Level > Opt.Low then Put (" -> cannot read "); Put_Line (Get_Name_String (Source.Dep_Path)); end if; return True; end if; -- Read only the necessary lines of the ALI file The_ALI := ALI.Scan_ALI (File_Name_Type (Source.Dep_Path), Text, Ignore_ED => False, Err => True, Read_Lines => "APDW"); Free (Text); if Source = Need_To_Compile.Source then Need_To_Compile.The_ALI := The_ALI; elsif Need_To_Compile.Stamp < File_Time_Stamp (Source.Dep_Path, Source.Dep_TS'Access) then -- We can be here only in Closure mode because -- Source /= Need_To_Compile.Source -- see if condition. if Opt.Verbosity_Level > Opt.Low then Put (" -> ALI file from dependencies "); Put (Get_Name_String (Source.Dep_Name)); Put (" later than "); Put_Line (Get_Name_String (Need_To_Compile.Source.Dep_Name)); end if; return True; elsif Object_Check then Initialize_Source_Record (Source); if not Check_Object_File (Source) then return True; end if; end if; if The_ALI = ALI.No_ALI_Id then if Opt.Verbosity_Level > Opt.Low then Put (" -> "); Put (Get_Name_String (Source.Dep_Path)); Put_Line (" is incorrectly formatted"); end if; return True; end if; declare U : Unit_Record renames Units.Table (ALIs.Table (The_ALI).First_Unit); A : String_Access; Gnatep : constant String := "-gnatep="; File : Text_File; procedure Prep_Append (Filename : String); ----------------- -- Prep_Append -- ----------------- procedure Prep_Append (Filename : String) is begin Preps.Include (Normalize_Pathname (Filename, Case_Sensitive => False)); end Prep_Append; begin for J in U.First_Arg .. U.Last_Arg loop A := Args.Table (J); if Starts_With (A.all, Gnatep) then Prep_Append (A (A'First + Gnatep'Length .. A'Last)); -- Extract all definition filenames from preprocessor data -- file. Put it into the Preps too. Open (File, A (A'First + Gnatep'Length .. A'Last)); while Is_Valid (File) and then not End_Of_File (File) loop declare Line : constant String := Get_Line (File); Str : String (Line'Range); Last : Natural; Scan : Positive := Line'First; procedure Scan_String_Literal; -- Scan string literal from Line starting from Scan -- index. ------------------------- -- Scan_String_Literal -- ------------------------- procedure Scan_String_Literal is Was_DQ : Boolean := False; Inside : Boolean := False; begin Last := Str'First - 1; for Idx in Scan .. Line'Last loop if Line (Idx) = '"' then if Inside then if Was_DQ then Last := Last + 1; Str (Last) := '"'; end if; Was_DQ := not Was_DQ; else Inside := True; end if; else if Was_DQ then Scan := Idx; exit; end if; if Inside then Last := Last + 1; Str (Last) := Line (Idx); end if; end if; end loop; end Scan_String_Literal; begin if Line /= "" then case Line (Line'First) is when '*' => Scan_String_Literal; Prep_Append (Str (Str'First .. Last)); when '"' => Scan_String_Literal; Scan_String_Literal; Prep_Append (Str (Str'First .. Last)); when others => null; end case; end if; end; end loop; if Is_Valid (File) then Close (File); end if; end if; end loop; end; -- Check if the ALI's GNAT version matches -- Tree.Shared.Ada_Runtime_Library_Version declare GNAT_Version : constant Name_Id := ALI.ALIs.Table (The_ALI).GNAT_Version; begin if GNAT_Version /= Tree.Shared.Ada_Runtime_Library_Version then if Opt.Verbosity_Level > Opt.Low then Put (" -> GNAT version changed: "); Put ("ALI version = "); Put (Get_Name_String (GNAT_Version)); Put ("; expected version = "); if Tree.Shared.Ada_Runtime_Library_Version /= No_Name then Put_Line (Get_Name_String (Tree.Shared.Ada_Runtime_Library_Version)); else Put_Line ("unknown"); end if; end if; return True; end if; end; if ALI.ALIs.Table (The_ALI).Compile_Errors then if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> last compilation had errors"); end if; return True; end if; if Object_Check and then ALI.ALIs.Table (The_ALI).No_Object then if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> no object generated during last compilation"); end if; return True; end if; if Check_Source_Info_In_ALI (The_ALI, Tree) = No_Name then return True; end if; -- We need to check that the ALI file is in the correct object -- directory. If it is in the object directory of a project -- that is extended and it depends on a source that is in one -- of its extending projects, then the ALI file is not in the -- correct object directory. ALI_Project := Source.Object_Project; -- Count the extending projects Num_Ext := 0; Proj := ALI_Project; loop Proj := Proj.Extended_By; exit when Proj = No_Project; Num_Ext := Num_Ext + 1; end loop; declare Projects : array (1 .. Num_Ext) of Project_Id; Sfile : File_Name_Type; Dep_Src : GPR.Source_Id; Position : Name_Id_Set.Cursor; Inserted : Boolean; ALI_Rec : ALIs_Record renames ALI.ALIs.Table (The_ALI); begin Proj := ALI_Project; for J in Projects'Range loop Proj := Proj.Extended_By; Projects (J) := Proj; end loop; for D in ALI_Rec.First_Sdep .. ALI_Rec.Last_Sdep loop Sfile := ALI.Sdep.Table (D).Sfile; Dep_Src := Source_Files_Htable.Get (Tree.Source_Files_HT, Sfile); if Closure and then Dep_Src /= No_Source then Processed.Insert (Name_Id (Sfile), Position, Inserted); else Inserted := True; end if; if Inserted and then ALI.Sdep.Table (D).Stamp /= Empty_Time_Stamp then Found := False; if Dep_Src = No_Source and then ALI.Sdep.Table (D).Checksum = 0 then -- Probably preprocessing dependencies. Look for the -- file in the directory of the source, then the other -- source directories of the project. declare Path : Path_Name_Type := No_Path; File : constant String := Get_Name_String (Sfile); Stamp : Time_Stamp_Type := Empty_Time_Stamp; List : String_List_Id := In_Project.Source_Dirs; Absp : constant Boolean := Is_Absolute_Path (File); -- Config pragma file or preprocessor data file Elem : String_Element; procedure Get_Path (Dir : String); -- If File is in the absolute directory Dir then -- set Path to the absolute path of the file and -- Stamp to its timestamp. Otherwise Path is -- No_Path. -------------- -- Get_Path -- -------------- procedure Get_Path (Dir : String) is begin Set_Name_Buffer (Dir); Add_Char_To_Name_Buffer (Directory_Separator); Add_Str_To_Name_Buffer (File); Path := Name_Find; Stamp := File_Stamp (Path); if Stamp = Empty_Time_Stamp then Path := No_Path; end if; end Get_Path; begin if Conf_Paths'Length > 0 or else Absp then Path := Path_Name_Type (Sfile); Stamp := File_Stamp (Path); declare Found : Boolean := False; Norm_Path : constant String := Normalize_Pathname (File, Case_Sensitive => False); begin for J in Conf_Paths'Range loop if Conf_Paths (J).Name = Get_Path_Name_Id (Norm_Path) then Found := True; Conf_Paths_Found (J) := True; end if; end loop; if not Found then for J in Target_Dep_Paths'Range loop if Target_Dep_Paths (J).Name = Get_Path_Name_Id (Norm_Path) then Found := True; end if; end loop; end if; if Absp and then not Found and then not Preps.Contains (Norm_Path) then -- Config pragma file is in D line but was -- not referenced from project and -- -gnatec = command line option. if Opt.Verbosity_Level > Opt.Low then Put (" -> """); Put (File); Put_Line (""" not defined in project and " & "-gnatec= command line option"); if Opt.Verbosity_Level > Opt.Medium then Put ("Warning: Dependency file """); Put (Get_Name_String (Source.Dep_Path)); Put_Line (""" contains outdated information " & "about configuration file. "); Put_Line ("Warning: Consider using the " & "-gnateb switch if supported by " & "the compiler."); end if; end if; return True; end if; end; end if; -- Look in the directory of the source if Path = No_Path then Get_Path (Source_Dir_Of (Source)); end if; while Path = No_Path and then List /= Nil_String loop Elem := Tree.Shared.String_Elements.Table (List); Get_Path (Get_Name_String (Elem.Display_Value)); List := Elem.Next; end loop; if Stamp /= ALI.Sdep.Table (D).Stamp then if Opt.Verbosity_Level > Opt.Low then if Stamp = Empty_Time_Stamp then Put (" -> """); Put (Get_Name_String (Sfile)); Put_Line (""" missing"); else Put (" -> different time stamp for "); Put_Line (Get_Name_String (Path)); if Debug.Debug_Flag_T then Put (" in ALI file: "); Put_Line (String (ALI.Sdep.Table (D).Stamp)); Put (" actual file: "); Put_Line (String (Stamp)); end if; end if; end if; return True; end if; end; elsif Dep_Src = No_Source and then ALI.Sdep.Table (D).Checksum /= 0 then if not Is_Ada_Predefined_File_Name (Sfile) then declare File_Found : Boolean := False; Correct_Checksum : Boolean := False; Checksum : Word; begin for J in Conf_Paths'Range loop declare File : constant File_Name_Type := Get_File_Name_Id (Ada.Directories.Simple_Name (Get_Name_String (Conf_Paths (J).Name))); begin if File = Sfile then File_Found := True; Checksum := Calculate_Checksum (Conf_Paths (J).Name); if Checksum = ALI.Sdep.Table (D).Checksum and then not Conf_Paths_Found (J) then Correct_Checksum := True; Conf_Paths_Found (J) := True; exit; end if; end if; end; end loop; -- If the file is missing from our internal config -- file list, recompute the config file checksum -- from the * .ali file and compare it. -- This prevents total project recompilation if -- --gnatec is declared at Compiler package -- switches level. if not File_Found then Checksum := Calculate_Checksum (Path_Name_Type (Sfile)); if Checksum = ALI.Sdep.Table (D).Checksum then File_Found := True; Correct_Checksum := True; end if; end if; if not File_Found then -- Config pragma file is in D line but was -- not referenced from project and -- -gnatec= command line option. if Opt.Verbosity_Level > Opt.Low then Put (" -> """); Put (Get_Name_String (Sfile)); Put_Line (""" not defined in project and " & "-gnatec= command line option"); end if; return True; elsif not Correct_Checksum then Put (" -> different checksum for "); Put_Line (Get_Name_String (Sfile)); if Debug.Debug_Flag_T then Put (" in ALI file: "); Put_Line (ALI.Sdep.Table (D).Checksum'Img); Put (" actual file: "); Put_Line (Checksum'Img); end if; end if; end; end if; else while Dep_Src /= No_Source loop if not Dep_Src.Locally_Removed and then Dep_Src.Unit /= No_Unit_Index then Found := True; Initialize_Source_Record (Dep_Src); if Dep_Src.Checksum /= ALI.Sdep.Table (D).Checksum then -- Checksum saved in source file differ from -- ALI D line checksum. case Dep_Src.Checksum_Src is when No_File => -- Checksum was not saved. Save it. Dep_Src.Checksum_Src := Source.File; Dep_Src.Checksum := ALI.Sdep.Table (D).Checksum; when True_Checksum => -- Checksum calculated from file and D -- record from ALI does not fit it. We -- have to rebuild source. return True; when others => if Dep_Src.File = Dep_Src.Checksum_Src then -- The checksum saved from the D record -- of the source itself. It is more -- reliable than the D line of the -- other sources. Rebuild the source. return True; end if; -- If we have 2 different sources with D -- lines referenced to the Dep_Src with -- different checksum, we should calculate -- checksum from source file. declare Prev_Src : constant File_Name_Type := Dep_Src.Checksum_Src; Prev_Chs : constant Word := Dep_Src.Checksum; Prev_Sid : Source_Id; Success : Boolean; begin if Calculate_Checksum (Dep_Src) then if Dep_Src.Checksum /= Prev_Chs then -- Saved D line checksum from -- previos source was wrond. We -- have to rebuild previous -- source file. Prev_Sid := Source_Files_Htable.Get (Tree.Source_Files_HT, Prev_Src); -- Delete obsolete ALI file if -- exists. Delete_File (Get_Name_String (Prev_Sid.Dep_Path), Success); -- Insert the source into the -- queue again. Queue.Insert (Source => (Tree, Prev_Sid, Closure => True), With_Roots => True, Repeat => True); end if; if Dep_Src.Checksum /= ALI.Sdep.Table (D).Checksum then -- If calculated checksum differ -- from D line checksum, we have -- to compile this Source. return True; end if; end if; end; end case; end if; if (Opt.Minimal_Recompilation and then ALI.Sdep.Table (D).Stamp /= Dep_Src.Source_TS) or else Opt.Checksum_Recompilation then -- If minimal recompilation is in action, -- replace the stamp of the source file in -- the table if checksums match. if Calculate_Checksum (Dep_Src) then if Dep_Src.Checksum = ALI.Sdep.Table (D).Checksum then if Opt.Verbosity_Level > Opt.Low then Put (" "); Put (Get_Name_String_Safe (ALI.Sdep.Table (D).Sfile)); Put (": up to date, "); if ALI.Sdep.Table (D).Stamp /= Dep_Src.Source_TS then Put ("different timestamps but "); else Put ("same timestamps and "); end if; Put ("same checksum"); New_Line; end if; ALI.Sdep.Table (D).Stamp := Dep_Src.Source_TS; elsif Opt.Checksum_Recompilation then if Opt.Verbosity_Level > Opt.Low then Put (" "); Put (Get_Name_String_Safe (ALI.Sdep.Table (D).Sfile)); Put_Line (": changed, different checksums"); end if; return True; end if; end if; end if; if ALI.Sdep.Table (D).Stamp /= Dep_Src.Source_TS then if Opt.Verbosity_Level > Opt.Low then Put (" -> different time stamp for "); Put_Line (Get_Name_String_Safe (Sfile)); if Debug.Debug_Flag_T then Put (" in ALI file: "); Put_Line (String (ALI.Sdep.Table (D).Stamp)); Put (" actual file: "); Put_Line (String (Dep_Src.Source_TS)); end if; end if; return True; end if; for J in Projects'Range loop if Dep_Src.Project = Projects (J) then if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> dependency file not in " & "object directory of project """ & Get_Name_String_Safe (Projects (Projects'Last).Display_Name) & """"); end if; return True; end if; end loop; if Closure and then Dep_Src /= Source and then Dep_Src.Kind /= Sep and then not Dep_Src.Project.Externally_Built and then Process_ALI_Deps (Dep_Src, True) then return True; end if; exit; end if; Dep_Src := Dep_Src.Next_With_File_Name; end loop; -- If the source was not found and the runtime source -- directory is defined, check if the file exists there, -- and if it does, check its timestamp. end if; if not Found and then (Runtime_Source_Dirs /= No_Name_List or else Is_Absolute_Path (Get_Name_String (Sfile))) then if Is_Absolute_Path (Get_Name_String (Sfile)) then if Check_Time_Stamps (Get_Name_String (Sfile), ALI.Sdep.Table (D).Stamp) then return True; end if; else declare R_Dirs : Name_List_Index := Runtime_Source_Dirs; begin while R_Dirs /= No_Name_List loop declare Nam_Nod : constant Name_Node := Tree.Shared.Name_Lists.Table (R_Dirs); begin if Check_Time_Stamps (Get_Name_String (Nam_Nod.Name) & Directory_Separator & Get_Name_String (Sfile), ALI.Sdep.Table (D).Stamp) then return True; end if; R_Dirs := Nam_Nod.Next; end; end loop; end; end if; end if; end if; end loop; -- Check that all the config files have been found in the ALI file if Source.Language.Config.Config_File_Dependency_Support then for J in Conf_Paths_Found'Range loop if not Conf_Paths_Found (J) then if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> new config file " & Get_Name_String_Safe (Conf_Paths (J).Display_Name)); end if; return True; end if; end loop; end if; end; return False; end Process_ALI_Deps; ------------- -- Cleanup -- ------------- procedure Cleanup is begin Free (C_Object_Name); Free (Switches_Name); end Cleanup; begin The_ALI := ALI.No_ALI_Id; -- Never attempt to compile header files if Source.Language.Config.Kind = File_Based and then Source.Kind = Spec then Must_Compile := False; return; end if; if Force_Compilations then Must_Compile := Always_Compile or else not Externally_Built; return; end if; -- Fail if no compiler if Source.Language.Config.Compiler_Driver = No_File then Fail_Program (Tree, "no compiler for """ & Get_Name_String_Safe (Source.File) & '"'); end if; -- No need to compile if there is no "compiler" if Source.Language.Config.Compiler_Driver = Empty_File then Must_Compile := False; return; end if; if Source.Language.Config.Object_Generated and then Object_Check then C_Object_Name := new String'(Get_Name_String (Source.Object)); Canonical_Case_File_Name (C_Object_Name.all); if Source.Switches_Path /= No_Path then Switches_Name := new String'(Get_Name_String (Source.Switches_Path)); end if; end if; if Opt.Verbosity_Level > Opt.Low then Put (" Checking "); Put (Source_Path); if Source.Index /= 0 then Put (" at"); Put (Source.Index'Img); end if; Put_Line (" ... "); end if; -- No need to compile if project is externally built if Externally_Built then if Opt.Verbosity_Level > Opt.Low then Put_Line (" project is externally built"); end if; Must_Compile := False; Cleanup; return; end if; if not Source.Language.Config.Object_Generated then -- If no object file is generated, the "compiler" need to be invoked -- if there is no dependency file. if Source.Language.Config.Dependency_Kind = None then if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> no object file generated"); end if; Must_Compile := True; Cleanup; return; end if; elsif Object_Check and then not Check_Object_File (Source) then Must_Compile := True; Cleanup; return; end if; if Source.Language.Config.Dependency_Kind /= None then -- If there is no dependency file, then the source needs to be -- recompiled and the dependency file need to be created. Stamp := File_Time_Stamp (Source.Dep_Path, Source.Dep_TS'Access); if Stamp = Empty_Time_Stamp then if Opt.Verbosity_Level > Opt.Low then Put (" -> dependency file "); Put (Get_Name_String (Source.Dep_Path)); Put_Line (" does not exist"); end if; Must_Compile := True; Cleanup; return; end if; if In_Project.Library and then Source.Unit /= No_Unit_Index and then Source.In_Interfaces then declare Dep_Path : constant String := Normalize_Pathname (Get_Name_String (Source.Dep_Name), Get_Name_String (In_Project.Library_ALI_Dir.Name), Resolve_Links => Opt.Follow_Links_For_Files); Lib_Stamp : constant Time_Stamp_Type := File_Stamp (Dep_Path); begin if Lib_Stamp = Empty_Time_Stamp then if Opt.Verbosity_Level > Opt.Low then Put (" -> file "); Put (Dep_Path); Put_Line (" does not exist"); end if; In_Project.Need_Build := True; elsif Lib_Stamp < Stamp then if Opt.Verbosity_Level > Opt.Low then Put (" -> file "); Put (Dep_Path); Put (" has timestamp earlier than "); Put_Line (Get_Name_String (Source.Dep_Path)); end if; In_Project.Need_Build := True; end if; end; end if; -- If the ALI file has been created after the object file, we need -- to recompile. if Object_Check and then Source.Language.Config.Dependency_Kind in ALI_Dependency and then Source.Object_TS < Stamp then if Opt.Verbosity_Level > Opt.Low then Put (" -> ALI file "); Put (Get_Name_String (Source.Dep_Path)); Put_Line (" has timestamp later than object file"); end if; Must_Compile := True; Cleanup; return; end if; -- The source needs to be recompiled if the source has been modified -- after the dependency file has been created. if not Opt.Minimal_Recompilation and then Stamp < Source.Source_TS then if Opt.Verbosity_Level > Opt.Low then Put (" -> dependency file "); Put (Get_Name_String (Source.Dep_Path)); Put_Line (" has time stamp earlier than source"); end if; Must_Compile := True; Cleanup; return; end if; end if; -- If we are checking the switches and there is no switches file, then -- the source needs to be recompiled and the switches file need to be -- created. if Check_Switches and then Switches_Name /= null then if Source.Switches_TS = Empty_Time_Stamp then if Opt.Verbosity_Level > Opt.Low then Put (" -> switches file "); Put (Switches_Name.all); Put_Line (" does not exist"); end if; Must_Compile := True; Cleanup; return; end if; -- The source needs to be recompiled if the source has been modified -- after the switches file has been created. if not Opt.Minimal_Recompilation and then Source.Switches_TS < Source.Source_TS then if Opt.Verbosity_Level > Opt.Low then Put (" -> switches file "); Put (Switches_Name.all); Put_Line (" has time stamp earlier than source"); end if; Must_Compile := True; Cleanup; return; end if; end if; case Source.Language.Config.Dependency_Kind is when None => null; when Makefile => if Process_Makefile_Deps (Get_Name_String (Source.Dep_Path), Get_Name_String (Source.Project.Object_Directory.Display_Name)) then Must_Compile := True; Cleanup; return; end if; when ALI_File => if Process_ALI_Deps (Source, Closure => False) then Must_Compile := True; Cleanup; return; end if; when ALI_Closure => if Process_ALI_Deps (Source, Closure => True) then Must_Compile := True; Cleanup; return; end if; end case; -- If we are here, then everything is OK, and we don't need -- to recompile. if not Object_Check and then Opt.Verbosity_Level > Opt.Low then Put_Line (" -> up to date"); end if; Must_Compile := False; Cleanup; end Need_To_Compile; --------------------------- -- Set_Default_Verbosity -- --------------------------- procedure Set_Default_Verbosity is Gpr_Verbosity : String_Access := Getenv ("GPR_VERBOSITY"); begin if Gpr_Verbosity /= null and then Gpr_Verbosity'Length > 0 then declare Verbosity : String := Gpr_Verbosity.all; begin To_Lower (Verbosity); if Verbosity = "quiet" then Quiet_Output := True; Verbose_Mode := False; Verbosity_Level := Opt.None; elsif Verbosity = "default" then Quiet_Output := False; Verbose_Mode := False; Verbosity_Level := Opt.None; elsif Verbosity = "verbose" or else Verbosity = "verbose_low" then Quiet_Output := False; Verbose_Mode := True; Verbosity_Level := Opt.Low; elsif Verbosity = "verbose_medium" then Quiet_Output := False; Verbose_Mode := True; Verbosity_Level := Opt.Medium; elsif Verbosity = "verbose_high" then Quiet_Output := False; Verbose_Mode := True; Verbosity_Level := Opt.High; end if; end; end if; Free (Gpr_Verbosity); end Set_Default_Verbosity; -------------------- -- Set_Gprls_Mode -- -------------------- procedure Set_Gprls_Mode is begin Gprls_Mode := True; end Set_Gprls_Mode; --------------- -- Knowledge -- --------------- package body Knowledge is separate; ---------------- -- Check_Diff -- ---------------- function Check_Diff (Ts1, Ts2 : Time_Stamp_Type; Max_Drift : Duration := 5.0) return Boolean is use Ada.Calendar; function Get (T : String) return Time is (Time_Of (Year => Year_Number'Value (T (T'First .. T'First + 3)), Month => Month_Number'Value (T (T'First + 4 .. T'First + 5)), Day => Day_Number'Value (T (T'First + 6 .. T'First + 7)), Hour => Hour_Number'Value (T (T'First + 8 .. T'First + 9)), Minute => Minute_Number'Value (T (T'First + 10 .. T'First + 11)), Second => Second_Number'Value (T (T'First + 12 .. T'First + 13)))); T1 : constant Time := Get (String (Ts1)); T2 : constant Time := Get (String (Ts2)); begin return abs (T1 - T2) <= Max_Drift; end Check_Diff; ----------------------------- -- Check_Maximum_Processes -- ----------------------------- procedure Check_Maximum_Processes is Already_Reported : Boolean := False; procedure Check_It (Value : in out Positive); -------------- -- Check_It -- -------------- procedure Check_It (Value : in out Positive) is Max_Proc : constant := 63; begin if Value > Max_Proc then Value := Max_Proc; if not Already_Reported then Already_Reported := True; Put_Line ("On Windows the maximum number of simultaneous processes is" & Max_Proc'Img); end if; end if; end Check_It; begin if On_Windows then Check_It (Opt.Maximum_Compilers); Check_It (Opt.Maximum_Binders); Check_It (Opt.Maximum_Linkers); end if; end Check_Maximum_Processes; -------------------- -- Project_Output -- -------------------- package body Project_Output is ---------------- -- Write_Char -- ---------------- procedure Write_A_Char (C : Character) is begin Write_A_String ((1 => C)); end Write_A_Char; --------------- -- Write_Eol -- --------------- procedure Write_Eol is begin Write_A_String ((1 => ASCII.LF)); end Write_Eol; -------------------- -- Write_A_String -- -------------------- procedure Write_A_String (S : String) is Str : String (1 .. S'Length); begin if S'Length > 0 then Str := S; if Write (Output_FD, Str (1)'Address, Str'Length) /= Str'Length then GPR.Com.Fail ("disk full"); end if; end if; end Write_A_String; end Project_Output; ---------------------------- -- Command Line Arguments -- ---------------------------- package Command_Line_Arguments is new GNAT.Table (Table_Component_Type => Name_Id, Table_Index_Type => Natural, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 100); ----------------------------------- -- Delete_Command_Line_Arguments -- ----------------------------------- procedure Delete_Command_Line_Arguments is begin Command_Line_Arguments.Set_Last (0); end Delete_Command_Line_Arguments; -------------------------------- -- Get_Command_Line_Arguments -- -------------------------------- procedure Get_Command_Line_Arguments is File : File_Type; procedure Read_File (Name : String); -- Read argument file with name Name and put the arguments into table -- Command_Line_Arguments. --------------- -- Read_File -- --------------- procedure Read_File (Name : String) is begin begin Open (File, In_File, Name); exception when others => Fail_Program (null, "could not open argument file """ & Name & '"', Exit_Code => E_General); end; while not End_Of_File (File) loop Get_Line (File, Name_Buffer, Name_Len); if Name_Len /= 0 and then (Name_Len = 1 or else Name_Buffer (1 .. 2) /= "--") then if Name_Buffer (1) = '@' then Fail_Program (null, "invalid argument """ & Name_Buffer (1 .. Name_Len) & """ in argument file", Exit_Code => E_General); else Command_Line_Arguments.Append (Name_Find); end if; end if; end loop; Close (File); end Read_File; begin for J in 1 .. Argument_Count loop declare Arg : constant String := Argument (J); begin if Arg'Length /= 0 then if Arg (Arg'First) = '@' then if Arg'Length = 1 then Fail_Program (null, "invalid argument '@' on the command line", Exit_Code => E_General); else Read_File (Arg (Arg'First + 1 .. Arg'Last)); end if; else Name_Len := Arg'Length; Name_Buffer (1 .. Name_Len) := Arg; Command_Line_Arguments.Append (Name_Find); end if; end if; end; end loop; end Get_Command_Line_Arguments; -------------------------------- -- Last_Command_Line_Argument -- -------------------------------- function Last_Command_Line_Argument return Natural is begin return Command_Line_Arguments.Last; end Last_Command_Line_Argument; --------------------------- -- Command_Line_Argument -- --------------------------- function Command_Line_Argument (Rank : Positive) return String is begin if Rank > Command_Line_Arguments.Last then return ""; else return Get_Name_String (Command_Line_Arguments.Table (Rank)); end if; end Command_Line_Argument; begin declare Ext : String_Access := GNAT.OS_Lib.Get_Target_Executable_Suffix; begin Set_Name_Buffer (Ext.all); Executable_Extension_On_Target := Name_Enter; Free (Ext); end; end GPR.Util; gprbuild-25.0.0/gpr/src/gpr-util.ads000066400000000000000000001171621470075373400172430ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2022, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- Utilities for use in processing project files with Ada.Calendar; use Ada; with Ada.Containers.Indefinite_Vectors; with GNAT.MD5; use GNAT.MD5; with GPR.ALI; with GPR.Names; with GPR.Osint; use GPR.Osint; with GPR.Scans; use GPR.Scans; package GPR.Util is package String_Vectors is new Ada.Containers.Indefinite_Vectors (Positive, String); -- General-purpose vector of strings type String_Vector_Access is access all String_Vectors.Vector; type Config_Paths is array (Positive range <>) of Path_Information; -- type used in Need_To_Compile Default_Config_Name : constant String := "default.cgpr"; -- Name of the configuration file used by gprbuild and generated by -- gprconfig by default. Load_Standard_Base : Boolean := True; -- False when gprbuild is called with --db- procedure Set_Program_Name (N : String); -- Indicate the executable name, so that it can be displayed with -- Write_Program_Name below. procedure Write_Program_Name; -- Display the name of the executable in error mesages procedure Set_Gprls_Mode; -- Set Gprls_Mode to True procedure Check_Maximum_Processes; -- Check that the maximum number of simultaneous processes is not too large -- for the platform. -------------- -- Closures -- -------------- type Status_Type is (Success, Unknown_Error, Invalid_Project, No_Main, Invalid_Main, Incomplete_Closure); procedure Get_Closures (Project : Project_Id; In_Tree : Project_Tree_Ref; Mains : String_Vectors.Vector; All_Projects : Boolean := True; Include_Externally_Built : Boolean := False; Status : out Status_Type; Result : out String_Vectors.Vector); -- Return the list of source files in the closures of the Ada Mains in -- Result. -- The project and its project tree must have been parsed and processed. -- Mains is a list of single file names that are Ada sources of the project -- Project or of its subprojects. -- When All_Projects is False, the Mains must be sources of the Project and -- the sources of the closures that are sources of the imported subprojects -- are not included in the returned list. -- When All_Projects is True, mains may also be found in subprojects, -- including aggregated projects when Project is an aggregate project. -- When All_Projects is True, sources in the closures that are sources of -- externally built subprojects are included in the returned list only when -- Include_Externally_Built is True. -- Result is the list of path names in the closures. -- It is the responsibility of the caller to deallocate the Strings in -- Result and Result itself. -- When all the sources in the closures are found, Result is non null and -- Status is Success. -- When only a subset of the sources in the closures are found, Result is -- non null and Status is Incomplete_Closure. -- When there are other problems, Result is null and Status is different -- from Success or Incomplete_Closure. procedure Put_Resource_Usage (Filename : String); -- Print resource usage statistic into file with Filename ------------------------- -- Program termination -- ------------------------- procedure Fail_Program (Project_Tree : Project_Tree_Ref; Message : String; Exit_Code : Exit_Code_Type := E_Fatal; Flush_Messages : Boolean := True; No_Message : Boolean := False; Command : String := "") with No_Return; -- Terminate program with a message and a fatal status code. Do not issue -- any message when No_Message is True. procedure Finish_Program (Project_Tree : Project_Tree_Ref; Exit_Code : Exit_Code_Type := E_Success; Message : String := ""; No_Message : Boolean := False; Command : String := "") with No_Return; -- Terminate program, with or without a message, setting the status code -- according to Exit_Code. This properly removes all temporary files. Don't -- issue any message when No_Message is True. procedure Compilation_Phase_Failed (Project_Tree : Project_Tree_Ref; Exit_Code : Exit_Code_Type := E_Fatal; No_Message : Boolean := False); -- Terminate program with "*** compilation phase failed" message and an -- Exit_Code status code. Don't issue any message when No_Message is True. procedure Duplicate (This : in out Name_List_Index; Shared : Shared_Project_Tree_Data_Access); -- Duplicate a name list function Executable_Of (Project : Project_Id; Shared : Shared_Project_Tree_Data_Access; Main : File_Name_Type; Index : Int; Language : String := ""; Include_Suffix : Boolean := True) return File_Name_Type; -- Return the value of the attribute Builder'Executable for file Main in -- the project Project, if it exists. If there is no attribute Executable -- for Main, remove the suffix from Main; then, when Include_Suffix -- is True, if the attribute Executable_Suffix is specified in package -- Builder, add this suffix. Attribute Executable_Suffix is either -- declared in the user project file or, for some platforms, in the -- configuration project file (for example ".exe" on Windows). procedure Expect (The_Token : Token_Type; Token_Image : String); -- Check that the current token is The_Token. If it is not, then output -- an error message. function Executable_Prefix_Path return String; -- Return the absolute path parent directory of the directory where the -- current executable resides, if its directory is named "bin", otherwise -- return an empty string. When a directory is returned, it is guaranteed -- to end with a directory separator. function Locate_Directory (Dir_Name : String; Path : String) return String_Access; -- Find directory Dir_Name in Path. Return absolute path of directory, or -- null if directory cannot be found. The caller is responsible for -- freeing the returned String_Access. procedure Put (Into_List : in out Name_List_Index; From_List : String_List_Id; In_Tree : Project_Tree_Ref; Lower_Case : Boolean := False); -- Append From_List list to list Into_List type Name_Array_Type is array (Positive range <>) of Name_Id; function Split (Source : String; Separator : String) return Name_Array_Type; -- Split string Source into several, using Separator. The different -- occurrences of Separator are not included in the result. The result -- includes no empty string. function Value_Of (Variable : Variable_Value; Default : String) return String; -- Get the value of a single string variable. If Variable is a string list, -- is Nil_Variable_Value,or is defaulted, return Default. function Value_Of (Index : Name_Id; In_Array : Array_Element_Id; Shared : Shared_Project_Tree_Data_Access) return Name_Id; -- Get a single string array component. Returns No_Name if there is no -- component Index, if In_Array is null, or if the component is a String -- list. Depending on the attribute (only attributes may be associative -- arrays) the index may or may not be case sensitive. If the index is not -- case sensitive, it is first set to lower case before the search in the -- associative array. function Value_Of (Index : Name_Id; Src_Index : Int := 0; In_Array : Array_Element_Id; Shared : Shared_Project_Tree_Data_Access; Force_Lower_Case_Index : Boolean := False; Allow_Wildcards : Boolean := False) return Variable_Value; -- Get a string array component (single String or String list). Returns -- Nil_Variable_Value if no component Index or if In_Array is null. -- -- Depending on the attribute (only attributes may be associative arrays) -- the index may or may not be case sensitive. If the index is not case -- sensitive, it is first set to lower case before the search in the -- associative array. function Value_Of (Name : Name_Id; Index : Int := 0; Attribute_Or_Array_Name : Name_Id; In_Package : Package_Id; Shared : Shared_Project_Tree_Data_Access; Force_Lower_Case_Index : Boolean := False; Allow_Wildcards : Boolean := False) return Variable_Value; -- In a specific package: -- - if there exists an array Attribute_Or_Array_Name with an index Name, -- returns the corresponding component (depending on the attribute, the -- index may or may not be case sensitive, see previous function), -- - otherwise if there is a single attribute Attribute_Or_Array_Name, -- returns this attribute, -- - otherwise, returns Nil_Variable_Value. -- If In_Package is null, returns Nil_Variable_Value. function Value_Of (Index : Name_Id; In_Array : Name_Id; In_Arrays : Array_Id; Shared : Shared_Project_Tree_Data_Access) return Name_Id; -- Get a string array component in an array of an array list. Returns -- No_Name if there is no component Index, if In_Arrays is null, if -- In_Array is not found in In_Arrays or if the component is a String list. function Value_Of (Name : Name_Id; In_Arrays : Array_Id; Shared : Shared_Project_Tree_Data_Access) return Array_Element_Id; -- Returns a specified array in an array list. Returns No_Array_Element -- if In_Arrays is null or if Name is not the name of an array in -- In_Arrays. The caller must ensure that Name is in lower case. function Value_Of (Name : Name_Id; In_Packages : Package_Id; Shared : Shared_Project_Tree_Data_Access) return Package_Id; -- Returns a specified package in a package list. Returns No_Package -- if In_Packages is null or if Name is not the name of a package in -- Package_List. The caller must ensure that Name is in lower case. function Value_Of (Variable_Name : Name_Id; In_Variables : Variable_Id; Shared : Shared_Project_Tree_Data_Access) return Variable_Value; -- Returns a specified variable in a variable list. Returns null if -- In_Variables is null or if Variable_Name is not the name of a -- variable in In_Variables. Caller must ensure that Name is lower case. procedure Write_Str (S : String; Max_Length : Positive; Separator : Character); -- Output string S. If S is too long to fit in one -- line of Max_Length, cut it in several lines, using Separator as the last -- character of each line, if possible. type Text_File is limited private; -- Represents a text file (default is invalid text file) function Is_Valid (File : Text_File) return Boolean; -- Returns True if File designates an open text file that has not yet been -- closed. procedure Open (File : out Text_File; Name : String); -- Open a text file to read (File is invalid if text file cannot be opened) procedure Create (File : out Text_File; Name : String); -- Create a text file to write (File is invalid if text file cannot be -- created). function End_Of_File (File : Text_File) return Boolean; -- Returns True if the end of the text file File has been reached. Fails if -- File is invalid. Return True if File is an out file. procedure Get_Line (File : Text_File; Line : out String; Last : out Natural); -- Reads a line from an open text file (fails if File is invalid or in an -- out file). function Get_Line (File : Text_File; Max_Length : Positive := 4096) return String; procedure Put (File : Text_File; S : String); procedure Put_Line (File : Text_File; Line : String); -- Output a string or a line to an out text file (fails if File is invalid -- or in an in file). procedure Close (File : in out Text_File); -- Close an open text file. File becomes invalid. Fails if File is already -- invalid or if an out file cannot be closed successfully. ----------------------- -- Source info files -- ----------------------- -- A source info file is a text file that contains information on the -- significant sources of a project tree. -- -- Only sources that are not excluded and are not replaced by another -- source in an extending projects are described in a source info file. -- -- Each source is described with 4 lines, followed by optional lines, -- followed by an empty line. -- -- The four lines in every entry are -- - the name of the project -- - the name of the language -- - the kind of source: SPEC, IMPL (body) OR SEP (subunit). -- - the path name of the source -- -- The optional lines are: -- - if the canonical case path name is not the same as the path name -- to be displayed, a line starting with "P=" followed by the canonical -- case path name. -- - if the language is unit based (Ada), a line starting with "U=" -- followed by the unit name. -- - if the unit is part of a multi-unit source, a line starting with -- "I=" followed by the index in the multi-unit source. -- - if the source is a naming exception declared in its project, a line -- containing "N=Y". -- - if it is an inherited naming exception, a line containng "N=I". procedure Write_Source_Info_File (Tree : Project_Tree_Ref); -- Create a new source info file, with the path name specified in the -- project tree data. Issue a warning if it is not possible to create -- the new file. procedure Read_Source_Info_File (Tree : Project_Tree_Ref); -- Check if there is a source info file specified for the project Tree. If -- so, attempt to read it. If the file exists and is successfully read, set -- the flag Source_Info_File_Exists to True for the tree. type Source_Info_Data is record Project : Name_Id; Language : Name_Id; Kind : Source_Kind; Display_Path_Name : Name_Id; Path_Name : Name_Id; Unit_Name : Name_Id := No_Name; Index : Int := 0; Naming_Exception : Naming_Exception_Type := No; end record; -- Data read from a source info file for a single source type Source_Info is access all Source_Info_Data; No_Source_Info : constant Source_Info := null; type Source_Info_Iterator is private; -- Iterator to get the sources for a single project procedure Initialize (Iter : out Source_Info_Iterator; For_Project : Name_Id); -- Initialize Iter for the project function Source_Info_Of (Iter : Source_Info_Iterator) return Source_Info; -- Get the source info for the source corresponding to the current value of -- the iterator. Returns No_Source_Info if there is no source corresponding -- to the iterator. procedure Next (Iter : in out Source_Info_Iterator); -- Advance the iterator to the next source in the project function Is_Ada_Predefined_File_Name (Fname : File_Name_Type) return Boolean; -- Return True if Fname is a runtime source file name function Is_Ada_Predefined_Unit (Unit : String) return Boolean; -- Return True if Unit is an Ada runtime unit function Is_Pragmas_Config_File (Fname : File_Name_Type) return Boolean; -- Return True if Fname is a pragmas config file function Starts_With (Item : String; Prefix : String) return Boolean; -- Return True if Item starts with Prefix function Ends_With (Str, Suffix : String) return Boolean; -- Whether the string ends with Suffix. Always True if Suffix is the empty -- string. generic with procedure Action (Source : Source_Id); procedure For_Interface_Sources (Tree : Project_Tree_Ref; Project : Project_Id); -- Call Action for every sources that are needed to use Project. This is -- either the sources corresponding to the units in attribute Interfaces -- or all sources of the project. Note that only the bodies that are -- needed (because the unit is generic or contains some inline pragmas) -- are handled. This routine must be called only when the project has -- been built successfully. function Relative_Path (Pathname : String; To : String; Directory : Boolean := True) return String; -- Returns the relative pathname which corresponds to Pathname when -- starting from directory to. Both Pathname and To must be absolute paths. -- If Directory is True then the result will be treated as directory and -- directory separator will be appended at the end. function Create_Name (Name : String) return File_Name_Type renames Names.Get_File_Name_Id; -- Get File_Name_Type for a name function Create_Name (Name : String) return Name_Id renames Names.Get_Name_Id; -- Get Name_Id for a name function Create_Name (Name : String) return Path_Name_Type renames Names.Get_Path_Name_Id; -- Get Path_Name_Type for a name function Is_Subunit (Source : Source_Id) return Boolean; -- Return True if source is a subunit procedure Initialize_Source_Record (Source : Source_Id; Always : Boolean := False); -- Get information either about the source file, or the object and -- dependency file, as well as their timestamps. -- When Always is True, initialize Source even if it has already been -- initialized. function Source_Dir_Of (Source : Source_Id) return String; -- Returns the directory of the source file procedure Get_Switches (Source : Source_Id; Pkg_Name : Name_Id; Project_Tree : Project_Tree_Ref; Value : out Variable_Value; Is_Default : out Boolean); procedure Get_Switches (Source_File : File_Name_Type; Source_Lang : Name_Id; Source_Prj : Project_Id; Pkg_Name : Name_Id; Project_Tree : Project_Tree_Ref; Value : out Variable_Value; Is_Default : out Boolean; Test_Without_Suffix : Boolean := False; Check_ALI_Suffix : Boolean := False); -- Compute the switches (Compilation switches for instance) for the given -- file. This checks various attributes to see if there are file specific -- switches, or else defaults on the switches for the corresponding -- language. Is_Default is set to False if there were file-specific -- switches. Source_File can be set to No_File to force retrieval of the -- default switches. If Test_Without_Suffix is True, and there is no "for -- Switches(Source_File) use", then this procedure also tests without the -- extension of the filename. If Test_Without_Suffix is True and -- Check_ALI_Suffix is True, then we also replace the file extension with -- ".ali" when testing. function Object_Project (Project : Project_Id; Must_Be_Writable : Boolean := False) return Project_Id; -- For a non aggregate project, returns the project, except when -- Must_Be_Writable is True and the object directory is not writable, -- return No_Project. -- For an aggregate project or an aggregate library project, returns an -- aggregated project that is not an aggregate project and that has -- a writable object directory. If there is no such project, returns -- No_Project. function To_Time_Stamp (Time : Calendar.Time) return Stamps.Time_Stamp_Type; -- Returns Time as a time stamp type function To_UTC_Time_Stamp (Time : Calendar.Time) return Stamps.Time_Stamp_Type; -- Return timestamp shifted to UTC on conversion function UTC_Time return Stamps.Time_Stamp_Type; -- Returns the UTC time Partial_Prefix : constant String := "p__"; Begin_Info : constant String := "-- BEGIN Object file/option list"; End_Info : constant String := "-- END Object file/option list "; Project_Node_Tree : constant GPR.Project_Node_Tree_Ref := new Project_Node_Tree_Data; -- This is also used to hold project path and scenario variables Complete_Output_Option : constant String := "--complete-output"; No_Complete_Output_Option : constant String := "--no-complete-output"; Added_Project : constant String := "--added-project="; Complete_Output : Boolean := False; -- Set to True with switch Complete_Output_Option No_Complete_Output : Boolean := False; -- Set to True with switch -n or No_Complete_Output_Option No_Project_File : Boolean := False; -- Set to True in gprbuild and gprclean when switch --no-project is used -- Config project Config_Project_Option : constant String := "--config="; Autoconf_Project_Option : constant String := "--autoconf="; Target_Project_Option : constant String := "--target="; Prefix_Project_Option : constant String := "--prefix"; No_Name_Map_File_Option : constant String := "--map-file-option"; Restricted_To_Languages_Option : constant String := "--restricted-to-languages="; No_Project_Option : constant String := "--no-project"; Distributed_Option : constant String := "--distributed"; Hash_Option : constant String := "--hash"; Hash_Value : String_Access; Slave_Env_Option : constant String := "--slave-env"; Slave_Env_Auto : Boolean := False; Dry_Run_Option : constant String := "--dry-run"; Named_Map_File_Option : constant String := No_Name_Map_File_Option & '='; Config_Path : String_Access := null; Target_Name : String_Access := null; Config_Project_File_Name : String_Access := null; Configuration_Project_Path : String_Access := null; -- Base name and full path to the configuration project file Autoconfiguration : Boolean := True; -- Whether we are using an automatically config (from gprconfig) Autoconf_Specified : Boolean := False; -- Whether the user specified --autoconf on the gprbuild command line Delete_Autoconf_File : Boolean := False; -- This variable is used by gprclean to decide if the config project file -- should be cleaned. It is set to True when the config project file is -- automatically generated or --autoconf= is used. -- Default project Default_Project_File_Name : constant String := "default.gpr"; -- Implicit project Implicit_Project_File_Path : constant String := "share" & Directory_Separator & "gpr" & Directory_Separator & '_' & Default_Project_File_Name; -- User projects Project_File_Name : String_Access := null; -- The name of the project file specified with switch -P No_Project_File_Found : Boolean := False; -- True when no project file is specified and there is no .gpr file -- in the current working directory. Main_Project : Project_Id; -- The project id of the main project RTS_Option : constant String := "--RTS="; RTS_Language_Option : constant String := "--RTS:"; Db_Directory_Expected : Boolean := False; -- True when last switch was --db Distributed_Mode : Boolean := False; -- Wether the distributed compilation mode has been activated Slave_Env : String_Access; -- The name of the distributed build environment -- Packages of project files where unknown attributes are errors Naming_String : aliased String := "naming"; Builder_String : aliased String := "builder"; Compiler_String : aliased String := "compiler"; Binder_String : aliased String := "binder"; Linker_String : aliased String := "linker"; Clean_String : aliased String := "clean"; -- Name of packages to be checked when parsing/processing project files List_Of_Packages : aliased String_List := (Naming_String'Access, Builder_String'Access, Compiler_String'Access, Binder_String'Access, Linker_String'Access, Clean_String'Access); Packages_To_Check : constant String_List_Access := List_Of_Packages'Access; -- List of the packages to be checked when parsing/processing project files Gprname_Packages : aliased String_List := (1 => Naming_String'Access); Packages_To_Check_By_Gprname : constant String_List_Access := Gprname_Packages'Access; -- Local subprograms function Binder_Exchange_File_Name (Main_Base_Name : File_Name_Type; Prefix : Name_Id) return String_Access; -- Returns the name of the binder exchange file corresponding to an -- object file and a language. -- Main_Base_Name must have no extension specified ---------- -- Misc -- ---------- procedure Create_Sym_Links (Lib_Path : String; Lib_Version : String; Lib_Dir : String; Maj_Version : String); -- Copy Lib_Version to Lib_Path (removing Lib_Path if it exists). If -- Maj_Version is set it also link Lib_Version into Lib_Dir with the -- specified Maj_Version. procedure Create_Sym_Link (From, To : String); -- Create a relative symlink in From pointing to To procedure Display_Usage_Version_And_Help; -- Output the two lines of usage for switches --version and --help procedure Display_Version (Tool_Name : String; Initial_Year : String); -- Display version of a tool when switch --version is used function Calculate_Checksum (Source : Source_Id) return Boolean; -- Calculate Source checksum from source file, returns True on success function Calculate_Checksum (File : Path_Name_Type) return Word; -- Calculate Source checksum from a file, returns the checksum generic with procedure Usage; -- Print tool-specific part of --help message procedure Check_Version_And_Help_G (Tool_Name : String; Initial_Year : String); -- Check if switches --version or --help is used. If one of this switch is -- used, issue the proper messages and end the process. procedure Find_Binding_Languages (Tree : Project_Tree_Ref; Root_Project : Project_Id); -- Check if in the project tree there are sources of languages that have -- a binder driver. -- Populates Tree's appdata (Binding and There_Are_Binder_Drivers). -- Nothing is done if the binding languages were already searched for -- this Tree. -- This also performs the check for aggregated project trees. function Get_Compiler_Driver_Path (Project : Project_Id; Lang : Language_Ptr) return String_Access; -- Get, from the config, the path of the compiler driver. This is first -- looked for on the PATH if needed. -- Returns "null" if no compiler driver was specified for the language, and -- exit with an error if one was specified but not found. -- -- The --compiler-subst switch is taken into account. For example, if -- "--compiler-subst=ada,gnatpp" was given, and Lang is the Ada language, -- this will return the full path name for gnatpp. procedure Locate_Runtime (Project_Tree : Project_Tree_Ref; Language : Name_Id); -- Wrapper around Set_Runtime_For. Search RTS name in the project path and -- if found convert it to an absolute path. Emit an error message if a -- full RTS name (an RTS name that contains a directory separator) is not -- found. procedure Look_For_Default_Project (Never_Fail : Boolean := False); -- Check if default.gpr exists in the current directory. If it does, use -- it. Otherwise, if there is only one file ending with .gpr, use it. -- Otherwise, if there is no file ending with .gpr or if Never_Fail is -- True, use the project file _default.gpr in /share/gpr. Fail -- if Never_Fail is False and there are several files ending with .gpr. function Major_Id_Name (Lib_Filename : String; Lib_Version : String) return String; -- Returns the major id library file name, if it exists. -- For example, if Lib_Filename is "libtoto.so" and Lib_Version is -- "libtoto.so.1.2", then "libtoto.so.1" is returned. function Partial_Name (Lib_Name : String; Number : Natural; Object_Suffix : String) return String; -- Returns the name of an object file created by the partial linker function Shared_Libgcc_Dir (Run_Time_Dir : String) return String; -- Returns the directory of the shared version of libgcc, if it can be -- found, otherwise returns an empty string. package Knowledge is function Normalized_Hostname return String; -- Return the normalized name of the host on which gprbuild is running. -- The knowledge base must have been parsed first. function Normalized_Target (Target_Name : String) return String; -- Return the normalized name of the specified target. -- The knowledge base must have been parsed first. procedure Parse_Knowledge_Base (Project_Tree : Project_Tree_Ref; Directory : String := ""); end Knowledge; procedure Need_To_Compile (Source : Source_Id; Tree : Project_Tree_Ref; In_Project : Project_Id; Conf_Paths : Config_Paths; Target_Dep_Paths : Config_Paths; Must_Compile : out Boolean; The_ALI : out ALI.ALI_Id; Object_Check : Boolean; Always_Compile : Boolean); -- Check if a source need to be compiled. -- A source need to be compiled if: -- - Force_Compilations is True -- - No object file generated for the language -- - Object file does not exist -- - Dependency file does not exist -- - Switches file does not exist -- - Either of these 3 files are older than the source or any source it -- depends on. -- If an ALI file had to be parsed, it is returned as The_ALI, so that the -- caller does not need to parse it again. -- -- Object_Check should be False when switch --no-object-check is used. When -- True, presence of the object file and its time stamp are checked to -- decide if a file needs to be compiled. -- -- Tree is the project tree in which Source is found (or the root tree when -- not using aggregate projects). -- -- Always_Compile should be True when gprbuid is called with -f -u and at -- least one source on the command line. function Project_Compilation_Failed (Prj : Project_Id; Recursive : Boolean := True) return Boolean; -- Returns True if all compilations for Prj (and all projects it depends on -- if Recursive is True) were successful and False otherwise. procedure Set_Failed_Compilation_Status (Prj : Project_Id); -- Record compilation failure status for the given project Maximum_Size : Integer; pragma Import (C, Maximum_Size, "__gnat_link_max"); -- Maximum number of bytes to put in an invocation of the -- Archive_Builder. function Ensure_Suffix (Item : String; Suffix : String) return String; -- Returns Item if it ends with Suffix otherwise returns Item & Suffix function Ensure_Extension (Filename : String; Ext : String) return String; -- If Filename has any extension returns it as is, otherwise returns it -- appended with Ext. function Ensure_Directory (Path : String) return String; -- Returns Path with an ending directory separator function Common_Prefix (Pathname1, Pathname2 : String) return String; -- Returns the longest common prefix for Pathname1 and Pathname2 function File_MD5 (Pathname : String) return Message_Digest; -- Returns the file MD5 signature. Raises Name_Error if Pathname does not -- exists. function As_RPath (Path : String; Case_Sensitive : Boolean) return String; -- Returns Path in a representation compatible with the use with --rpath or -- --rpath-link. -- This normalizes the path, and ensure the use of unix-style directory -- separator. function Common_Path_Prefix_Length (A, B : String) return Integer; -- Adapted from: -- https://www.rosettacode.org/wiki/Find_common_directory_path#Ada -- The result is the length of the longest common path prefix, including -- trailing separators. -- If the only common prefix is "/" then the result is zero. function Relative_RPath (Dest, Src, Origin : String) return String; -- returns Dest as a path relative to the Src directory using Origin -- to indicate the relative path: with dest = /foo/bar, Src = /foo/baz and -- Origin = $ORIGIN, the function will return $ORIGIN/../bar. -- If Absolute is set, then the rpath will be absolute. function Concat_Paths (List : String_Vectors.Vector; Separator : String) return String; -- Concatenate the strings in the list, using Separator between the -- strings. -- Typical usage is to concatenate paths using the path separator between -- those. function To_Argument_List (List : String_Vectors.Vector) return Argument_List; -- Translates a string vector into an argument list function Slice (List : String_Vectors.Vector; From, To : Positive) return String_Vectors.Vector; -- Returns List (From .. To) -- Architecture function Get_Target return String; -- Returns the current target for the compilation function Check_Diff (Ts1, Ts2 : Stamps.Time_Stamp_Type; Max_Drift : Duration := 5.0) return Boolean; -- Check two time stamps, returns True if both time are in a range of -- Max_Drift seconds maximum. -- Compiler and package substitutions -- The following are used to support the --compiler-subst and -- --compiler-pkg-subst switches, which are used by tools such as gnatpp to -- have gprbuild drive gnatpp, thus calling gnatpp only on files that need -- it. -- -- gnatpp will pass --compiler-subst=ada,gnatpp to tell gprbuild to run -- gnatpp instead of gcc. It will also pass -- --compiler-pkg-subst=pretty_printer to tell gprbuild to get switches -- from "package Pretty_Printer" instead of from "package Compiler". procedure Set_Default_Verbosity; -- Set the default verbosity from environment variable GPR_VERBOSITY. -- The values that are taken into account, case-insensitive, are: -- "quiet", "default", "verbose", "verbose_high", "verbose_medium" and -- "verbose_low". Compiler_Subst_Option : constant String := "--compiler-subst="; Compiler_Pkg_Subst_Option : constant String := "--compiler-pkg-subst="; Compiler_Subst_HTable : Language_Maps.Map; -- A hash table to get the compiler to substitute from the from the -- language name. For example, if the command line option -- "--compiler-subst=ada,gnatpp" was given, then this mapping will include -- the key-->value pair "ada" --> "gnatpp". This causes gprbuild to call -- gnatpp instead of gcc. Compiler_Pkg_Subst : Name_Id := No_Name; -- A package name to be used when invoking the compiler, in addition to -- "package Compiler". Normally, this is No_Name, indicating no additional -- package, but it can be set by the --compiler-pkg-subst option. For -- example, if --compiler-pkg-subst=pretty_printer was given, then this -- will be "pretty_printer", and gnatpp will be invoked with switches from -- "package Pretty_Printer", and -inner-cargs followed by switches from -- "package Compiler". package Project_Output is -- Support for Gprname Output_FD : File_Descriptor; -- To save the project file and its naming project file procedure Write_Eol; -- Output an empty line procedure Write_A_Char (C : Character); -- Write one character to Output_FD procedure Write_A_String (S : String); -- Write a String to Output_FD end Project_Output; ---------------------------- -- Command Line Arguments -- ---------------------------- procedure Delete_Command_Line_Arguments; -- Remove all previous command line arguments procedure Get_Command_Line_Arguments; -- Get the command line arguments, including those coming from argument -- files. function Last_Command_Line_Argument return Natural; -- The number of command line arguments that have been read function Command_Line_Argument (Rank : Positive) return String; -- Return command line argument of rank Rank. If Rank is greater than -- Last_Command_Line_Argument, return the empty string. ---------------------- -- Time Stamp Cache -- ---------------------- -- There is a hash table to cache the time stamps of files. -- This table needs to be cleared and updated sometimes. procedure Clear_Time_Stamp_Cache; procedure Update_File_Stamp (Path : Path_Name_Type; Stamp : Time_Stamp_Type); ----------- -- Flags -- ----------- function Has_Incomplete_Withs (Flags : Processing_Flags) return Boolean; -- Return the value of the Incomplete_Withs flag private type Text_File_Data is record FD : File_Descriptor := Invalid_FD; Out_File : Boolean := False; Buffer : String (1 .. 100_000); Buffer_Len : Natural := 0; Cursor : Natural := 0; End_Of_File_Reached : Boolean := False; end record; type Text_File is access Text_File_Data; type Source_Info_Iterator is record Info : Source_Info; Next : Natural; end record; function Starts_With (Item : String; Prefix : String) return Boolean is (Item'Length >= Prefix'Length and then Item (Item'First .. Item'First + Prefix'Length - 1) = Prefix); function Ends_With (Str, Suffix : String) return Boolean is (Str'Length >= Suffix'Length and then Str (Str'Last - Suffix'Length + 1 .. Str'Last) = Suffix); end GPR.Util; gprbuild-25.0.0/gpr/src/gpr-version.adb000066400000000000000000000073141470075373400177270ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2001-2019, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with GPR.Sdefault; package body GPR.Version is ---------------------- -- Copyright_Holder -- ---------------------- function Copyright_Holder return String is begin return "AdaCore"; end Copyright_Holder; ------------------- -- Free_Software -- ------------------- function Free_Software return String is begin case Build_Type is when GPL | FSF => return "This is free software; see the source for copying conditions." & ASCII.LF & "There is NO warranty; not even for MERCHANTABILITY or FITNESS" & " FOR A PARTICULAR PURPOSE."; when Gnatpro => return "This is free software; see the source for copying conditions." & ASCII.LF & "See your AdaCore support agreement for details of warranty" & " and support." & ASCII.LF & "If you do not have a current support agreement, then there" & " is absolutely" & ASCII.LF & "no warranty; not even for MERCHANTABILITY or FITNESS FOR" & " A PARTICULAR" & ASCII.LF & "PURPOSE."; end case; end Free_Software; ------------------------ -- Gpr_Version_String -- ------------------------ function Gpr_Version_String (Host : Boolean := True) return String is Hostname : constant String := " (" & GPR.Sdefault.Hostname & ')'; Version_String : constant String := Gpr_Version & " (" & Date & ")" & (if Host then Hostname else ""); begin case Build_Type is when Gnatpro => return "Pro " & Version_String; when GPL => return "Community " & Version_String; when FSF => return Version_String; end case; end Gpr_Version_String; end GPR.Version; gprbuild-25.0.0/gpr/src/gpr-version.ads000066400000000000000000000076441470075373400177560ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2019, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package spec holds version information for the GPR tools. -- -- It is patched on the fly during builds to match the current version, date -- and build type. Consider it as a compilable template rather than real -- source. package GPR.Version is Gpr_Version : constant String := "18.0w"; -- Static string identifying this version Date : constant String := "19940713"; Current_Year : constant String := "2016"; type Gnat_Build_Type is (Gnatpro, FSF, GPL); -- See Get_Gnat_Build_Type below for the meaning of these values Build_Type : constant Gnat_Build_Type := Gnatpro; -- Kind of GNAT Build: -- -- FSF -- GNAT FSF version. This version of GNAT is part of a Free Software -- Foundation release of the GNU Compiler Collection (GCC). The bug -- box generated by Comperr gives information on how to report bugs -- and list the "no warranty" information. -- -- Gnatpro -- GNAT Professional version. This version of GNAT is supported by Ada -- Core Technologies. The bug box generated by package Comperr gives -- instructions on bug submission that include references to customer -- number, gnattracker site etc. -- -- GPL -- GNAT GPL Edition. This is a special version of GNAT, released by -- Ada Core Technologies and intended for academic users, and free -- software developers. The bug box generated by the package Comperr -- gives appropriate bug submission instructions that do not reference -- customer number etc. function Gpr_Version_String (Host : Boolean := True) return String; -- Version output when GPRBUILD or its related tools, including -- GPRCLEAN, are run (with appropriate verbose option switch set). function Free_Software return String; -- Text to be displayed by the different GNAT tools when switch --version -- is used. This text depends on the GNAT build type. function Copyright_Holder return String; -- Return the name of the Copyright holder to be displayed by the different -- GNAT tools when switch --version is used. end GPR.Version; gprbuild-25.0.0/gpr/src/gpr.adb000066400000000000000000002142361470075373400162470ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2022, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Command_Line; with Ada.Directories; with Ada.Environment_Variables; use Ada.Environment_Variables; with Ada.Text_IO; use Ada.Text_IO; with Ada.Unchecked_Deallocation; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GPR.Opt; with GPR.Attr; with GPR.Names; use GPR.Names; with GPR.Output; use GPR.Output; with GPR.Snames; use GPR.Snames; with GPR.Tempdir; package body GPR is type Restricted_Lang; type Restricted_Lang_Access is access Restricted_Lang; type Restricted_Lang is record Name : Name_Id; Next : Restricted_Lang_Access; end record; Initialized : Boolean := False; -- A flag to avoid multiple initialization Restricted_Languages : Restricted_Lang_Access := null; -- When null, all languages are allowed, otherwise only the languages in -- the list are allowed. Object_Suffix : constant String := Get_Target_Object_Suffix.all; -- File suffix for object files Initial_Buffer_Size : constant := 100; -- Initial size for extensible buffer used in Add_To_Buffer Debug_Level : Integer := 0; -- Current indentation level for debug traces type Cst_String_Access is access constant String; All_Lower_Case_Image : aliased constant String := "lowercase"; All_Upper_Case_Image : aliased constant String := "UPPERCASE"; Mixed_Case_Image : aliased constant String := "MixedCase"; The_Casing_Images : constant array (Casing_Type) of Cst_String_Access := (All_Lower_Case => All_Lower_Case_Image'Access, All_Upper_Case => All_Upper_Case_Image'Access, Mixed_Case => Mixed_Case_Image'Access, Unknown => null); type Section_Displayed_Arr is array (Section_Type) of Boolean; Section_Displayed : Section_Displayed_Arr := (others => False); -- Flags to avoid to display several times the section header Temp_Files : Temp_Files_Table.Instance; -- Table to record temp file paths to be deleted, when no project tree is -- available. function Label (Section : Section_Type) return String; -- Section headers procedure Free (Project : in out Project_Id); -- Free memory allocated for Project procedure Free_List (Languages : in out Language_Ptr); procedure Free_List (Source : in out Source_Id); procedure Free_List (Languages : in out Language_List); -- Free memory allocated for the list of languages or sources procedure Reset_Units_In_Table (Table : in out Units_Htable.Instance); -- Resets all Units to No_Unit_Index Unit.File_Names (Spec).Unit & -- Unit.File_Names (Impl).Unit in the given table. procedure Free_Units (Table : in out Units_Htable.Instance); -- Free memory allocated for unit information in the project procedure Language_Changed (Iter : in out Source_Iterator); procedure Project_Changed (Iter : in out Source_Iterator); -- Called when a new project or language was selected for this iterator function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean; -- Return True if there is at least one ALI file in the directory Dir ----------------------------- -- Add_Restricted_Language -- ----------------------------- procedure Add_Restricted_Language (Name : String) is begin Restricted_Languages := new Restricted_Lang' (Name => Get_Lower_Name_Id (Name), Next => Restricted_Languages); end Add_Restricted_Language; ----------------- -- Add_To_Path -- ----------------- procedure Add_To_Path (Directory : String; Append : Boolean := False; Variable : String := "PATH") is procedure Update (Path : String); -- Update value of Variable. Path is its current value; ------------ -- Update -- ------------ procedure Update (Path : String) is begin if Path'Length = 0 then Set (Variable, Directory); elsif Append then Set (Variable, Path & Path_Separator & Directory); else Set (Variable, Directory & Path_Separator & Path); end if; end Update; begin if Directory'Length /= 0 then if not Exists (Variable) then Update (""); else Update (Value (Variable)); end if; end if; end Add_To_Path; ------------------------------------- -- Remove_All_Restricted_Languages -- ------------------------------------- procedure Remove_All_Restricted_Languages is begin Restricted_Languages := null; end Remove_All_Restricted_Languages; ------------------- -- Add_To_Buffer -- ------------------- procedure Add_To_Buffer (S : String; To : in out String_Access; Last : in out Natural) is begin if To = null then To := new String (1 .. Initial_Buffer_Size); Last := 0; end if; -- If Buffer is too small, double its size while Last + S'Length > To'Last loop declare New_Buffer : constant String_Access := new String (1 .. 2 * To'Length); begin New_Buffer (1 .. Last) := To (1 .. Last); Free (To); To := New_Buffer; end; end loop; To (Last + 1 .. Last + S'Length) := S; Last := Last + S'Length; end Add_To_Buffer; --------------------------------- -- Current_Object_Path_File_Of -- --------------------------------- function Current_Object_Path_File_Of (Shared : Shared_Project_Tree_Data_Access) return Path_Name_Type is begin return Shared.Private_Part.Current_Object_Path_File; end Current_Object_Path_File_Of; --------------------------------- -- Current_Source_Path_File_Of -- --------------------------------- function Current_Source_Path_File_Of (Shared : Shared_Project_Tree_Data_Access) return Path_Name_Type is begin return Shared.Private_Part.Current_Source_Path_File; end Current_Source_Path_File_Of; --------------------------- -- Delete_Temporary_File -- --------------------------- procedure Delete_Temporary_File (Shared : Shared_Project_Tree_Data_Access := null; Path : Path_Name_Type) is Dont_Care : Boolean; pragma Warnings (Off, Dont_Care); begin if not Opt.Keep_Temporary_Files then if Current_Verbosity = High then Write_Line ("Removing temp file: " & Get_Name_String_Safe (Path)); end if; Delete_File (Get_Name_String (Path), Dont_Care); if Shared = null then for Index in 1 .. Temp_Files_Table.Last (Temp_Files) loop if Temp_Files.Table (Index) = Path then Temp_Files.Table (Index) := No_Path; end if; end loop; else for Index in 1 .. Temp_Files_Table.Last (Shared.Private_Part.Temp_Files) loop if Shared.Private_Part.Temp_Files.Table (Index) = Path then Shared.Private_Part.Temp_Files.Table (Index) := No_Path; end if; end loop; end if; GPR.Tempdir.Delete_Temp_Dir; end if; end Delete_Temporary_File; procedure Delete_Temporary_File (Shared : Shared_Project_Tree_Data_Access := null; Path : String) is begin Delete_Temporary_File (Shared, Get_Path_Name_Id (Path)); end Delete_Temporary_File; --------------------------- -- Delete_All_Temp_Files -- --------------------------- procedure Delete_All_Temp_Files (Shared : Shared_Project_Tree_Data_Access) is Success : Boolean; Path : Path_Name_Type; Instance : Temp_Files_Table.Instance; begin if not Opt.Keep_Temporary_Files then if Shared = null then Instance := Temp_Files; else Instance := Shared.Private_Part.Temp_Files; end if; for Index in 1 .. Temp_Files_Table.Last (Instance) loop Path := Instance.Table (Index); if Path /= No_Path then declare Path_Name : constant String := Get_Name_String (Path); begin if Current_Verbosity = High then Write_Line ("Removing temp file: " & Path_Name); end if; Delete_File (Path_Name, Success); if not Success then if Is_Regular_File (Path_Name) then Write_Line ("Could not remove temp file " & Path_Name); elsif Current_Verbosity = High then Write_Line ("Temp file " & Path_Name & " already deleted"); end if; end if; end; end if; end loop; GPR.Tempdir.Delete_Temp_Dir; if Shared = null then Temp_Files_Table.Init (Temp_Files); else Temp_Files_Table.Init (Shared.Private_Part.Temp_Files); end if; end if; if Shared /= null then -- If any of the environment variables ADA_PRJ_INCLUDE_FILE or -- ADA_PRJ_OBJECTS_FILE has been set, then reset their value to -- the empty string. if Shared.Private_Part.Current_Source_Path_File /= No_Path then Setenv (Project_Include_Path_File, ""); end if; if Shared.Private_Part.Current_Object_Path_File /= No_Path then Setenv (Project_Objects_Path_File, ""); end if; end if; end Delete_All_Temp_Files; --------------------- -- Dependency_Name -- --------------------- function Dependency_Name (Source_File_Name : File_Name_Type; Dependency : Dependency_File_Kind) return File_Name_Type is begin case Dependency is when None => return No_File; when Makefile => return Extend_Name (Source_File_Name, Makefile_Dependency_Suffix); when ALI_Dependency => return Extend_Name (Source_File_Name, ALI_Dependency_Suffix); end case; end Dependency_Name; --------- -- Set -- --------- procedure Set (Section : Section_Type) is begin Section_Displayed (Section) := True; end Set; ------------- -- Display -- ------------- procedure Display (Section : Section_Type; Command : String; Argument : String) is Buffer : String (1 .. 1_000); Last : Natural := 0; First_Offset : constant := 3; Second_Offset : constant := 18; begin -- Display the section header if not already displayed if not Section_Displayed (Section) then Put_Line (Label (Section)); Section_Displayed (Section) := True; end if; Buffer (1 .. First_Offset) := (others => ' '); Last := First_Offset + 1; Buffer (Last) := '['; Buffer (Last + 1 .. Last + Command'Length) := Command; Last := Last + Command'Length + 1; Buffer (Last) := ']'; -- At least one space between first and second column. Second column -- starts at least at Second_Offset + 1. loop Last := Last + 1; Buffer (Last) := ' '; exit when Last >= Second_Offset; end loop; Buffer (Last + 1 .. Last + Argument'Length) := Argument; Last := Last + Argument'Length; Put_Line (Buffer (1 .. Last)); end Display; ---------------- -- Dot_String -- ---------------- function Dot_String return Name_Id is begin return The_Dot_String; end Dot_String; ---------------- -- Empty_File -- ---------------- function Empty_File return File_Name_Type is begin return File_Name_Type (The_Empty_String); end Empty_File; ------------------- -- Empty_Project -- ------------------- function Empty_Project (Qualifier : Project_Qualifier) return Project_Data is begin GPR.Initialize (Tree => No_Project_Tree); declare Data : Project_Data (Qualifier => Qualifier); begin -- Only the fields for which no default value could be provided in -- prj.ads are initialized below. Data.Config := Default_Project_Config; return Data; end; end Empty_Project; ------------------ -- Empty_String -- ------------------ function Empty_String return Name_Id is begin return The_Empty_String; end Empty_String; ----------------- -- Extend_Name -- ----------------- function Extend_Name (File : File_Name_Type; With_Suffix : String) return File_Name_Type is Last : Positive; begin Get_Name_String (File); Last := Name_Len + 1; while Name_Len /= 0 and then Name_Buffer (Name_Len) /= '.' loop Name_Len := Name_Len - 1; end loop; if Name_Len <= 1 then Name_Len := Last; end if; for J in With_Suffix'Range loop Name_Buffer (Name_Len) := With_Suffix (J); Name_Len := Name_Len + 1; end loop; Name_Len := Name_Len - 1; return Name_Find; end Extend_Name; ---------- -- Free -- ---------- procedure Free (Proj : in out Project_Node_Tree_Ref) is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Project_Node_Tree_Data, Project_Node_Tree_Ref); begin if Proj /= null then Tree_Private_Part.Project_Node_Table.Free (Proj.Project_Nodes); Tree_Private_Part.Projects_Htable.Reset (Proj.Projects_HT); Unchecked_Free (Proj); end if; end Free; ------------------------- -- Is_Allowed_Language -- ------------------------- function Is_Allowed_Language (Name : Name_Id) return Boolean is R : Restricted_Lang_Access := Restricted_Languages; Lang : constant String := Get_Name_String (Name); begin if R = null then return True; else while R /= null loop if Get_Name_String (R.Name) = Lang then return True; end if; R := R.Next; end loop; return False; end if; end Is_Allowed_Language; --------------------- -- Project_Changed -- --------------------- procedure Project_Changed (Iter : in out Source_Iterator) is begin if Iter.Project /= null then Iter.Language := Iter.Project.Project.Languages; Language_Changed (Iter); end if; end Project_Changed; ---------------------- -- Language_Changed -- ---------------------- procedure Language_Changed (Iter : in out Source_Iterator) is begin Iter.Current := No_Source; if Iter.Language_Name /= No_Name then while Iter.Language /= null and then Iter.Language.Name /= Iter.Language_Name loop Iter.Language := Iter.Language.Next; end loop; end if; -- If there is no matching language in this project, move to next if Iter.Language = No_Language_Index then if Iter.All_Projects then loop Iter.Project := Iter.Project.Next; exit when Iter.Project = null or else Iter.Encapsulated_Libs or else not Iter.Project.From_Encapsulated_Lib; end loop; Project_Changed (Iter); else Iter.Project := null; end if; else Iter.Current := Iter.Language.First_Source; if Iter.Current = No_Source then Iter.Language := Iter.Language.Next; Language_Changed (Iter); elsif not Iter.Locally_Removed and then Iter.Current.Locally_Removed then Next (Iter); end if; end if; end Language_Changed; --------------------- -- For_Each_Source -- --------------------- function For_Each_Source (In_Tree : Project_Tree_Ref; Project : Project_Id := No_Project; Language : Name_Id := No_Name; Encapsulated_Libs : Boolean := True; Locally_Removed : Boolean := True) return Source_Iterator is Iter : Source_Iterator; begin Iter := Source_Iterator' (In_Tree => In_Tree, Project => In_Tree.Projects, All_Projects => Project = No_Project, Language_Name => Language, Language => No_Language_Index, Current => No_Source, Encapsulated_Libs => Encapsulated_Libs, Locally_Removed => Locally_Removed); if Project /= null then while Iter.Project /= null and then Iter.Project.Project /= Project loop Iter.Project := Iter.Project.Next; end loop; elsif not Encapsulated_Libs then while Iter.Project /= null and then Iter.Project.From_Encapsulated_Lib loop Iter.Project := Iter.Project.Next; end loop; end if; Project_Changed (Iter); return Iter; end For_Each_Source; ------------- -- Element -- ------------- function Element (Iter : Source_Iterator) return Source_Id is begin return Iter.Current; end Element; ---------- -- Next -- ---------- procedure Next (Iter : in out Source_Iterator) is begin loop Iter.Current := Iter.Current.Next_In_Lang; exit when Iter.Locally_Removed or else Iter.Current = No_Source or else not Iter.Current.Locally_Removed; end loop; if Iter.Current = No_Source then Iter.Language := Iter.Language.Next; Language_Changed (Iter); end if; end Next; ---------------------------------------- -- For_Every_Project_Imported_Context -- ---------------------------------------- procedure For_Every_Project_Imported_Context (By : Project_Id; Tree : Project_Tree_Ref; With_State : in out State; Include_Aggregated : Boolean := True; Imported_First : Boolean := False) is procedure Recursive_Check_Context (Project : Project_Id; Tree : Project_Tree_Ref; In_Aggregate_Lib : Boolean; From_Encapsulated_Lib : Boolean); -- Recursively handle the project tree creating a new context for -- keeping track about already handled projects. ----------------------------- -- Recursive_Check_Context -- ----------------------------- procedure Recursive_Check_Context (Project : Project_Id; Tree : Project_Tree_Ref; In_Aggregate_Lib : Boolean; From_Encapsulated_Lib : Boolean) is Position : Name_Id_Set.Cursor; Inserted : Boolean; Seen_Name : Name_Id_Set.Set; -- This set is needed to ensure that we do not handle the same -- project twice in the context of aggregate libraries. procedure Recursive_Check (Project : Project_Id; Tree : Project_Tree_Ref; In_Aggregate_Lib : Boolean; From_Encapsulated_Lib : Boolean); -- Check if project has already been seen. If not, mark it as Seen, -- Call Action, and check all its imported and aggregated projects. --------------------- -- Recursive_Check -- --------------------- procedure Recursive_Check (Project : Project_Id; Tree : Project_Tree_Ref; In_Aggregate_Lib : Boolean; From_Encapsulated_Lib : Boolean) is function Has_Sources (P : Project_Id) return Boolean; -- Returns True if P has sources function Get_From_Tree (P : Project_Id) return Project_Id; -- Get project P from Tree. If P has no sources get another -- instance of this project with sources. If P has sources, -- returns it. ----------------- -- Has_Sources -- ----------------- function Has_Sources (P : Project_Id) return Boolean is Lang : Language_Ptr; begin Lang := P.Languages; while Lang /= No_Language_Index loop if Lang.First_Source /= No_Source then return True; end if; Lang := Lang.Next; end loop; return False; end Has_Sources; ------------------- -- Get_From_Tree -- ------------------- function Get_From_Tree (P : Project_Id) return Project_Id is List : Project_List := Tree.Projects; begin if not Has_Sources (P) then while List /= null loop if List.Project.Name = P.Name and then Has_Sources (List.Project) then return List.Project; end if; List := List.Next; end loop; end if; return P; end Get_From_Tree; -- Local variables List : Project_List; -- Start of processing for Recursive_Check begin -- If a non abstract imported project is extended, then the actual -- imported is the extending project. if Project.Qualifier /= Abstract_Project and then Project.Extended_By /= No_Project and then not Seen_Name.Contains (Project.Extended_By.Name) then Recursive_Check (Project.Extended_By, Tree, In_Aggregate_Lib, From_Encapsulated_Lib); end if; Seen_Name.Insert (Project.Name, Position, Inserted); if Inserted then -- Even if a project is aggregated multiple times in an -- aggregated library, we will only return it once. if not Imported_First then if Project.Qualifier /= Abstract_Project or else Project.Extended_By = No_Project then Action (Get_From_Tree (Project), Tree, Project_Context' (In_Aggregate_Lib, From_Encapsulated_Lib), With_State); end if; end if; -- Visit all extended projects if Project.Extends /= No_Project then Recursive_Check (Project.Extends, Tree, In_Aggregate_Lib, From_Encapsulated_Lib); end if; -- Visit all imported projects List := Project.Imported_Projects; while List /= null loop Recursive_Check (List.Project, Tree, In_Aggregate_Lib, From_Encapsulated_Lib or else Project.Standalone_Library = Encapsulated); List := List.Next; end loop; -- Visit all aggregated projects if Include_Aggregated and then Project.Qualifier in Aggregate_Project then declare Agg : Aggregated_Project_List; begin Agg := Project.Aggregated_Projects; while Agg /= null loop pragma Assert (Agg.Project /= No_Project); -- For aggregated libraries, the tree must be the one -- of the aggregate library. if Project.Qualifier = Aggregate_Library then Recursive_Check (Agg.Project, Tree, True, From_Encapsulated_Lib or else Project.Standalone_Library = Encapsulated); else -- Use a new context as we want to returns the same -- project in different project tree for aggregated -- projects. Recursive_Check_Context (Agg.Project, Agg.Tree, False, False); end if; Agg := Agg.Next; end loop; end; end if; if Imported_First then if Project.Qualifier /= Abstract_Project or else Project.Extended_By = No_Project then Action (Get_From_Tree (Project), Tree, Project_Context' (In_Aggregate_Lib, From_Encapsulated_Lib), With_State); end if; end if; end if; end Recursive_Check; -- Start of processing for Recursive_Check_Context begin Recursive_Check (Project, Tree, In_Aggregate_Lib, From_Encapsulated_Lib); end Recursive_Check_Context; -- Start of processing for For_Every_Project_Imported begin Recursive_Check_Context (Project => By, Tree => Tree, In_Aggregate_Lib => False, From_Encapsulated_Lib => False); end For_Every_Project_Imported_Context; -------------------------------- -- For_Every_Project_Imported -- -------------------------------- procedure For_Every_Project_Imported (By : Project_Id; Tree : Project_Tree_Ref; With_State : in out State; Include_Aggregated : Boolean := True; Imported_First : Boolean := False) is procedure Internal (Project : Project_Id; Tree : Project_Tree_Ref; Context : Project_Context; With_State : in out State); -- Action wrapper for handling the context -------------- -- Internal -- -------------- procedure Internal (Project : Project_Id; Tree : Project_Tree_Ref; Context : Project_Context; With_State : in out State) is pragma Unreferenced (Context); begin Action (Project, Tree, With_State); end Internal; procedure For_Projects is new For_Every_Project_Imported_Context (State, Internal); begin For_Projects (By, Tree, With_State, Include_Aggregated, Imported_First); end For_Every_Project_Imported; ----------------- -- Find_Source -- ----------------- function Find_Source (In_Tree : Project_Tree_Ref; Project : Project_Id; In_Imported_Only : Boolean := False; In_Extended_Only : Boolean := False; Base_Name : File_Name_Type; Index : Int := 0) return Source_Id is Result : Source_Id := No_Source; procedure Look_For_Sources (Proj : Project_Id; Tree : Project_Tree_Ref; Src : in out Source_Id); -- Look for Base_Name in the sources of Proj ---------------------- -- Look_For_Sources -- ---------------------- procedure Look_For_Sources (Proj : Project_Id; Tree : Project_Tree_Ref; Src : in out Source_Id) is Iterator : Source_Iterator; begin Iterator := For_Each_Source (In_Tree => Tree, Project => Proj); while Element (Iterator) /= No_Source loop if Element (Iterator).File = Base_Name and then (Index = 0 or else Element (Iterator).Index = Index) then Src := Element (Iterator); -- If the source has been excluded, continue looking. We will -- get the excluded source only if there is no other source -- with the same base name that is not locally removed. if not Element (Iterator).Locally_Removed then return; end if; end if; Next (Iterator); end loop; end Look_For_Sources; procedure For_Imported_Projects is new For_Every_Project_Imported (State => Source_Id, Action => Look_For_Sources); Proj : Project_Id; -- Start of processing for Find_Source begin if In_Extended_Only then Proj := Project; while Proj /= No_Project loop Look_For_Sources (Proj, In_Tree, Result); exit when Result /= No_Source; Proj := Proj.Extends; end loop; elsif In_Imported_Only then Look_For_Sources (Project, In_Tree, Result); if Result = No_Source then For_Imported_Projects (By => Project, Tree => In_Tree, Include_Aggregated => False, With_State => Result); end if; else Look_For_Sources (No_Project, In_Tree, Result); end if; return Result; end Find_Source; ---------------------- -- Find_All_Sources -- ---------------------- function Find_All_Sources (In_Tree : Project_Tree_Ref; Project : Project_Id; In_Imported_Only : Boolean := False; In_Extended_Only : Boolean := False; Base_Name : File_Name_Type; Index : Int := 0) return Source_Ids is Result : Source_Ids (1 .. 1_000); Last : Natural := 0; type Empty_State is null record; No_State : Empty_State; -- This is needed for the State parameter of procedure Look_For_Sources -- below, because of the instantiation For_Imported_Projects of generic -- procedure For_Every_Project_Imported. As procedure Look_For_Sources -- does not modify parameter State, there is no need to give its type -- more than one value. procedure Look_For_Sources (Proj : Project_Id; Tree : Project_Tree_Ref; State : in out Empty_State); -- Look for Base_Name in the sources of Proj ---------------------- -- Look_For_Sources -- ---------------------- procedure Look_For_Sources (Proj : Project_Id; Tree : Project_Tree_Ref; State : in out Empty_State) is Iterator : Source_Iterator; Src : Source_Id; begin State := No_State; Iterator := For_Each_Source (In_Tree => Tree, Project => Proj); while Element (Iterator) /= No_Source loop if Element (Iterator).File = Base_Name and then (Index = 0 or else (Element (Iterator).Unit /= No_Unit_Index and then Element (Iterator).Index = Index)) then Src := Element (Iterator); -- If the source has been excluded, continue looking. We will -- get the excluded source only if there is no other source -- with the same base name that is not locally removed. if not Element (Iterator).Locally_Removed then Last := Last + 1; Result (Last) := Src; end if; end if; Next (Iterator); end loop; end Look_For_Sources; procedure For_Imported_Projects is new For_Every_Project_Imported (State => Empty_State, Action => Look_For_Sources); Proj : Project_Id; -- Start of processing for Find_All_Sources begin if In_Extended_Only then Proj := Project; while Proj /= No_Project loop Look_For_Sources (Proj, In_Tree, No_State); exit when Last > 0; Proj := Proj.Extends; end loop; elsif In_Imported_Only then Look_For_Sources (Project, In_Tree, No_State); if Last = 0 then For_Imported_Projects (By => Project, Tree => In_Tree, Include_Aggregated => False, With_State => No_State); end if; else Look_For_Sources (No_Project, In_Tree, No_State); end if; return Result (1 .. Last); end Find_All_Sources; ---------- -- Hash -- ---------- function Hash (Name : Name_Id) return Header_Num is begin return Header_Num (Name mod (Max_Header_Num + 1)); end Hash; function Hash (Name : File_Name_Type) return Header_Num is begin return Hash (Name_Id (Name)); end Hash; function Hash (Name : Path_Name_Type) return Header_Num is begin return Hash (Name_Id (Name)); end Hash; function Hash (Project : Project_Id) return Header_Num is begin if Project = No_Project then return Header_Num'First; else return Hash (Project.Name); end if; end Hash; --------------- -- Hex_Image -- --------------- function Hex_Image (Item : Word; Length : Positive := 8) return String is Result : String (1 .. Length); begin Hex_Image (Item, Result); return Result; end Hex_Image; procedure Hex_Image (Item : Word; Result : out String) is Chr : constant array (Word range 0 .. 15) of Character := "0123456789abcdef"; Tmp : Word := Item; begin for C of reverse Result loop C := Chr (Tmp rem 16); Tmp := Tmp / 16; end loop; if Tmp > 0 then raise Constraint_Error; end if; end Hex_Image; ----------- -- Image -- ----------- function Image (The_Casing : Casing_Type) return String is begin return The_Casing_Images (The_Casing).all; end Image; ----------- -- Image -- ----------- function Image (Kind : Lib_Kind) return String is begin case Kind is when Static => return "static"; when Dynamic => return "dynamic"; when Relocatable => return "relocatable"; when Static_Pic => return "static-pic"; end case; end Image; ----------------------------- -- Is_Standard_GNAT_Naming -- ----------------------------- function Is_Standard_GNAT_Naming (Naming : Lang_Naming_Data) return Boolean is begin return Get_Name_String (Naming.Spec_Suffix) = ".ads" and then Get_Name_String (Naming.Body_Suffix) = ".adb" and then Get_Name_String (Naming.Dot_Replacement) = "-"; end Is_Standard_GNAT_Naming; ---------------- -- Initialize -- ---------------- procedure Initialize (Tree : Project_Tree_Ref) is begin if not Initialized then Initialized := True; GPR.Attr.Initialize; -- Add the directory of the GPR tool at the end of the PATH, so that -- other GPR tools, such as gprconfig, may be found. declare Program_Name : constant String := Ada.Command_Line.Command_Name; use Ada.Directories; begin if Program_Name'Length > 0 then if Is_Absolute_Path (Program_Name) then Add_To_Path (Containing_Directory (Program_Name), Append => True); else Add_To_Path (Get_Current_Dir & Containing_Directory (Program_Name), Append => True); end if; end if; end; end if; if Tree /= No_Project_Tree then Reset (Tree); end if; end Initialize; ------------------ -- Is_Extending -- ------------------ function Is_Extending (Extending : Project_Id; Extended : Project_Id) return Boolean is Proj : Project_Id; begin Proj := Extending; while Proj /= No_Project loop if Proj = Extended then return True; end if; Proj := Proj.Extends; end loop; return False; end Is_Extending; ----------------- -- Object_Name -- ----------------- function Object_Name (Source_File_Name : File_Name_Type; Object_File_Suffix : Name_Id := No_Name) return File_Name_Type is begin if Object_File_Suffix = No_Name then return Extend_Name (Source_File_Name, Object_Suffix); else return Extend_Name (Source_File_Name, Get_Name_String (Object_File_Suffix)); end if; end Object_Name; function Object_Name (Source_File_Name : File_Name_Type; Source_Index : Int; Index_Separator : Character; Object_File_Suffix : Name_Id := No_Name) return File_Name_Type is Index_Img : constant String := Source_Index'Img; Last : Natural; begin Get_Name_String (Source_File_Name); Last := Name_Len; while Last > 1 and then Name_Buffer (Last) /= '.' loop Last := Last - 1; end loop; if Last > 1 then Name_Len := Last - 1; end if; Add_Char_To_Name_Buffer (Index_Separator); Add_Str_To_Name_Buffer (Index_Img (2 .. Index_Img'Last)); if Object_File_Suffix = No_Name then Add_Str_To_Name_Buffer (Object_Suffix); else Get_Name_String_And_Append (Object_File_Suffix); end if; return Name_Find; end Object_Name; ---------------------- -- Record_Temp_File -- ---------------------- procedure Record_Temp_File (Shared : Shared_Project_Tree_Data_Access; Path : Path_Name_Type) is begin if Shared = null then Temp_Files_Table.Append (Temp_Files, Path); else Temp_Files_Table.Append (Shared.Private_Part.Temp_Files, Path); end if; end Record_Temp_File; ---------- -- Free -- ---------- procedure Free (List : in out Aggregated_Project_List) is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Aggregated_Project, Aggregated_Project_List); Tmp : Aggregated_Project_List; begin while List /= null loop Tmp := List.Next; Free (List.Tree); Unchecked_Free (List); List := Tmp; end loop; end Free; ---------------------------- -- Add_Aggregated_Project -- ---------------------------- procedure Add_Aggregated_Project (Project : Project_Id; Path : Path_Name_Type) is Aggregated : Aggregated_Project_List; begin -- Check if the project is already in the aggregated project list. If it -- is, do not add it again. Aggregated := Project.Aggregated_Projects; while Aggregated /= null loop if Path = Aggregated.Path then return; else Aggregated := Aggregated.Next; end if; end loop; Project.Aggregated_Projects := new Aggregated_Project' (Path => Path, Project => No_Project, Tree => null, Node_Tree => null, Next => Project.Aggregated_Projects); end Add_Aggregated_Project; ---------- -- Free -- ---------- procedure Free (Project : in out Project_Id) is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Project_Data, Project_Id); begin if Project /= null then Free (Project.Ada_Include_Path); Free (Project.Objects_Path); Free (Project.Ada_Objects_Path); Free (Project.Ada_Objects_Path_No_Libs); Free_List (Project.Imported_Projects, Free_Project => False); Free_List (Project.All_Imported_Projects, Free_Project => False); Free_List (Project.Languages); case Project.Qualifier is when Aggregate | Aggregate_Library => Free (Project.Aggregated_Projects); when others => null; end case; Unchecked_Free (Project); end if; end Free; --------------- -- Free_List -- --------------- procedure Free_List (Languages : in out Language_List) is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Language_List_Element, Language_List); Tmp : Language_List; begin while Languages /= null loop Tmp := Languages.Next; Unchecked_Free (Languages); Languages := Tmp; end loop; end Free_List; --------------- -- Free_List -- --------------- procedure Free_List (Source : in out Source_Id) is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Source_Data, Source_Id); Tmp : Source_Id; begin while Source /= No_Source loop Tmp := Source.Next_In_Lang; Free_List (Source.Alternate_Languages); if Source.Unit /= null and then Source.Kind in Spec_Or_Body then Source.Unit.File_Names (Source.Kind) := null; end if; Unchecked_Free (Source); Source := Tmp; end loop; end Free_List; --------------- -- Free_List -- --------------- procedure Free_List (List : in out Project_List; Free_Project : Boolean) is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Project_List_Element, Project_List); Tmp : Project_List; begin while List /= null loop Tmp := List.Next; if Free_Project then Free (List.Project); end if; Unchecked_Free (List); List := Tmp; end loop; end Free_List; --------------- -- Free_List -- --------------- procedure Free_List (Languages : in out Language_Ptr) is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Language_Data, Language_Ptr); Tmp : Language_Ptr; begin while Languages /= null loop Tmp := Languages.Next; Free_List (Languages.First_Source); Unchecked_Free (Languages); Languages := Tmp; end loop; end Free_List; ----------- -- Label -- ----------- function Label (Section : Section_Type) return String is begin case Section is when Setup => return "Setup"; when Compile => return "Compile"; when Build_Libraries => return "Build Libraries"; when Bind => return "Bind"; when Link => return "Link"; end case; end Label; -------------------------- -- Reset_Units_In_Table -- -------------------------- procedure Reset_Units_In_Table (Table : in out Units_Htable.Instance) is Unit : Unit_Index; begin Unit := Units_Htable.Get_First (Table); while Unit /= No_Unit_Index loop if Unit.File_Names (Spec) /= null then Unit.File_Names (Spec).Unit := No_Unit_Index; end if; if Unit.File_Names (Impl) /= null then Unit.File_Names (Impl).Unit := No_Unit_Index; end if; Unit := Units_Htable.Get_Next (Table); end loop; end Reset_Units_In_Table; ---------------- -- Free_Units -- ---------------- procedure Free_Units (Table : in out Units_Htable.Instance) is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Unit_Data, Unit_Index); Unit : Unit_Index; begin Unit := Units_Htable.Get_First (Table); while Unit /= No_Unit_Index loop -- We cannot reset Unit.File_Names (Impl or Spec).Unit here as -- Source_Data buffer is freed by the following instruction -- Free_List (Tree.Projects, Free_Project => True); Unchecked_Free (Unit); Unit := Units_Htable.Get_Next (Table); end loop; Units_Htable.Reset (Table); end Free_Units; ---------- -- Free -- ---------- procedure Free (Tree : in out Project_Tree_Ref) is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Project_Tree_Data, Project_Tree_Ref); procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Project_Tree_Appdata'Class, Project_Tree_Appdata_Access); begin if Tree /= null then if Tree.Is_Root_Tree then Name_List_Table.Free (Tree.Shared.Name_Lists); Number_List_Table.Free (Tree.Shared.Number_Lists); String_Element_Table.Free (Tree.Shared.String_Elements); Variable_Element_Table.Free (Tree.Shared.Variable_Elements); Array_Element_Table.Free (Tree.Shared.Array_Elements); Array_Table.Free (Tree.Shared.Arrays); Package_Table.Free (Tree.Shared.Packages); Temp_Files_Table.Free (Tree.Shared.Private_Part.Temp_Files); end if; if Tree.Appdata /= null then Free (Tree.Appdata.all); Unchecked_Free (Tree.Appdata); end if; Source_Paths_Htable.Reset (Tree.Source_Paths_HT); Source_Files_Htable.Reset (Tree.Source_Files_HT); Reset_Units_In_Table (Tree.Units_HT); Free_List (Tree.Projects, Free_Project => True); Free_Units (Tree.Units_HT); Unchecked_Free (Tree); end if; end Free; ------------------------------ -- Languages_Are_Restricted -- ------------------------------ function Languages_Are_Restricted return Boolean is begin return Restricted_Languages /= null; end Languages_Are_Restricted; ----------- -- Reset -- ----------- procedure Reset (Tree : Project_Tree_Ref) is begin -- Visible tables if Tree.Is_Root_Tree then -- We cannot use 'Access here: -- "illegal attribute for discriminant-dependent component" -- However, we know this is valid since Shared and Shared_Data have -- the same lifetime and will always exist concurrently. Tree.Shared := Tree.Shared_Data'Unrestricted_Access; Number_List_Table.Init (Tree.Shared.Number_Lists); String_Element_Table.Init (Tree.Shared.String_Elements); Variable_Element_Table.Init (Tree.Shared.Variable_Elements); Array_Element_Table.Init (Tree.Shared.Array_Elements); Array_Table.Init (Tree.Shared.Arrays); Package_Table.Init (Tree.Shared.Packages); -- As Ada_Runtime_Dir is the key for caching various Ada language -- data, reset it so that the cached values are no longer used. -- Tree.Shared.Ada_Runtime_Dir := No_Name; -- Create Dot_String_List String_Element_Table.Append (Tree.Shared.String_Elements, String_Element' (Value => The_Dot_String, Index => 0, Display_Value => The_Dot_String, Location => No_Location, Next => Nil_String)); Tree.Shared.Dot_String_List := String_Element_Table.Last (Tree.Shared.String_Elements); -- Private part table Temp_Files_Table.Init (Tree.Shared.Private_Part.Temp_Files); Tree.Shared.Private_Part.Current_Source_Path_File := No_Path; Tree.Shared.Private_Part.Current_Object_Path_File := No_Path; end if; Source_Paths_Htable.Reset (Tree.Source_Paths_HT); Source_Files_Htable.Reset (Tree.Source_Files_HT); Replaced_Source_HTable.Reset (Tree.Replaced_Sources); Tree.Replaced_Source_Number := 0; Reset_Units_In_Table (Tree.Units_HT); Free_List (Tree.Projects, Free_Project => True); Free_Units (Tree.Units_HT); end Reset; ------------------------------------- -- Set_Current_Object_Path_File_Of -- ------------------------------------- procedure Set_Current_Object_Path_File_Of (Shared : Shared_Project_Tree_Data_Access; To : Path_Name_Type) is begin Shared.Private_Part.Current_Object_Path_File := To; end Set_Current_Object_Path_File_Of; ------------------------------------- -- Set_Current_Source_Path_File_Of -- ------------------------------------- procedure Set_Current_Source_Path_File_Of (Shared : Shared_Project_Tree_Data_Access; To : Path_Name_Type) is begin Shared.Private_Part.Current_Source_Path_File := To; end Set_Current_Source_Path_File_Of; ----------------------- -- Set_Path_File_Var -- ----------------------- procedure Set_Path_File_Var (Name : String; Value : String) is begin Setenv (Name, Value); end Set_Path_File_Var; ------------------- -- Switches_Name -- ------------------- function Switches_Name (Source_File_Name : File_Name_Type) return File_Name_Type is begin return Extend_Name (Source_File_Name, Switches_Dependency_Suffix); end Switches_Name; ----------- -- Value -- ----------- function Value (Image : String) return Casing_Type is begin for Casing in The_Casing_Images'Range loop if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then return Casing; end if; end loop; raise Constraint_Error; end Value; --------------------- -- Has_Ada_Sources -- --------------------- function Has_Ada_Sources (Data : Project_Id) return Boolean is Lang : Language_Ptr; begin Lang := Data.Languages; while Lang /= No_Language_Index loop if Lang.Name = Name_Ada then return Lang.First_Source /= No_Source; end if; Lang := Lang.Next; end loop; return False; end Has_Ada_Sources; ------------------------ -- Contains_ALI_Files -- ------------------------ function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean is Dir_Name : constant String := Get_Name_String (Dir); Direct : Dir_Type; Name : String (1 .. 1_000); Last : Natural; Result : Boolean := False; begin Open (Direct, Dir_Name); -- For each file in the directory, check if it is an ALI file loop Read (Direct, Name, Last); exit when Last = 0; -- Canonical_Case_File_Name (Name (1 .. Last)); Result := Last >= 5 and then Name (Last - 3 .. Last) = ".ali"; exit when Result; end loop; Close (Direct); return Result; exception -- If there is any problem, close the directory if open and return True. -- The library directory will be added to the path. when others => if Is_Open (Direct) then Close (Direct); end if; return True; end Contains_ALI_Files; -------------------------- -- Get_Object_Directory -- -------------------------- function Get_Object_Directory (Project : Project_Id; Including_Libraries : Boolean; Only_If_Ada : Boolean := False) return Path_Name_Type is begin if (Project.Library and then Including_Libraries) or else (Project.Object_Directory /= No_Path_Information and then (not Including_Libraries or else not Project.Library)) then -- For a library project, add the library ALI directory if there is -- no object directory or if the library ALI directory contains ALI -- files; otherwise add the object directory. if Project.Library then if Project.Object_Directory = No_Path_Information or else (Including_Libraries and then Contains_ALI_Files (Project.Library_ALI_Dir.Display_Name)) then return Project.Library_ALI_Dir.Display_Name; else return Project.Object_Directory.Display_Name; end if; -- For a non-library project, add object directory if it is not a -- virtual project, and if there are Ada sources in the project or -- one of the projects it extends. If there are no Ada sources, -- adding the object directory could disrupt the order of the -- object dirs in the path. elsif not Project.Virtual then declare Add_Object_Dir : Boolean; Prj : Project_Id; begin Add_Object_Dir := not Only_If_Ada; Prj := Project; while not Add_Object_Dir and then Prj /= No_Project loop if Has_Ada_Sources (Prj) then Add_Object_Dir := True; else Prj := Prj.Extends; end if; end loop; if Add_Object_Dir then return Project.Object_Directory.Display_Name; end if; end; end if; end if; return No_Path; end Get_Object_Directory; ----------------------------------- -- Ultimate_Extending_Project_Of -- ----------------------------------- function Ultimate_Extending_Project_Of (Proj : Project_Id; Before : Project_Id := No_Project) return Project_Id is Prj : Project_Id := Proj; begin if Prj /= No_Project then while Prj.Extended_By not in No_Project | Before loop Prj := Prj.Extended_By; end loop; end if; return Prj; end Ultimate_Extending_Project_Of; ----------------------------------- -- Compute_All_Imported_Projects -- ----------------------------------- procedure Compute_All_Imported_Projects (Root_Project : Project_Id; Tree : Project_Tree_Ref) is procedure Analyze_Tree (Local_Root : Project_Id; Local_Tree : Project_Tree_Ref; Context : Project_Context); -- Process Project and all its aggregated project to analyze their own -- imported projects. ------------------ -- Analyze_Tree -- ------------------ procedure Analyze_Tree (Local_Root : Project_Id; Local_Tree : Project_Tree_Ref; Context : Project_Context) is pragma Unreferenced (Local_Root); Project : Project_Id; procedure Recursive_Add (Prj : Project_Id; Tree : Project_Tree_Ref; Context : Project_Context; Dummy : in out Boolean); -- Recursively add the projects imported by project Project, but not -- those that are extended. ------------------- -- Recursive_Add -- ------------------- procedure Recursive_Add (Prj : Project_Id; Tree : Project_Tree_Ref; Context : Project_Context; Dummy : in out Boolean) is pragma Unreferenced (Tree); List : Project_List; Prj2 : Project_Id; begin -- A project is not importing itself Prj2 := Ultimate_Extending_Project_Of (Prj); if Project /= Prj2 then -- Check that the project is not already in the list. We know -- the one passed to Recursive_Add have never been visited -- before, but the one passed it are the extended projects. List := Project.All_Imported_Projects; while List /= null loop if List.Project = Prj2 then return; end if; List := List.Next; end loop; -- Add it to the list Project.All_Imported_Projects := new Project_List_Element' (Project => Prj2, From_Encapsulated_Lib => Context.From_Encapsulated_Lib or else Analyze_Tree.Context.From_Encapsulated_Lib, Next => Project.All_Imported_Projects); end if; end Recursive_Add; procedure For_All_Projects is new For_Every_Project_Imported_Context (Boolean, Recursive_Add); Dummy : Boolean := False; List : Project_List; begin List := Local_Tree.Projects; while List /= null loop Project := List.Project; Free_List (Project.All_Imported_Projects, Free_Project => False); For_All_Projects (Project, Local_Tree, Dummy, Include_Aggregated => False); List := List.Next; end loop; end Analyze_Tree; procedure For_Aggregates is new For_Project_And_Aggregated_Context (Analyze_Tree); -- Start of processing for Compute_All_Imported_Projects begin For_Aggregates (Root_Project, Tree); end Compute_All_Imported_Projects; ------------------- -- Is_Compilable -- ------------------- function Is_Compilable (Source : Source_Id) return Boolean is begin case Source.Compilable is when Unknown => if (Source.Language.Config.Compiler_Driver not in No_File | Empty_File or else Gprls_Mode) and then not Source.Locally_Removed and then (Source.Language.Config.Kind /= File_Based or else Source.Kind /= Spec) then -- Do not modify Source.Compilable before the source record -- has been initialized. if Source.Source_TS /= Empty_Time_Stamp then Source.Compilable := Yes; end if; return True; else if Source.Source_TS /= Empty_Time_Stamp then Source.Compilable := No; end if; return False; end if; when Yes => return True; when No => return False; end case; end Is_Compilable; ------------------------------ -- Object_To_Global_Archive -- ------------------------------ function Object_To_Global_Archive (Source : Source_Id) return Boolean is begin return Source.Language.Config.Kind = File_Based and then Source.Kind = Impl and then Source.Language.Config.Objects_Linked and then Is_Compilable (Source) and then Source.Language.Config.Object_Generated; end Object_To_Global_Archive; ---------------------------- -- Get_Language_From_Name -- ---------------------------- function Get_Language_From_Name (Project : Project_Id; Name : String) return Language_Ptr is N : Name_Id; Result : Language_Ptr; begin N := Get_Lower_Name_Id (Name); Result := Project.Languages; while Result /= No_Language_Index loop if Result.Name = N then return Result; end if; Result := Result.Next; end loop; return No_Language_Index; end Get_Language_From_Name; ---------------------------- -- Has_Language_From_Name -- ---------------------------- function Has_Language_From_Name (Project : Project_Id; Name : String) return Boolean is begin return (Get_Language_From_Name (Project, Name) /= No_Language_Index); end Has_Language_From_Name; ---------------- -- Other_Part -- ---------------- function Other_Part (Source : Source_Id) return Source_Id is begin if Source.Unit /= No_Unit_Index then case Source.Kind is when Impl => return Source.Unit.File_Names (Spec); when Spec => return Source.Unit.File_Names (Impl); when Sep => return No_Source; end case; else return No_Source; end if; end Other_Part; ------------------ -- Create_Flags -- ------------------ function Create_Flags (Report_Error : Error_Handler; When_No_Sources : Error_Warning; Require_Sources_Other_Lang : Boolean := True; Allow_Duplicate_Basenames : Boolean := True; Compiler_Driver_Mandatory : Boolean := False; Error_On_Unknown_Language : Boolean := True; Require_Obj_Dirs : Error_Warning := Error; Allow_Invalid_External : Error_Warning := Error; Missing_Project_Files : Error_Warning := Error; Missing_Source_Files : Error_Warning := Error; Ignore_Missing_With : Boolean := False; Check_Configuration_Only : Boolean := False) return Processing_Flags is begin return Processing_Flags' (Report_Error => Report_Error, When_No_Sources => When_No_Sources, Require_Sources_Other_Lang => Require_Sources_Other_Lang, Allow_Duplicate_Basenames => Allow_Duplicate_Basenames, Error_On_Unknown_Language => Error_On_Unknown_Language, Compiler_Driver_Mandatory => Compiler_Driver_Mandatory, Require_Obj_Dirs => Require_Obj_Dirs, Allow_Invalid_External => Allow_Invalid_External, Missing_Project_Files => Missing_Project_Files, Missing_Source_Files => Missing_Source_Files, Ignore_Missing_With => Ignore_Missing_With, Incomplete_Withs => False, Check_Configuration_Only => Check_Configuration_Only); end Create_Flags; ------------ -- Length -- ------------ function Length (Table : Name_List_Table.Instance; List : Name_List_Index) return Natural is Count : Natural := 0; Tmp : Name_List_Index; begin Tmp := List; while Tmp /= No_Name_List loop Count := Count + 1; Tmp := Table.Table (Tmp).Next; end loop; return Count; end Length; ------------------ -- Debug_Output -- ------------------ procedure Debug_Output (Str : String) is begin if Current_Verbosity > Default then Set_Standard_Error; Write_Line ((1 .. Debug_Level * 2 => ' ') & Str); Set_Standard_Output; end if; end Debug_Output; ------------------ -- Debug_Indent -- ------------------ procedure Debug_Indent is begin if Current_Verbosity = High then Set_Standard_Error; Write_Str ((1 .. Debug_Level * 2 => ' ')); Set_Standard_Output; end if; end Debug_Indent; ------------------ -- Debug_Output -- ------------------ procedure Debug_Output (Str : String; Str2 : Name_Id) is begin if Current_Verbosity > Default then Debug_Indent; Set_Standard_Error; Write_Str (Str); if Str2 = No_Name then Write_Line (" "); else Write_Line (" """ & Get_Name_String_Safe (Str2) & '"'); end if; Set_Standard_Output; end if; end Debug_Output; --------------------------- -- Debug_Increase_Indent -- --------------------------- procedure Debug_Increase_Indent (Str : String := ""; Str2 : Name_Id := No_Name) is begin if Str2 /= No_Name then Debug_Output (Str, Str2); else Debug_Output (Str); end if; Debug_Level := Debug_Level + 1; end Debug_Increase_Indent; --------------------------- -- Debug_Decrease_Indent -- --------------------------- procedure Debug_Decrease_Indent (Str : String := "") is begin if Debug_Level > 0 then Debug_Level := Debug_Level - 1; end if; if Str /= "" then Debug_Output (Str); end if; end Debug_Decrease_Indent; ---------------- -- Debug_Name -- ---------------- function Debug_Name (Tree : Project_Tree_Ref) return Name_Id is P : Project_List; begin Set_Name_Buffer ("Tree ["); P := Tree.Projects; while P /= null loop if P /= Tree.Projects then Add_Char_To_Name_Buffer (','); end if; Add_Str_To_Name_Buffer (Get_Name_String (P.Project.Name)); P := P.Next; end loop; Add_Char_To_Name_Buffer (']'); return Name_Find; end Debug_Name; -------------- -- Distance -- -------------- function Distance (L, R : String) return Natural is D : array (L'First - 1 .. L'Last, R'First - 1 .. R'Last) of Natural; begin for I in D'Range (1) loop D (I, D'First (2)) := I; end loop; for I in D'Range (2) loop D (D'First (1), I) := I; end loop; for J in R'Range loop for I in L'Range loop D (I, J) := Natural'Min (Natural'Min (D (I - 1, J), D (I, J - 1)) + 1, D (I - 1, J - 1) + (if L (I) = R (J) then 0 else 1)); if J > R'First and then I > L'First and then R (J) = L (I - 1) and then R (J - 1) = L (I) then D (I, J) := Natural'Min (D (I, J), D (I - 2, J - 2) + 1); end if; end loop; end loop; return D (L'Last, R'Last); end Distance; ---------- -- Free -- ---------- procedure Free (Tree : in out Project_Tree_Appdata) is pragma Unreferenced (Tree); begin null; end Free; -------------------------------- -- For_Project_And_Aggregated -- -------------------------------- procedure For_Project_And_Aggregated (Root_Project : Project_Id; Root_Tree : Project_Tree_Ref) is Agg : Aggregated_Project_List; begin Action (Root_Project, Root_Tree); if Root_Project.Qualifier in Aggregate_Project then Agg := Root_Project.Aggregated_Projects; while Agg /= null loop For_Project_And_Aggregated (Agg.Project, Agg.Tree); Agg := Agg.Next; end loop; end if; end For_Project_And_Aggregated; ---------------------------------------- -- For_Project_And_Aggregated_Context -- ---------------------------------------- procedure For_Project_And_Aggregated_Context (Root_Project : Project_Id; Root_Tree : Project_Tree_Ref) is procedure Recursive_Process (Project : Project_Id; Tree : Project_Tree_Ref; Context : Project_Context); -- Process Project and all aggregated projects recursively ----------------------- -- Recursive_Process -- ----------------------- procedure Recursive_Process (Project : Project_Id; Tree : Project_Tree_Ref; Context : Project_Context) is Agg : Aggregated_Project_List; Ctx : Project_Context; begin Action (Project, Tree, Context); if Project.Qualifier in Aggregate_Project then Ctx := (In_Aggregate_Lib => Project.Qualifier = Aggregate_Library, From_Encapsulated_Lib => Context.From_Encapsulated_Lib or else Project.Standalone_Library = Encapsulated); Agg := Project.Aggregated_Projects; while Agg /= null loop Recursive_Process (Agg.Project, Agg.Tree, Ctx); Agg := Agg.Next; end loop; end if; end Recursive_Process; -- Start of processing for For_Project_And_Aggregated_Context begin Recursive_Process (Root_Project, Root_Tree, Project_Context'(False, False)); end For_Project_And_Aggregated_Context; -------------------------- -- Set_Require_Obj_Dirs -- -------------------------- procedure Set_Require_Obj_Dirs (Flags : in out Processing_Flags; Value : Error_Warning) is begin Flags.Require_Obj_Dirs := Value; end Set_Require_Obj_Dirs; ----------------------------- -- Set_Ignore_Missing_With -- ----------------------------- procedure Set_Ignore_Missing_With (Flags : in out Processing_Flags; Value : Boolean) is begin Flags.Ignore_Missing_With := Value; end Set_Ignore_Missing_With; ---------------------------------- -- Set_Check_Configuration_Only -- ---------------------------------- procedure Set_Check_Configuration_Only (Flags : in out Processing_Flags; Value : Boolean) is begin Flags.Check_Configuration_Only := Value; end Set_Check_Configuration_Only; ------------------------------ -- Set_Missing_Source_Files -- ------------------------------ procedure Set_Missing_Source_Files (Flags : in out Processing_Flags; Value : Error_Warning) is begin Flags.Missing_Source_Files := Value; end Set_Missing_Source_Files; begin Temp_Files_Table.Init (Temp_Files); end GPR; gprbuild-25.0.0/gpr/src/gpr.ads000066400000000000000000003575611470075373400163010ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2023, AdaCore -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- The following package declares the data types for GNAT project. -- These data types may be used by GNAT Project-aware tools. -- Children of this package implement various services on these data types with Ada.Containers.Hashed_Maps; with Ada.Containers.Indefinite_Ordered_Sets; with Ada.Containers.Ordered_Sets; with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables; with GNAT.Dynamic_Tables; with GNAT.OS_Lib; use GNAT.OS_Lib; with System.Storage_Elements; package GPR is EOF : constant Character := ASCII.SUB; -- The character SUB (16#1A#) is used in DOS and other systems derived -- from DOS (XP, NT etc) to signal the end of a text file. Internally all -- source files are ended by an EOF character, even on Unix systems. An EOF -- character acts as the end of file only as the last character of a source -- buffer, in any other position, it is treated as a blank if it appears -- between tokens, and as an illegal character otherwise. This makes -- life easier dealing with files that originated from DOS, including -- concatenated files with interspersed EOF characters. Shared_Libgcc : constant String := "-shared-libgcc"; Static_Libgcc : constant String := "-static-libgcc"; Dash_Shared : constant String := "-shared"; Dash_Static : constant String := "-static"; Dash_Lgnat : constant String := "-lgnat"; Dash_Lgnarl : constant String := "-lgnarl"; On_Windows : constant Boolean := Directory_Separator = '\'; -- True when on Windows ----------- -- Types -- ----------- ------------------------------- -- General Use Integer Types -- ------------------------------- type Int is range -2 ** 31 .. +2 ** 31 - 1; -- Signed 32-bit integer subtype Nat is Int range 0 .. Int'Last; -- Non-negative Int values subtype Pos is Int range 1 .. Int'Last; -- Positive Int values type Word is mod 2 ** 32; -- Unsigned 32-bit integer type size_t is mod 2 ** Standard'Address_Size; subtype Upper_Half_Character is Character range Character'Val (16#80#) .. Character'Val (16#FF#); -- 8-bit Characters with the upper bit set subtype Graphic_Character is Character range ' ' .. '~'; -- Graphic characters, as defined in Ada Reference Manual subtype Line_Terminator is Character range ASCII.LF .. ASCII.CR; -- Line terminator characters (LF, VT, FF, CR) type Source_Ptr is new Int; -- Type used to represent a source location, which is a subscript of a -- character in the source buffer. As noted above, different source buffers -- have different ranges, so it is possible to tell from a Source_Ptr value -- which source it refers to. Note that negative numbers are allowed to -- accommodate the following special values. No_Location : constant Source_Ptr := -1; -- Value used to indicate no source position set in a node. A test for a -- Source_Ptr value being > No_Location is the approved way to test for a -- standard value that does not include No_Location or any of the following -- special definitions. One important use of No_Location is to label -- generated nodes that we don't want the debugger to see in normal mode -- (very often we conditionalize so that we set No_Location in normal mode -- and the corresponding source line in -gnatD mode). First_Source_Ptr : constant Source_Ptr := 0; -- Starting source pointer index value for first source program type Source_File_Index is new Int range -1 .. Int'Last; -- Type used to index the source file table (see package GPR.Sinput) No_Source_File : constant Source_File_Index := 0; -- Value used to indicate no source file present ----------- -- Nodes -- ----------- type Node_Id is range 0 .. 99_999_999; -- Type used to identify nodes in the tree Empty_Node : constant Node_Id := 0; -- Used to indicate null node. A node is actually allocated with this Id -- value, so that Nkind (Empty) = N_Empty. Note that Node_Low_Bound is -- zero, so Empty = No_List = zero. Error_Node : constant Node_Id := 1; -- Used to indicate an error in the source program. A node is actually -- allocated with this Id value, so that Nkind (Error) = N_Error. First_Node_Id : constant Node_Id := 0; -- Subscript of first allocated node. Note that Empty and Error are both -- allocated nodes, whose Nkind fields can be accessed without error. Unrecoverable_Error : exception; ------------------- -- Project nodes -- ------------------- Project_Nodes_Initial : constant := 1_000; Project_Nodes_Increment : constant := 100; -- Allocation parameters for initializing and extending number -- of nodes in table Tree_Private_Part.Project_Nodes Project_Node_Low_Bound : constant := 0; Project_Node_High_Bound : constant := 099_999_999; -- Range of values for project node id's (in practice infinite) type Project_Node_Id is range Project_Node_Low_Bound .. Project_Node_High_Bound; -- The index of table Tree_Private_Part.Project_Nodes Empty_Project_Node : constant Project_Node_Id := Project_Node_Low_Bound; -- Designates no node in table Project_Nodes First_Project_Node_Id : constant Project_Node_Id := Project_Node_Low_Bound + 1; type Response_File_Format is (None, GNU, Object_List, Option_List, GCC, GCC_GNU, GCC_Object_List, GCC_Option_List); -- The format of the different response files ------------ -- Stamps -- ------------ package Stamps is ----------------------------------- -- Representation of Time Stamps -- ----------------------------------- -- All compiled units are marked with a time stamp which is derived from -- the source file (we assume that the host system has the concept of a -- file time stamp which is modified when a file is modified). These -- time stamps are used to ensure consistency of the set of units that -- constitutes a library. Time stamps are 14-character strings with -- with the following format: -- YYYYMMDDHHMMSS -- YYYY year -- MM month (2 digits 01-12) -- DD day (2 digits 01-31) -- HH hour (2 digits 00-23) -- MM minutes (2 digits 00-59) -- SS seconds (2 digits 00-59) -- In the case of Unix systems (and other systems which keep the time in -- GMT), the time stamp is the GMT time of the file, not the local time. -- This solves problems in using libraries across networks with clients -- spread across multiple time-zones. Time_Stamp_Length : constant := 14; -- Length of time stamp value subtype Time_Stamp_Index is Natural range 1 .. Time_Stamp_Length; type Time_Stamp_Type is new String (Time_Stamp_Index); -- Type used to represent time stamp Empty_Time_Stamp : constant Time_Stamp_Type := (others => ' '); -- Value representing an empty or missing time stamp. Looks less than -- any real time stamp if two time stamps are compared. Note that -- although this is not private, clients should not rely on the exact -- way in which this string is represented, and instead should use the -- subprograms below. -- Note : the Empty_Time_Stamp value less than any non-empty time stamp -- value. Dummy_Time_Stamp : constant Time_Stamp_Type := (others => '0'); -- This is used for dummy time stamp values used in the D lines for -- non-existent files, and is intended to be an impossible value. end Stamps; use Stamps; -------------------- -- Default Output -- -------------------- type Section_Type is (Setup, Compile, Build_Libraries, Bind, Link); -- Different sections in the default output, when switches -q and -v are -- not used. procedure Set (Section : Section_Type); -- Indicate that the section header does not need to be output again. -- This is used by gprbind and gprlib to avoid display the section header -- again. procedure Display (Section : Section_Type; Command : String; Argument : String); -- Display a command in the standard output. Display first the section -- header if it has not been already displayed. -------------------- type Name_Id is range 0 .. 99_999_999; No_Name : constant Name_Id := 0; Error_Name : constant Name_Id := 1; First_Name_Id : constant Name_Id := 2; -- Subscript of first entry in names table package Name_Id_Set is new Ada.Containers.Ordered_Sets (Name_Id); type Unit_Name_Type is new Name_Id; -- Unit names are stored in the names table and this type is used to -- indicate that a Name_Id value is being used to hold a unit name, -- which terminates in %b for a body or %s for a spec. No_Unit_Name : constant Unit_Name_Type := Unit_Name_Type (No_Name); -- Constant used to indicate no file name present Error_Unit_Name : constant Unit_Name_Type := Unit_Name_Type (Error_Name); -- The special Unit_Name_Type value Error_Unit_Name is used to indicate -- a unit name where some previous processing has found an error. package String_Sets is new Ada.Containers.Indefinite_Ordered_Sets (String); ------------------------------ -- File and Path Name Types -- ------------------------------ type File_Name_Type is new Name_Id; -- File names are stored in the names table and this type is used to -- indicate that a Name_Id value is being used to hold a simple file -- name (which does not include any directory information). No_File : constant File_Name_Type := File_Name_Type (No_Name); -- Constant used to indicate no file is present (this is used for -- example when a search for a file indicates that no file of the -- name exists). Error_File_Name : constant File_Name_Type := File_Name_Type (Error_Name); -- The special File_Name_Type value Error_File_Name is used to indicate -- a unit name where some previous processing has found an error. type Path_Name_Type is new Name_Id; -- Path names are stored in the names table and this type is used to -- indicate that a Name_Id value is being used to hold a path name (that -- may contain directory information). No_Path : constant Path_Name_Type := Path_Name_Type (No_Name); -- Constant used to indicate no path name is present File_Attributes_Size : constant Natural := 32; type File_Attributes is array (1 .. File_Attributes_Size) of System.Storage_Elements.Storage_Element; for File_Attributes'Alignment use Standard'Maximum_Alignment; -- A cache for various attributes for a file (length, accessibility,...) -- This must be initialized to Unknown_Attributes prior to the first call. Unknown_Attributes : File_Attributes := (others => 0); -- A cache for various attributes for a file (length, accessibility,...) -- Will be initialized properly at elaboration (for efficiency later on, -- avoid function calls every time we want to reset the attributes) prior -- to the first usage. We cannot make it constant since the compiler may -- put it in a read-only section. Ada_Include_Path : constant String := "ADA_INCLUDE_PATH"; Ada_Objects_Path : constant String := "ADA_OBJECTS_PATH"; Project_Include_Path_File : constant String := "ADA_PRJ_INCLUDE_FILE"; Project_Objects_Path_File : constant String := "ADA_PRJ_OBJECTS_FILE"; procedure Add_Restricted_Language (Name : String); -- Call by gprbuild for each language specified by switch -- --restricted-to-languages=. procedure Remove_All_Restricted_Languages; -- Call by gprbuild in CodePeer mode to ignore switches -- --restricted-to-languages=. function Is_Allowed_Language (Name : Name_Id) return Boolean; -- Returns True if --restricted-to-languages= is not used or if Name -- is one of the restricted languages. function Languages_Are_Restricted return Boolean; -- Returns True iff the list of restricted languages is not empty. All_Other_Names : constant Name_Id := Name_Id'Last; -- Name used to replace others as an index of an associative array -- attribute in situations where this is allowed. Subdirs : String_Access; -- The value after the equal sign in switch --subdirs=... -- Contains the relative subdirectory. Src_Subdirs : String_Access; -- The value after the equal sign in switch --src-subdirs=... -- Contains the relative subdirectory. Build_Tree_Dir : String_Access; -- A root directory for building out-of-tree projects. All relative object -- directories will be rooted at this location. Root_Dir : String_Access; -- When using out-of-tree build we need to keep information about the root -- directory of artifacts to properly relocate them. Note that the root -- directory is not necessarily the directory of the main project. Getrusage : String_Access; -- Print getrusage call output to file type Library_Support is (None, Static_Only, Full); -- Support for Library Project File. -- - None: Library Project Files are not supported at all -- - Static_Only: Library Project Files are only supported for static -- libraries. -- - Full: Library Project Files are supported for static and dynamic -- (shared) libraries. type Yes_No_Unknown is (Yes, No, Unknown); -- Tri-state to decide if -lgnarl is needed when linking type Attribute_Default_Value is (Read_Only_Value, -- For read only attributes (Name,Project_Dir) Empty_Value, -- Empty string or empty string list Dot_Value, -- "." or (".") Object_Dir_Value, -- 'Object_Dir Target_Value, -- 'Target (special rules) Runtime_Value, -- 'Runtime (special rules) Canonical_Target_Value); -- 'Canonical_Target (special rules) -- Describe the default values of attributes that are referenced but not -- declared. pragma Warnings (Off); type Project_Qualifier is (Unspecified, -- The following clash with Standard is OK, and justified by the context -- which really wants to use the same set of qualifiers. Standard, Library, Configuration, Abstract_Project, Aggregate, Aggregate_Library); pragma Warnings (On); -- Qualifiers that can prefix the reserved word "project" in a project -- file: -- Standard: standard project ... -- Library: library project is ... -- Abstract_Project: abstract project is -- Aggregate: aggregate project is -- Aggregate_Library: aggregate library project is ... -- Configuration: configuration project is ... subtype Aggregate_Project is Project_Qualifier range Aggregate .. Aggregate_Library; All_Packages : constant String_List_Access; -- Default value of parameter Packages of procedures Parse, in Prj.Pars and -- Prj.Part, indicating that all packages should be checked. type Project_Tree_Data; type Project_Tree_Ref is access all Project_Tree_Data; -- Reference to a project tree. Several project trees may exist in memory -- at the same time. No_Project_Tree : constant Project_Tree_Ref; procedure Free (Tree : in out Project_Tree_Ref); -- Free memory associated with the tree Config_Project_File_Extension : String := ".cgpr"; Project_File_Extension : String := ".gpr"; -- The standard config and user project file name extensions. They are not -- constants, because Canonical_Case_File_Name is called on these variables -- in the body of Prj. GNAT_And_Space : constant String := "GNAT "; function Empty_File return File_Name_Type with Inline_Always; function Empty_String return Name_Id with Inline_Always; -- Return the id for an empty string "" function Dot_String return Name_Id with Inline_Always; -- Return the id for "." type Path_Information is record Name : Path_Name_Type := No_Path; Display_Name : Path_Name_Type := No_Path; end record; -- Directory names always end with a directory separator No_Path_Information : constant Path_Information := (No_Path, No_Path); type Project_Data; type Project_Id is access all Project_Data; No_Project : constant Project_Id := null; -- Id of a Project File type String_List_Id is new Nat; Nil_String : constant String_List_Id := 0; type String_Element is record Value : Name_Id := No_Name; Index : Int := 0; Display_Value : Name_Id := No_Name; Location : Source_Ptr := No_Location; Next : String_List_Id := Nil_String; end record; -- To hold values for string list variables and array elements. package String_Element_Table is new GNAT.Dynamic_Tables (Table_Component_Type => String_Element, Table_Index_Type => String_List_Id, Table_Low_Bound => 1, Table_Initial => 200, Table_Increment => 100); -- The table for string elements in string lists type Variable_Kind is (Undefined, List, Single); -- Different kinds of variables subtype Defined_Variable_Kind is Variable_Kind range List .. Single; -- The defined kinds of variables Ignored : constant Variable_Kind; -- Used to indicate that a package declaration must be ignored while -- processing the project tree (unknown package name). type Variable_Value (Kind : Variable_Kind := Undefined) is record Project : Project_Id := No_Project; Location : Source_Ptr := No_Location; String_Type : Project_Node_Id := Empty_Project_Node; Default : Boolean := False; From_Implicit_Target : Boolean := False; case Kind is when Undefined => null; when List => Values : String_List_Id := Nil_String; Concat : Boolean := False; when Single => Value : Name_Id := No_Name; Index : Int := 0; end case; end record; -- Values for variables and array elements. Default is True if the -- current value is the default one for the variable. String_Type is -- Empty_Project_Node, except for typed variables where it designates -- the string type node. -- -- From_Implicit_Target is only changed to True when evaluating -- an expression that depends on 'Target reference, and the target is not -- explicitly declared in corresponding project. In such case the 'Target -- is still evaluated to normalized hostname, however at configuration -- phase it is not possible to distinguish this case from real explicit -- native target specification. So if in root project we have -- for Target use Imported_Project'Target; -- and Imported_Project has no explicit target declaration it is otherwise -- not possible to understand that target fallback if needed. Nil_Variable_Value : constant Variable_Value; -- Value of a non existing variable or array element type Variable_Id is new Nat; No_Variable : constant Variable_Id := 0; type Variable is record Next : Variable_Id := No_Variable; Name : Name_Id; Value : Variable_Value; end record; -- To hold the list of variables in a project file and in packages package Variable_Element_Table is new GNAT.Dynamic_Tables (Table_Component_Type => Variable, Table_Index_Type => Variable_Id, Table_Low_Bound => 1, Table_Initial => 200, Table_Increment => 100); -- The table of variable in list of variables type Array_Element_Id is new Nat; No_Array_Element : constant Array_Element_Id := 0; type Array_Element is record Index : Name_Id; Restricted : Boolean := False; Src_Index : Int := 0; Index_Case_Sensitive : Boolean := True; Value : Variable_Value; Next : Array_Element_Id := No_Array_Element; end record; -- Each Array_Element represents an array element and is linked (Next) -- to the next array element, if any, in the array. package Array_Element_Table is new GNAT.Dynamic_Tables (Table_Component_Type => Array_Element, Table_Index_Type => Array_Element_Id, Table_Low_Bound => 1, Table_Initial => 200, Table_Increment => 100); -- The table that contains all array elements type Array_Id is new Nat; No_Array : constant Array_Id := 0; type Array_Data is record Name : Name_Id := No_Name; Location : Source_Ptr := No_Location; Value : Array_Element_Id := No_Array_Element; Next : Array_Id := No_Array; end record; -- Each Array_Data value represents an array. -- Value is the id of the first element. -- Next is the id of the next array in the project file or package. package Array_Table is new GNAT.Dynamic_Tables (Table_Component_Type => Array_Data, Table_Index_Type => Array_Id, Table_Low_Bound => 1, Table_Initial => 200, Table_Increment => 100); -- The table that contains all arrays type Package_Id is new Nat; No_Package : constant Package_Id := 0; type Declarations is record Variables : Variable_Id := No_Variable; Attributes : Variable_Id := No_Variable; Arrays : Array_Id := No_Array; Packages : Package_Id := No_Package; end record; -- Contains the declarations (variables, single and array attributes, -- packages) for a project or a package in a project. No_Declarations : constant Declarations := (Variables => No_Variable, Attributes => No_Variable, Arrays => No_Array, Packages => No_Package); -- Default value of Declarations: used if there are no declarations type Package_Element is record Name : Name_Id := No_Name; Decl : Declarations := No_Declarations; Parent : Package_Id := No_Package; Next : Package_Id := No_Package; end record; -- A package (includes declarations that may include other packages) package Package_Table is new GNAT.Dynamic_Tables (Table_Component_Type => Package_Element, Table_Index_Type => Package_Id, Table_Low_Bound => 1, Table_Initial => 100, Table_Increment => 100); -- The table that contains all packages type Language_Data; type Language_Ptr is access all Language_Data; -- Index of language data No_Language_Index : constant Language_Ptr := null; -- Constant indicating that there is no language data function Get_Language_From_Name (Project : Project_Id; Name : String) return Language_Ptr; -- Get a language from a project. This might return null if no such -- language exists in the project function Has_Language_From_Name (Project : Project_Id; Name : String) return Boolean; -- Return whether or not Project has language Name in it. Max_Header_Num : constant := 6150; type Header_Num is range 0 .. Max_Header_Num; -- Size for hash table below. The upper bound is an arbitrary value, the -- value here was chosen after testing to determine a good compromise -- between speed of access and memory usage. function Hash (Name : Name_Id) return Header_Num; function Hash (Name : File_Name_Type) return Header_Num; function Hash (Name : Path_Name_Type) return Header_Num; function Hash (Project : Project_Id) return Header_Num; -- Used for computing hash values for names put into hash tables type Language_Kind is (File_Based, Unit_Based); -- Type for the kind of language. All languages are file based, except Ada -- which is unit based. -- Type of dependency to be checked type Dependency_File_Kind is (None, -- There is no dependency file, the source must always be recompiled Makefile, -- The dependency file is a Makefile fragment indicating all the files -- the source depends on. If the object file or the dependency file is -- more recent than any of these files, the source must be recompiled. ALI_File, -- The dependency file is an ALI file and the source must be recompiled -- if the object or ALI file is more recent than any of the sources -- listed in the D lines. ALI_Closure); -- The dependency file is an ALI file and the source must be recompiled -- if the object or ALI file is more recent than any source in the full -- closure. subtype ALI_Dependency is Dependency_File_Kind range ALI_File .. ALI_Closure; Makefile_Dependency_Suffix : constant String := ".d"; ALI_Dependency_Suffix : constant String := ".ali"; Switches_Dependency_Suffix : constant String := ".cswi"; Binder_Exchange_Suffix : constant String := ".bexch"; -- Suffix for binder exchange files Library_Exchange_Suffix : constant String := ".lexch"; -- Suffix for library exchange files type Name_List_Index is new Nat; No_Name_List : constant Name_List_Index := 0; type Name_Node is record Name : Name_Id := No_Name; Next : Name_List_Index := No_Name_List; end record; package Name_List_Table is new GNAT.Dynamic_Tables (Table_Component_Type => Name_Node, Table_Index_Type => Name_List_Index, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 100); -- The table for lists of names function Length (Table : Name_List_Table.Instance; List : Name_List_Index) return Natural; -- Return the number of elements in specified list type Number_List_Index is new Nat; No_Number_List : constant Number_List_Index := 0; type Number_Node is record Number : Natural := 0; Next : Number_List_Index := No_Number_List; end record; package Number_List_Table is new GNAT.Dynamic_Tables (Table_Component_Type => Number_Node, Table_Index_Type => Number_List_Index, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 100); -- The table for lists of numbers package Mapping_Files_Htable is new Simple_HTable (Header_Num => Header_Num, Element => Path_Name_Type, No_Element => No_Path, Key => Path_Name_Type, Hash => Hash, Equal => "="); -- A hash table to store the mapping files that are not used -- The following record ??? type Casing_Type is ( All_Upper_Case, -- All letters are upper case All_Lower_Case, -- All letters are lower case Mixed_Case, -- The initial letter, and any letters after underlines are upper case. -- All other letters are lower case Unknown -- Used if an identifier does not distinguish between the above cases, -- (e.g. X, Y_3, M4, A_B, or if it is inconsistent ABC_def). ); subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case; -- Exclude Unknown casing type Lang_Naming_Data is record Dot_Replacement : File_Name_Type := No_File; -- The string to replace '.' in the source file name (for Ada) Casing : Casing_Type := All_Lower_Case; -- The casing of the source file name (for Ada) Separate_Suffix : File_Name_Type := No_File; -- String to append to unit name for source file name of an Ada subunit Spec_Suffix : File_Name_Type := No_File; -- The string to append to the unit name for the -- source file name of a spec. Body_Suffix : File_Name_Type := No_File; -- The string to append to the unit name for the -- source file name of a body. end record; No_Lang_Naming_Data : constant Lang_Naming_Data := (others => <>); function Is_Standard_GNAT_Naming (Naming : Lang_Naming_Data) return Boolean; -- True if the naming scheme is GNAT's default naming scheme. This -- is to take into account shortened names like "Ada." (a-), "System." (s-) -- and so on. type Source_Data; type Source_Id is access all Source_Data; function Is_Compilable (Source : Source_Id) return Boolean; pragma Inline (Is_Compilable); -- Return True if we know how to compile Source (i.e. if a compiler is -- defined). This doesn't indicate whether the source should be compiled. function Object_To_Global_Archive (Source : Source_Id) return Boolean; pragma Inline (Object_To_Global_Archive); -- Return True if the object file should be put in the global archive. -- This is for Ada, when only the closure of a main needs to be -- (re)compiled. function Other_Part (Source : Source_Id) return Source_Id; pragma Inline (Other_Part); -- Source ID for the other part, if any: for a spec, returns its body; -- for a body, returns its spec. No_Source : constant Source_Id := null; -- The following record describes the configuration of a language type Language_Config is record Kind : Language_Kind := File_Based; -- Kind of language. Most languages are file based. A few, such as Ada, -- are unit based. Naming_Data : Lang_Naming_Data; -- The naming data for the languages (prefixes, etc.) Include_Compatible_Languages : Name_List_Index := No_Name_List; -- List of languages that are "include compatible" with this language. A -- language B (for example "C") is "include compatible" with a language -- A (for example "C++") if it is expected that sources of language A -- may "include" header files from language B. Compiler_Driver : File_Name_Type := No_File; -- The name of the executable for the compiler of the language Compiler_Driver_Path : String_Access := null; -- The path name of the executable for the compiler of the language Compiler_Leading_Required_Switches : Name_List_Index := No_Name_List; -- The list of initial switches that are required as a minimum to invoke -- the compiler driver. Compiler_Trailing_Required_Switches : Name_List_Index := No_Name_List; -- The list of final switches that are required as a minimum to invoke -- the compiler driver. Multi_Unit_Switches : Name_List_Index := No_Name_List; -- The switch(es) to indicate the index of a unit in a multi-source file Multi_Unit_Object_Separator : Character := ' '; -- The string separating the base name of a source from the index of the -- unit in a multi-source file, in the object file name. Source_File_Switches : Name_List_Index := No_Name_List; -- Optional switches to be put before the source file. The source file -- path name is appended to the last switch in the list. -- Example: ("-i", ""); Object_File_Suffix : Name_Id := No_Name; -- Optional alternate object file suffix Object_File_Switches : Name_List_Index := No_Name_List; -- Optional object file switches. When this is defined, the switches -- are used to specify the object file. The object file name is appended -- to the last switch in the list. Example: ("-o", ""). Object_Path_Switches : Name_List_Index := No_Name_List; -- List of switches to specify to the compiler the path name of a -- temporary file containing the list of object directories in the -- correct order. Compilation_PIC_Option : Name_List_Index := No_Name_List; -- The option(s) to compile a source in Position Independent Code for -- shared libraries. Specified in the configuration. When not specified, -- there is no need for such switch. Object_Generated : Boolean := True; -- False if no object file is generated Objects_Linked : Boolean := True; -- False if object files are not use to link executables and build -- libraries. Runtime_Dir : Name_Id := No_Name; -- Path name of the runtime directory, if any Runtime_Library_Dirs : Name_List_Index := No_Name_List; -- Path names of the runtime library directories, if any Runtime_Source_Dirs : Name_List_Index := No_Name_List; -- Path names of the runtime source directories, if any Runtime_Library_Version : Name_Id := No_Name; -- Value of the library version Mapping_File_Switches : Name_List_Index := No_Name_List; -- The option(s) to provide a mapping file to the compiler. Specified in -- the configuration. When value is No_Name_List, there is no mapping -- file. Mapping_Spec_Suffix : File_Name_Type := No_File; -- Placeholder representing the spec suffix in a mapping file Mapping_Body_Suffix : File_Name_Type := No_File; -- Placeholder representing the body suffix in a mapping file Config_File_Switches : Name_List_Index := No_Name_List; -- The option(s) to provide a config file to the compiler. Specified in -- the configuration. If value is No_Name_List there is no config file. Dependency_Kind : Dependency_File_Kind := None; -- The kind of dependency to be checked: none, Makefile fragment or -- ALI file (for Ada). Dependency_Option : Name_List_Index := No_Name_List; -- The option(s) to be used to create the dependency file. When value is -- No_Name_List, there is not such option(s). Compute_Dependency : Name_List_Index := No_Name_List; -- Hold the value of attribute Dependency_Driver, if declared for the -- language. Include_Option : Name_List_Index := No_Name_List; -- Hold the value of attribute Include_Switches, if declared for the -- language. Include_Path : Name_Id := No_Name; -- Name of environment variable declared by attribute Include_Path for -- the language. Include_Switches_Via_Spec : Name_List_Index := No_Name_List; -- Indicate the name of the underlying compiler and the switch to -- specify an included source directory. -- Used to invoke a GNU compiler with switch -specs, to avoid long -- command lines. Include_Path_File : Name_Id := No_Name; -- Name of environment variable declared by attribute Include_Path_File -- for the language. Only_Dirs_With_Sources : Boolean := False; -- When True, only the directories that contain sources of the language -- are used as included directories when compiling. Objects_Path : Name_Id := No_Name; -- Name of environment variable declared by attribute Objects_Path for -- the language. Objects_Path_File : Name_Id := No_Name; -- Name of environment variable declared by attribute Objects_Path_File -- for the language. Config_Body : Name_Id := No_Name; -- The template for a pragma Source_File_Name(_Project) for a specific -- file name of a body. Config_Body_Index : Name_Id := No_Name; -- The template for a pragma Source_File_Name(_Project) for a specific -- file name of a body in a multi-source file. Config_Body_Pattern : Name_Id := No_Name; -- The template for a pragma Source_File_Name(_Project) for a naming -- body pattern. Config_Spec : Name_Id := No_Name; -- The template for a pragma Source_File_Name(_Project) for a specific -- file name of a spec. Config_Spec_Index : Name_Id := No_Name; -- The template for a pragma Source_File_Name(_Project) for a specific -- file name of a spec in a multi-source file. Config_Spec_Pattern : Name_Id := No_Name; -- The template for a pragma Source_File_Name(_Project) for a naming -- spec pattern. Config_File_Dependency_Support : Boolean := True; -- True if dependency of the source files from config file is supported Config_File_Unique : Boolean := False; -- True if the config file specified to the compiler needs to be unique. -- If it is unique, then all config files are concatenated into a temp -- config file. Binder_Driver : File_Name_Type := No_File; -- The name of the binder driver for the language, if any Binder_Driver_Path : Path_Name_Type := No_Path; -- The path name of the binder driver Binder_Required_Switches : Name_List_Index := No_Name_List; -- Hold the value of attribute Binder'Required_Switches for the language Binder_Prefix : Name_Id := No_Name; -- Hold the value of attribute Binder'Prefix for the language Toolchain_Version : Name_Id := No_Name; -- Hold the value of attribute Toolchain_Version for the language Required_Toolchain_Version : Name_Id := No_Name; -- Hold the value of attribute Required_Toolchain_Version for the -- language. Toolchain_Description : Name_Id := No_Name; -- Hold the value of attribute Toolchain_Description for the language Clean_Object_Artifacts : Name_List_Index := No_Name_List; -- List of object artifact extensions to be deleted by gprclean Clean_Source_Artifacts : Name_List_Index := No_Name_List; -- List of source artifact extensions to be deleted by gprclean Resp_File_Format : Response_File_Format := None; -- The format of a response file, when compiling with a response file is -- supported. Resp_File_Options : Name_List_Index := No_Name_List; -- The switches, if any, that precede the path name of the response -- file in the invocation of the compiler. end record; No_Language_Config : constant Language_Config := (others => <>); type Language_Data is record Name : Name_Id := No_Name; -- The name of the language in lower case Display_Name : Name_Id := No_Name; -- The name of the language, as found in attribute Languages Config : Language_Config := No_Language_Config; -- Configuration of the language First_Source : Source_Id := No_Source; -- Head of the list of sources of the language in the project Mapping_Files : Mapping_Files_Htable.Instance := Mapping_Files_Htable.Nil; -- Hash table containing the mapping of the sources to their path names Unconditional_Linking : Boolean := False; -- All object files of this language should be linked unconditionally Next : Language_Ptr := No_Language_Index; -- Next language of the project end record; No_Language_Data : constant Language_Data := (others => <>); type Language_List_Element; type Language_List is access all Language_List_Element; type Language_List_Element is record Language : Language_Ptr := No_Language_Index; Next : Language_List; end record; type Source_Kind is (Spec, Impl, Sep); subtype Spec_Or_Body is Source_Kind range Spec .. Impl; -- The following declarations declare a structure used to store the Name -- and File and Path names of a unit, with a reference to its GNAT Project -- File(s). Some units might have neither Spec nor Impl when they were -- created for a "separate". type File_Names_Data is array (Spec_Or_Body) of Source_Id; type Unit_Data is record Name : Name_Id := No_Name; File_Names : File_Names_Data; end record; type Unit_Index is access all Unit_Data; No_Unit_Index : constant Unit_Index := null; -- Used to indicate a null entry for no unit type Source_Roots; type Roots_Access is access Source_Roots; type Source_Roots is record Root : Source_Id; Next : Roots_Access; end record; -- A list to store the roots associated with a main unit. These are the -- files that need to linked along with the main (for instance a C file -- corresponding to an Ada file). In general, these are dependencies that -- cannot be computed automatically by the builder. type Naming_Exception_Type is (No, Yes, Inherited); -- Structure to define source data type Source_Data is record Initialized : Boolean := False; -- Set to True when Source_Data is completely initialized Project : Project_Id := No_Project; -- Project of the source Location : Source_Ptr := No_Location; -- Location in the project file of the declaration of the source in -- package Naming. Source_Dir_Rank : Natural := 0; -- The rank of the source directory in list declared with attribute -- Source_Dirs. Two source files with the same name cannot appears in -- different directory with the same rank. That can happen when the -- recursive notation /** is used in attribute Source_Dirs. Language : Language_Ptr := No_Language_Index; -- Language of the source In_Interfaces : Boolean := True; -- False when the source is not included in interfaces, when attribute -- Interfaces is declared. In_Src_Subdir : Boolean := False; -- If source is in the --src-subdir direcory it should be In_Interfaces Declared_In_Interfaces : Boolean := False; -- True when source is declared in attribute Interfaces Alternate_Languages : Language_List := null; -- List of languages a header file may also be, in addition of language -- Language_Name. Kind : Source_Kind := Spec; -- Kind of the source: spec, body or subunit Unit : Unit_Index := No_Unit_Index; -- Name of the unit, if language is unit based. This is only set for -- those files that are part of the compilation set (for instance a -- file in an extended project that is overridden will not have this -- field set). Index : Int := 0; -- Index of the source in a multi unit source file (the same Source_Data -- is duplicated several times when there are several units in the same -- file). Index is 0 if there is either no unit or a single one, and -- starts at 1 when there are multiple units Compilable : Yes_No_Unknown := Unknown; -- Updated at the first call to Is_Compilable. Yes if source file is -- compilable. In_The_Queue : Boolean := False; -- True if the source has been put in the queue Locally_Removed : Boolean := False; -- True if the source has been "excluded" Suppressed : Boolean := False; -- True if the source is a locally removed direct source of the project. -- These sources should not be put in the mapping file. Replaced_By : Source_Id := No_Source; -- Source in an extending project that replaces the current source File : File_Name_Type := No_File; -- Canonical file name of the source Display_File : File_Name_Type := No_File; -- File name of the source, for display purposes Path : Path_Information := No_Path_Information; -- Path name of the source Source_TS : Time_Stamp_Type := Empty_Time_Stamp; -- Time stamp of the source file Checksum : Word := 0; -- Checksum calculated from source file Checksum_Src : File_Name_Type := No_File; -- Source of checksum. -- No_File - No checksum -- First_Name_Id - Calculated from source file -- Other values - From dependency file of source simple name Object_Project : Project_Id := No_Project; -- Project where the object file is. This might be different from -- Project when using extending project files. Object : File_Name_Type := No_File; -- File name of the object file Current_Object_Path : Path_Name_Type := No_Path; -- Object path of an existing object file Object_Path : Path_Name_Type := No_Path; -- Object path of the real object file Object_TS : Time_Stamp_Type := Empty_Time_Stamp; -- Object file time stamp Dep_Name : File_Name_Type := No_File; -- Dependency file simple name Dep_Path : Path_Name_Type := No_Path; -- Path name of the real dependency file Dep_TS : aliased File_Attributes := Unknown_Attributes; -- Dependency file time stamp Switches : File_Name_Type := No_File; -- File name of the switches file. For all languages, this is a file -- that ends with the .cswi extension. Switches_Path : Path_Name_Type := No_Path; -- Path name of the switches file Switches_TS : Time_Stamp_Type := Empty_Time_Stamp; -- Switches file time stamp Naming_Exception : Naming_Exception_Type := No; -- True if the source has an exceptional name Duplicate_Unit : Boolean := False; -- True when a duplicate unit has been reported for this source Next_In_Lang : Source_Id := No_Source; -- Link to another source of the same language in the same project Next_With_File_Name : Source_Id := No_Source; -- Link to another source with the same base file name Roots : Roots_Access := null; -- The roots for a main unit end record; No_Source_Data : constant Source_Data := (Initialized => False, Project => No_Project, Location => No_Location, Source_Dir_Rank => 0, Language => No_Language_Index, In_Interfaces => True, Declared_In_Interfaces => False, In_Src_Subdir => False, Alternate_Languages => null, Kind => Spec, Unit => No_Unit_Index, Index => 0, Locally_Removed => False, Suppressed => False, Compilable => Unknown, In_The_Queue => False, Replaced_By => No_Source, File => No_File, Display_File => No_File, Path => No_Path_Information, Source_TS => Empty_Time_Stamp, Checksum => 0, Checksum_Src => No_File, Object_Project => No_Project, Object => No_File, Current_Object_Path => No_Path, Object_Path => No_Path, Object_TS => Empty_Time_Stamp, Dep_Name => No_File, Dep_Path => No_Path, Dep_TS => Unknown_Attributes, Switches => No_File, Switches_Path => No_Path, Switches_TS => Empty_Time_Stamp, Naming_Exception => No, Duplicate_Unit => False, Next_In_Lang => No_Source, Next_With_File_Name => No_Source, Roots => null); package Source_Files_Htable is new Simple_HTable (Header_Num => Header_Num, Element => Source_Id, No_Element => No_Source, Key => File_Name_Type, Hash => Hash, Equal => "="); -- Mapping of source file names to source ids package Source_Paths_Htable is new Simple_HTable (Header_Num => Header_Num, Element => Source_Id, No_Element => No_Source, Key => Path_Name_Type, Hash => Hash, Equal => "="); -- Mapping of source paths to source ids type Lib_Kind is (Static, Static_Pic, Dynamic, Relocatable); function Image (Kind : Lib_Kind) return String; -- Return image of Lib_kind as used in project files type Policy is (Restricted, Unrestricted); -- Type to specify the symbol policy, when symbol control is supported. -- Restricted: Restrict the symbols to those in the symbol file -- Unrestrictedt: All symbols are exported type Symbol_Record is record Symbol_File : Path_Name_Type := No_Path; Symbol_Policy : Policy := Restricted; end record; -- Type to keep the symbol data to be used when building a shared library No_Symbols : constant Symbol_Record := (Symbol_File => No_Path, Symbol_Policy => Restricted); -- The default value of the symbol data function Image (The_Casing : Casing_Type) return String; -- Similar to 'Image (but avoid use of this attribute in compiler) function Value (Image : String) return Casing_Type; -- Similar to 'Value (but avoid use of this attribute in compiler) -- Raises Constraint_Error if not a Casing_Type image. function Hex_Image (Item : Word; Length : Positive := 8) return String; -- Returns hexadecimal Item representation. -- Result string would be with size Length. -- If Length is not enough for representation, raise Constrant_Error. procedure Hex_Image (Item : Word; Result : out String); -- Write Item hexadecimal representation into Result. Raise -- Constraint_Error if Result length is not enough. -- The following record contains data for a naming scheme function Get_Object_Directory (Project : Project_Id; Including_Libraries : Boolean; Only_If_Ada : Boolean := False) return Path_Name_Type; -- Return the object directory to use for the project. This depends on -- whether we have a library project or a standard project. This function -- might return No_Name when no directory applies. If the project is a -- library project file and Including_Libraries is True then the library -- ALI dir is returned instead of the object dir, except when there is no -- ALI files in the Library ALI dir and the object directory exists. If -- Only_If_Ada is True, then No_Name is returned when the project doesn't -- include any Ada source. procedure Compute_All_Imported_Projects (Root_Project : Project_Id; Tree : Project_Tree_Ref); -- For all projects in the tree, compute the list of the projects imported -- directly or indirectly by project Root_Project. The result is stored in -- Project.All_Imported_Projects for each project function Ultimate_Extending_Project_Of (Proj : Project_Id; Before : Project_Id := No_Project) return Project_Id; -- Returns the ultimate extending project of project Proj. If project Proj -- is not extended, returns Proj. -- If Before is defined, returns last extending project before it. type Project_List_Element; type Project_List is access all Project_List_Element; type Project_List_Element is record Project : Project_Id := No_Project; From_Encapsulated_Lib : Boolean := False; Next : Project_List := null; end record; -- A list of projects procedure Free_List (List : in out Project_List; Free_Project : Boolean); -- Free the list of projects, if Free_Project, each project is also freed type Export_File_Format is (None, Flat, GNU, Def); -- The format of the different exported symbol files type Project_Configuration is record Target : Name_Id := No_Name; -- The target of the configuration, when specified Run_Path_Option : Name_List_Index := No_Name_List; -- The option to use when linking to specify the path where to look for -- libraries. Run_Path_Origin : Name_Id := No_Name; -- Specify the string (such as "$ORIGIN") to indicate paths relative to -- the directory of the executable in the run path option. Library_Install_Name_Option : Name_Id := No_Name; -- When this is not an empty list, this option, followed by the single -- name of the shared library file is used when linking a shared -- library. Separate_Run_Path_Options : Boolean := False; -- True if each directory needs to be specified in a separate run path -- option. Executable_Suffix : Name_Id := No_Name; -- The suffix of executables, when specified in the configuration or in -- package Builder of the main project. When this is not specified, the -- executable suffix is the default for the platform. -- Linking Linker : Path_Name_Type := No_Path; -- Path name of the linker driver. Specified in the configuration or in -- the package Builder of the main project. Map_File_Option : Name_Id := No_Name; -- Option to use when invoking the linker to build a map file Trailing_Linker_Required_Switches : Name_List_Index := No_Name_List; -- The minimum options for the linker driver. Specified in the -- configuration. Linker_Executable_Option : Name_List_Index := No_Name_List; -- The option(s) to indicate the name of the executable in the linker -- command. Specified in the configuration. When not specified, default -- to -o . Linker_Lib_Dir_Option : Name_Id := No_Name; -- The option to specify where to find a library for linking. Specified -- in the configuration. When not specified, defaults to "-L". Linker_Lib_Name_Option : Name_Id := No_Name; -- The option to specify the name of a library for linking. Specified in -- the configuration. When not specified, defaults to "-l". Max_Command_Line_Length : Natural := 0; -- When positive and when Resp_File_Format (see below) is not None, -- if the command line for the invocation of the linker would be greater -- than this value, a response file is used to invoke the linker. -- Also used for compiler supporting response files. Resp_File_Format : Response_File_Format := None; -- The format of a response file, when linking with a response file is -- supported. Resp_File_Options : Name_List_Index := No_Name_List; -- The switches, if any, that precede the path name of the response -- file in the invocation of the linker. -- Libraries Library_Builder : Path_Name_Type := No_Path; -- The executable to build library (specified in the configuration) Lib_Support : Library_Support := None; -- The level of library support. Specified in the configuration. Support -- is none, static libraries only or both static and shared libraries. Lib_Encapsulated_Supported : Boolean := False; -- True when building fully standalone libraries supported on the target Archive_Builder : Name_List_Index := No_Name_List; -- The name of the executable to build archives, with the minimum -- switches. Specified in the configuration. Archive_Builder_Append_Option : Name_List_Index := No_Name_List; -- The options to append object files to an archive Archive_Indexer : Name_List_Index := No_Name_List; -- The name of the executable to index archives, with the minimum -- switches. Specified in the configuration. Archive_Suffix : File_Name_Type := No_File; -- The suffix of archives. Specified in the configuration. When not -- specified, defaults to ".a". Object_Lister : Name_List_Index := No_Name_List; -- The object lister if any defined Object_Lister_Matcher : Name_Id := No_Name; -- Pattern to match symbols out of the object lister output Export_File_Format : GPR.Export_File_Format := GPR.None; -- The format of the expor file Export_File_Switch : Name_Id := No_Name; -- Swicth to pass the export file to the linker Lib_Partial_Linker : Name_List_Index := No_Name_List; -- Shared libraries Shared_Lib_Driver : File_Name_Type := No_File; -- The driver to link shared libraries. Set with attribute Library_GCC. -- Default to gcc. Shared_Lib_Prefix : File_Name_Type := No_File; -- Part of a shared library file name that precedes the name of the -- library. Specified in the configuration. When not specified, defaults -- to "lib". Shared_Lib_Suffix : File_Name_Type := No_File; -- Suffix of shared libraries, after the library name in the shared -- library name. Specified in the configuration. When not specified, -- default to ".so". Shared_Lib_Min_Options : Name_List_Index := No_Name_List; -- The minimum options to use when building a shared library Lib_Version_Options : Name_List_Index := No_Name_List; -- The options to use to specify a library version Symbolic_Link_Supported : Boolean := False; -- True if the platform supports symbolic link files Lib_Maj_Min_Id_Supported : Boolean := False; -- True if platform supports library major and minor options, such as -- libname.so -> libname.so.2 -> libname.so.2.4 Auto_Init_Supported : Boolean := False; -- True if automatic initialisation is supported for shared stand-alone -- libraries. -- Cleaning Artifacts_In_Exec_Dir : Name_List_Index := No_Name_List; -- List of regexp file names to be cleaned in the exec directory of the -- main project. Artifacts_In_Object_Dir : Name_List_Index := No_Name_List; -- List of regexp file names to be cleaned in the object directory of -- all projects. end record; Default_Project_Config : constant Project_Configuration := (Target => No_Name, Run_Path_Option => No_Name_List, Run_Path_Origin => No_Name, Library_Install_Name_Option => No_Name, Separate_Run_Path_Options => False, Executable_Suffix => No_Name, Linker => No_Path, Map_File_Option => No_Name, Trailing_Linker_Required_Switches => No_Name_List, Linker_Executable_Option => No_Name_List, Linker_Lib_Dir_Option => No_Name, Linker_Lib_Name_Option => No_Name, Library_Builder => No_Path, Max_Command_Line_Length => 0, Resp_File_Format => None, Resp_File_Options => No_Name_List, Lib_Support => None, Lib_Encapsulated_Supported => False, Archive_Builder => No_Name_List, Archive_Builder_Append_Option => No_Name_List, Archive_Indexer => No_Name_List, Archive_Suffix => No_File, Object_Lister => No_Name_List, Object_Lister_Matcher => No_Name, Export_File_Format => GPR.None, Export_File_Switch => No_Name, Lib_Partial_Linker => No_Name_List, Shared_Lib_Driver => No_File, Shared_Lib_Prefix => No_File, Shared_Lib_Suffix => No_File, Shared_Lib_Min_Options => No_Name_List, Lib_Version_Options => No_Name_List, Symbolic_Link_Supported => False, Lib_Maj_Min_Id_Supported => False, Auto_Init_Supported => False, Artifacts_In_Exec_Dir => No_Name_List, Artifacts_In_Object_Dir => No_Name_List); ------------------------- -- Aggregated projects -- ------------------------- type Project_Node_Kind is (N_Project, N_With_Clause, N_Project_Declaration, N_Declarative_Item, N_Package_Declaration, N_String_Type_Declaration, N_Literal_String, N_Attribute_Declaration, N_Typed_Variable_Declaration, N_Variable_Declaration, N_Expression, N_Term, N_Literal_String_List, N_Variable_Reference, N_External_Value, N_Attribute_Reference, N_Split, N_Case_Construction, N_Case_Item, N_Comment_Zones, N_Comment); -- Each node in the tree is of a Project_Node_Kind. For the signification -- of the fields in each node of Project_Node_Kind, look at package -- Tree_Private_Part. subtype Variable_Node_Id is Project_Node_Id; -- Used to designate a node whose expected kind is one of -- N_Typed_Variable_Declaration, N_Variable_Declaration or -- N_Variable_Reference. subtype Package_Declaration_Id is Project_Node_Id; -- Used to designate a node whose expected kind is N_Project_Declaration Packages_Initial : constant := 10; Packages_Increment : constant := 100; Package_Node_Low_Bound : constant := 0; Package_Node_High_Bound : constant := 099_999_999; type Pkg_Node_Id is range Package_Node_Low_Bound .. Package_Node_High_Bound; -- Index type for table Package_Attributes in the body type Package_Node_Id is record Value : Pkg_Node_Id := Package_Node_Low_Bound; end record; -- Full declaration of self-initialized private type Empty_Pkg : constant Pkg_Node_Id := Package_Node_Low_Bound; Empty_Package : constant Package_Node_Id := (Value => Empty_Pkg); Unknown_Pkg : constant Pkg_Node_Id := Package_Node_High_Bound; Unknown_Package : constant Package_Node_Id := (Value => Unknown_Pkg); ------------------- -- Miscellaneous -- ------------------- procedure Add_To_Path (Directory : String; Append : Boolean := False; Variable : String := "PATH"); -- Add a directory to the path environment variable (by default "PATH"). -- If the variable is not defined or if its value is the empty string, set -- the value of the variable to Directory; -- Otherwise update the variable with Directory either in the front or in -- the back, depending on the value of parameter Append, using a -- Path_Separator after or before Directory. ------------------------------- -- Restricted Access Section -- ------------------------------- package Tree_Private_Part is -- This is conceptually in the private part. However, for efficiency, -- some packages are accessing it directly. type Project_Node_Record is record Kind : Project_Node_Kind; Qualifier : Project_Qualifier := Unspecified; Location : Source_Ptr := No_Location; Directory : Path_Name_Type := No_Path; -- Only for N_Project Display_Name : Name_Id := No_Name; -- Only for N_Project Expr_Kind : Variable_Kind := Undefined; -- See below for what Project_Node_Kind it is used Variables : Variable_Node_Id := Empty_Project_Node; -- First variable in a project or a package Packages : Package_Declaration_Id := Empty_Project_Node; -- First package declaration in a project Pkg_Id : Package_Node_Id := Empty_Package; -- Only used for N_Package_Declaration -- -- The component Pkg_Id is an entry into the table Package_Attributes -- (in Prj.Attr). It is used to indicate all the attributes of the -- package with their characteristics. -- -- The tables Prj.Attr.Attributes and Prj.Attr.Package_Attributes -- are built once and for all through a call (from Prj.Initialize) -- to procedure Prj.Attr.Initialize. It is never modified after that. Name : Name_Id := No_Name; -- See below for what Project_Node_Kind it is used Src_Index : Int := 0; -- Index of a unit in a multi-unit source. -- Only for some N_Attribute_Declaration and N_Literal_String. Path_Name : Path_Name_Type := No_Path; -- See below for what Project_Node_Kind it is used Value : Name_Id := No_Name; -- See below for what Project_Node_Kind it is used Default : Attribute_Default_Value := Empty_Value; -- Only used in N_Attribute_Reference Field1 : Project_Node_Id := Empty_Project_Node; -- See below the meaning for each Project_Node_Kind Field2 : Project_Node_Id := Empty_Project_Node; -- See below the meaning for each Project_Node_Kind Field3 : Project_Node_Id := Empty_Project_Node; -- See below the meaning for each Project_Node_Kind Field4 : Project_Node_Id := Empty_Project_Node; -- See below the meaning for each Project_Node_Kind Flag1 : Boolean := False; -- This flag is significant only for: -- -- N_Attribute_Declaration and N_Attribute_Reference -- Indicates for an associative array attribute, that the -- index is case insensitive. -- -- N_Comment -- Indicates that the comment is preceded by an empty line. -- -- N_Project -- Indicates that there are comments in the project source that -- cannot be kept in the tree. -- -- N_Project_Declaration -- Indicates that there are unkept comments in the project. -- -- N_With_Clause -- Indicates that this is not the last with in a with clause. -- Set for "A", but not for "B" in with "B"; and with "A", "B"; Flag2 : Boolean := False; -- This flag is significant only for: -- -- N_Attribute_Declaration and N_Attribute_Reference -- Indicates if attribute values are concatenated with the value -- in the configuration project for the same attribute. -- -- N_Project -- Indicates that the project "extends all" another project. -- -- N_Comment -- Indicates that the comment is followed by an empty line. -- -- N_With_Clause -- Indicates that the originally imported project is an extending -- all project. Comments : Project_Node_Id := Empty_Project_Node; -- For nodes other that N_Comment_Zones or N_Comment, designates the -- comment zones associated with the node. -- -- For N_Comment_Zones, designates the comment after the "end" of -- the construct. -- -- For N_Comment, designates the next comment, if any. Checksum : Word := 0; -- Checksum taken from parser end record; -- type Project_Node_Kind is -- (N_Project, -- -- Name: project name -- -- Path_Name: project path name -- -- Expr_Kind: Undefined -- -- Field1: first with clause -- -- Field2: project declaration -- -- Field3: first string type -- -- Field4: parent project, if any -- -- Value: extended project path name (if any) -- N_With_Clause, -- -- Name: imported project name -- -- Path_Name: imported project path name -- -- Expr_Kind: Undefined -- -- Field1: project node -- -- Field2: next with clause -- -- Field3: project node or empty if "limited with" -- -- Field4: not used -- -- Value: literal string withed -- N_Project_Declaration, -- -- Name: not used -- -- Path_Name: not used -- -- Expr_Kind: Undefined -- -- Field1: first declarative item -- -- Field2: extended project -- -- Field3: extending project -- -- Field4: not used -- -- Value: not used -- N_Declarative_Item, -- -- Name: not used -- -- Path_Name: not used -- -- Expr_Kind: Undefined -- -- Field1: current item node -- -- Field2: next declarative item -- -- Field3: not used -- -- Field4: not used -- -- Value: not used -- N_Package_Declaration, -- -- Name: package name -- -- Path_Name: not used -- -- Expr_Kind: Undefined -- -- Field1: project of renamed package (if any) -- -- Field2: first declarative item -- -- Field3: next package in project -- -- Field4: not used -- -- Value: not used -- N_String_Type_Declaration, -- -- Name: type name -- -- Path_Name: not used -- -- Expr_Kind: Undefined -- -- Field1: first literal string -- -- Field2: next string type -- -- Field3: project node -- -- Field4: not used -- -- Value: not used -- N_Literal_String, -- -- Name: not used -- -- Path_Name: not used -- -- Expr_Kind: Single -- -- Field1: next literal string -- -- Field2: not used -- -- Field3: not used -- -- Field4: not used -- -- Value: string value -- N_Attribute_Declaration, -- -- Name: attribute name -- -- Path_Name: not used -- -- Expr_Kind: attribute kind -- -- Field1: expression -- -- Field2: project of full associative array -- -- Field3: package of full associative array -- -- Field4: not used -- -- Value: associative array index -- -- (if an associative array element) -- N_Typed_Variable_Declaration, -- -- Name: variable name -- -- Path_Name: not used -- -- Expr_Kind: Single -- -- Field1: expression -- -- Field2: type of variable (N_String_Type_Declaration) -- -- Field3: next variable -- -- Field4: project node -- -- Value: not used -- N_Variable_Declaration, -- -- Name: variable name -- -- Path_Name: not used -- -- Expr_Kind: variable kind -- -- Field1: expression -- -- Field2: not used -- -- Field3 is used for next variable, instead of Field2, -- -- so that it is the same field for -- -- N_Variable_Declaration and -- -- N_Typed_Variable_Declaration -- -- Field3: next variable -- -- Field4: not used -- -- Value: not used -- N_Expression, -- -- Name: not used -- -- Path_Name: not used -- -- Expr_Kind: expression kind -- -- Field1: first term -- -- Field2: next expression in list -- -- Field3: not used -- -- Value: not used -- N_Term, -- -- Name: not used -- -- Path_Name: not used -- -- Expr_Kind: term kind -- -- Field1: current term -- -- Field2: next term in the expression -- -- Field3: not used -- -- Field4: not used -- -- Value: not used -- N_Literal_String_List, -- -- Designates a list of string expressions between brackets -- -- separated by commas. The string expressions are not necessarily -- -- literal strings. -- -- Name: not used -- -- Path_Name: not used -- -- Expr_Kind: List -- -- Field1: first expression -- -- Field2: not used -- -- Field3: not used -- -- Field4: not used -- -- Value: not used -- N_Variable_Reference, -- -- Name: variable name -- -- Path_Name: not used -- -- Expr_Kind: variable kind -- -- Field1: project (if specified) -- -- Field2: package (if specified) -- -- Field3: type of variable (N_String_Type_Declaration), if any -- -- Field4: not used -- -- Value: not used -- N_External_Value, -- -- Name: not used -- -- Path_Name: not used -- -- Expr_Kind: Single -- -- Field1: Name of the external reference (literal string) -- -- Field2: Default (literal string) -- -- Field3: not used -- -- Value: not used -- N_Split, -- -- Name: not used -- -- Path_Name: not used -- -- Expr_Kind: List -- -- Field1: expression to split (single string) -- -- Field2: expression of separator (single string) -- -- Field3: not used -- -- Value: not used -- N_Attribute_Reference, -- -- Name: attribute name -- -- Path_Name: not used -- -- Expr_Kind: attribute kind -- -- Field1: project -- -- Field2: package (if attribute of a package) -- -- Field3: not used -- -- Field4: not used -- -- Value: associative array index -- -- (if an associative array element) -- N_Case_Construction, -- -- Name: not used -- -- Path_Name: not used -- -- Expr_Kind: Undefined -- -- Field1: case variable reference -- -- Field2: first case item -- -- Field3: not used -- -- Field4: not used -- -- Value: not used -- N_Case_Item -- -- Name: not used -- -- Path_Name: not used -- -- Expr_Kind: not used -- -- Field1: first choice (literal string), or Empty_Node -- -- for when others -- -- Field2: first declarative item -- -- Field3: next case item -- -- Field4: not used -- -- Value: not used -- N_Comment_zones -- -- Name: not used -- -- Path_Name: not used -- -- Expr_Kind: not used -- -- Field1: comment before the construct -- -- Field2: comment after the construct -- -- Field3: comment before the "end" of the construct -- -- Value: end of line comment -- -- Field4: not used -- -- Comments: comment after the "end" of the construct -- N_Comment -- -- Name: not used -- -- Path_Name: not used -- -- Expr_Kind: not used -- -- Field1: not used -- -- Field2: not used -- -- Field3: not used -- -- Field4: not used -- -- Value: comment -- -- Flag1: comment is preceded by an empty line -- -- Flag2: comment is followed by an empty line -- -- Comments: next comment package Project_Node_Table is new GNAT.Dynamic_Tables (Table_Component_Type => Project_Node_Record, Table_Index_Type => Project_Node_Id, Table_Low_Bound => First_Project_Node_Id, Table_Initial => Project_Nodes_Initial, Table_Increment => Project_Nodes_Increment); -- Table contains the syntactic tree of project data from project files type Project_Name_And_Node is record Name : Name_Id; -- Name of the project Node : Project_Node_Id; -- Node of the project in table Project_Nodes Resolved_Path : Path_Name_Type; -- Resolved and canonical path of a real project file. -- No_Name in case of virtual projects. Extended : Boolean; -- True when the project is being extended by another project From_Extended : Boolean; -- True when the project is only imported by projects that are -- extended. Proj_Qualifier : Project_Qualifier; -- The project qualifier of the project, if any end record; No_Project_Name_And_Node : constant Project_Name_And_Node := (Name => No_Name, Node => Empty_Project_Node, Resolved_Path => No_Path, Extended => True, From_Extended => False, Proj_Qualifier => Unspecified); package Projects_Htable is new GNAT.Dynamic_HTables.Simple_HTable (Header_Num => Header_Num, Element => Project_Name_And_Node, No_Element => No_Project_Name_And_Node, Key => Name_Id, Hash => Hash, Equal => "="); -- This hash table contains a mapping of project names to project nodes. -- Note that this hash table contains only the nodes whose Kind is -- N_Project. It is used to find the node of a project from its name, -- and to verify if a project has already been parsed, knowing its name. end Tree_Private_Part; type Project_Node_Tree_Data is record Project_Nodes : Tree_Private_Part.Project_Node_Table.Instance; Projects_HT : Tree_Private_Part.Projects_Htable.Instance; Incomplete_With : Boolean := False; -- Set to True if the projects were loaded with the flag -- Ignore_Missing_With set to True, and there were indeed some with -- statements that could not be resolved end record; type Project_Node_Tree_Ref is access all Project_Node_Tree_Data; -- Type to designate a project node tree, so that several project node -- trees can coexist in memory. procedure Free (Proj : in out Project_Node_Tree_Ref); -- Free memory used by Prj type Aggregated_Project; type Aggregated_Project_List is access all Aggregated_Project; type Aggregated_Project is record Path : Path_Name_Type; Tree : Project_Tree_Ref; Node_Tree : Project_Node_Tree_Ref; Project : Project_Id; Next : Aggregated_Project_List; end record; procedure Free (List : in out Aggregated_Project_List); -- Free the memory used for List procedure Add_Aggregated_Project (Project : Project_Id; Path : Path_Name_Type); -- Add a new aggregated project in Project. -- The aggregated project has not been processed yet. This procedure should -- the called while processing the aggregate project, and as a result -- Prj.Proc.Process will then automatically process the aggregated projects ------------------ -- Project_Data -- ------------------ -- The following record describes a project file representation type Standalone is (No, -- The following clash with Standard is OK, and justified by the context -- which really wants to use the same set of qualifiers. Standard, Encapsulated); type Project_Data (Qualifier : Project_Qualifier := Unspecified) is record ------------- -- General -- ------------- Name : Name_Id := No_Name; -- The name of the project Display_Name : Name_Id := No_Name; -- The name of the project with the spelling of its declaration Externally_Built : Boolean := False; -- True if the project is externally built. In such case, the Project -- Manager will not modify anything in this project. Config : Project_Configuration; Path : Path_Information := No_Path_Information; -- The path name of the project file. This include base name of the -- project file. Virtual : Boolean := False; -- True for virtual extending projects Location : Source_Ptr := No_Location; -- The location in the project file source of the project name that -- immediately follows the reserved word "project". --------------- -- Languages -- --------------- Languages : Language_Ptr := No_Language_Index; -- First index of the language data in the project. Traversing the list -- gives access to all the languages supported by the project. -------------- -- Projects -- -------------- Mains : String_List_Id := Nil_String; -- List of mains specified by attribute Main Extends : Project_Id := No_Project; -- The reference of the project file, if any, that this project file -- extends. Extended_By : Project_Id := No_Project; -- The reference of the project file, if any, that extends this project -- file. Decl : Declarations := No_Declarations; -- The declarations (variables, attributes and packages) of this project -- file. Imported_Projects : Project_List := null; -- The list of all directly imported projects, if any All_Imported_Projects : Project_List := null; -- The list of all projects imported directly or indirectly, if any. -- This does not include the project itself. ----------------- -- Directories -- ----------------- Directory : Path_Information := No_Path_Information; -- Path name of the directory where the project file resides Object_Directory : Path_Information := No_Path_Information; -- The path name of the object directory of this project file Exec_Directory : Path_Information := No_Path_Information; -- The path name of the exec directory of this project file. Default is -- equal to Object_Directory. Object_Path_File : Path_Name_Type := No_Path; -- Store the name of the temporary file that contains the list of object -- directories, when attribute Object_Path_Switches is declared. ------------- -- Library -- ------------- Library : Boolean := False; -- True if this is a library project Library_Name : Name_Id := No_Name; -- If a library project, name of the library Library_Kind : Lib_Kind := Static; -- If a library project, kind of library Library_Dir : Path_Information := No_Path_Information; -- If a library project, path name of the directory where the library -- resides. Library_TS : Time_Stamp_Type := Empty_Time_Stamp; -- The timestamp of a library file in a library project Was_Built : Boolean := False; -- The library project has been built in the current gprbuild execution Need_Build : Boolean := False; -- Library project has to be built even if no need any compilation Library_Src_Dir : Path_Information := No_Path_Information; -- If a Stand-Alone Library project, path name of the directory where -- the sources of the interfaces of the library are copied. By default, -- if attribute Library_Src_Dir is not specified, sources of the -- interfaces are not copied anywhere. Library_ALI_Dir : Path_Information := No_Path_Information; -- In a library project, path name of the directory where the ALI files -- are copied. If attribute Library_ALI_Dir is not specified, ALI files -- are copied in the Library_Dir. Lib_Internal_Name : Name_Id := No_Name; -- If a library project, internal name store inside the library Standalone_Library : Standalone := No; -- Indicate that this is a Standalone Library Project File Lib_Interface_ALIs : String_List_Id := Nil_String; -- For Standalone Library Project Files, list of Interface ALI files Other_Interfaces : String_List_Id := Nil_String; -- List of non unit based sources in attribute Interfaces Lib_Auto_Init : Boolean := False; -- For non static Stand-Alone Library Project Files, True if the library -- initialisation should be automatic. Symbol_Data : Symbol_Record := No_Symbols; -- Symbol file name, reference symbol file name, symbol policy ------------- -- Sources -- ------------- -- The sources for all languages including Ada are accessible through -- the Source_Iterator type Interfaces_Defined : Boolean := False; -- True if attribute Interfaces is declared for the project or any -- project it extends. Include_Path_File : Path_Name_Type := No_Path; -- The path name of the of the source search directory file. -- This is only used by gnatmake Source_Dirs : String_List_Id := Nil_String; -- The list of all the source directories Source_Dir_Ranks : Number_List_Index := No_Number_List; Ada_Include_Path : String_Access := null; -- The cached value of source search path for this project file. Set by -- the first call to Prj.Env.Ada_Include_Path for the project. Do not -- use this field directly outside of the project manager, use -- Prj.Env.Ada_Include_Path instead. Has_Multi_Unit_Sources : Boolean := False; -- Whether there is at least one source file containing multiple units ------------------- -- Miscellaneous -- ------------------- Ada_Objects_Path : String_Access := null; -- The cached value of ADA_OBJECTS_PATH for this project file, with -- library ALI directories for library projects instead of object -- directories. Do not use this field directly outside of the -- compiler, use Prj.Env.Ada_Objects_Path instead. Ada_Objects_Path_No_Libs : String_Access := null; -- The cached value of ADA_OBJECTS_PATH for this project file with all -- object directories (no library ALI dir for library projects). Libgnarl_Needed : Yes_No_Unknown := Unknown; -- Set to True when libgnarl is needed to link Objects_Path : String_Access := null; -- The cached value of the object dir path, used during the binding -- phase of gprbuild. Objects_Path_File_With_Libs : Path_Name_Type := No_Path; -- The cached value of the object path temp file (including library -- dirs) for this project file. Objects_Path_File_Without_Libs : Path_Name_Type := No_Path; -- The cached value of the object path temp file (excluding library -- dirs) for this project file. Config_File_Name : Path_Name_Type := No_Path; -- The path name of the configuration pragmas file, if any Config_File_Temp : Boolean := False; -- True if the configuration pragmas file is a temporary file that must -- be deleted at the end. Config_Checked : Boolean := False; -- A flag to avoid checking repetitively the configuration pragmas file Depth : Natural := 0; -- The maximum depth of a project in the project graph. Depth of main -- project is 0. Unkept_Comments : Boolean := False; -- True if there are comments in the project sources that cannot be kept -- in the project tree. Checksum : Word := 0; -- Checksum of the project taken from parser ----------------------------- -- Qualifier-Specific data -- ----------------------------- -- The following fields are only valid for specific types of projects case Qualifier is when Aggregate | Aggregate_Library => Aggregated_Projects : Aggregated_Project_List := null; -- List of aggregated projects (which could themselves be -- aggregate projects). when others => null; end case; end record; function Empty_Project (Qualifier : Project_Qualifier) return Project_Data; -- Return the representation of an empty project function Is_Extending (Extending : Project_Id; Extended : Project_Id) return Boolean; -- Return True if Extending is extending the Extended project function Is_Ext (Extending : Project_Id; Extended : Project_Id) return Boolean renames Is_Extending; function Has_Ada_Sources (Data : Project_Id) return Boolean; -- Return True if the project has Ada sources Project_Error : exception; -- Raised by some subprograms in Prj.Attr package Units_Htable is new Simple_HTable (Header_Num => Header_Num, Element => Unit_Index, No_Element => No_Unit_Index, Key => Name_Id, Hash => Hash, Equal => "="); -- Mapping of unit names to indexes in the Units table --------------------- -- Source_Iterator -- --------------------- type Source_Iterator is private; function For_Each_Source (In_Tree : Project_Tree_Ref; Project : Project_Id := No_Project; Language : Name_Id := No_Name; Encapsulated_Libs : Boolean := True; Locally_Removed : Boolean := True) return Source_Iterator; -- Returns an iterator for all the sources of a project tree, or a specific -- project, or a specific language. Include sources from encapsulated -- stand-alone libs if Encapsulated_Libs is True. If Locally_Removed is set -- to False the Locally_Removed files won't be reported. function Element (Iter : Source_Iterator) return Source_Id; -- Return the current source (or No_Source if there are no more sources) procedure Next (Iter : in out Source_Iterator); -- Move on to the next source function Find_Source (In_Tree : Project_Tree_Ref; Project : Project_Id; In_Imported_Only : Boolean := False; In_Extended_Only : Boolean := False; Base_Name : File_Name_Type; Index : Int := 0) return Source_Id; -- Find the first source file with the given name. -- If In_Extended_Only is True, it will search in project and the project -- it extends, but not in the imported projects. -- Elsif In_Imported_Only is True, it will search in project and the -- projects it imports, but not in the others or in aggregated projects. -- Else it searches in the whole tree. -- If Index is specified, this only search for a source with that index. type Source_Ids is array (Positive range <>) of Source_Id; No_Sources : constant Source_Ids := (1 .. 0 => No_Source); function Find_All_Sources (In_Tree : Project_Tree_Ref; Project : Project_Id; In_Imported_Only : Boolean := False; In_Extended_Only : Boolean := False; Base_Name : File_Name_Type; Index : Int := 0) return Source_Ids; -- Find all source files with the given name: -- -- If In_Extended_Only is True, it will search in project and the project -- it extends, but not in the imported projects. -- -- If Extended_Only is False, and In_Imported_Only is True, it will -- search in project and the projects it imports, but not in the others -- or in aggregated projects. -- -- If both Extended_Only and In_Imported_Only are False (the default) -- then it searches the whole tree. -- -- If Index is specified, this only search for sources with that index. ----------------------- -- Project_Tree_Data -- ----------------------- package Replaced_Source_HTable is new Simple_HTable (Header_Num => Header_Num, Element => File_Name_Type, No_Element => No_File, Key => File_Name_Type, Hash => Hash, Equal => "="); type Private_Project_Tree_Data is private; -- Data for a project tree that is used only by the Project Manager type Shared_Project_Tree_Data is record Name_Lists : Name_List_Table.Instance; Number_Lists : Number_List_Table.Instance; String_Elements : String_Element_Table.Instance; Variable_Elements : Variable_Element_Table.Instance; Array_Elements : Array_Element_Table.Instance; Arrays : Array_Table.Instance; Packages : Package_Table.Instance; Private_Part : Private_Project_Tree_Data; Dot_String_List : String_List_Id := Nil_String; Ada_Runtime_Dir : Name_Id := No_Name; Ada_Runtime_Source_Dirs : Name_List_Index := No_Name_List; Ada_Runtime_Library_Dirs : Name_List_Index := No_Name_List; Ada_Runtime_Library_Version : Name_Id := No_Name; end record; type Shared_Project_Tree_Data_Access is access all Shared_Project_Tree_Data; -- The data that is shared among multiple trees, when these trees are -- loaded through the same aggregate project. -- To avoid ambiguities, limit the number of parameters to the -- subprograms (we would have to parse the "root project tree" since this -- is where the configuration file was loaded, in addition to the project's -- own tree) and make the comparison of projects easier, all trees store -- the lists in the same tables. type Project_Tree_Appdata is tagged null record; type Project_Tree_Appdata_Access is access all Project_Tree_Appdata'Class; -- Application-specific data that can be associated with a project tree. -- We do not make the Project_Tree_Data itself tagged for several reasons: -- - it couldn't have a default value for its discriminant -- - it would require a "factory" to allocate such data, because trees -- are created automatically when parsing aggregate projects. procedure Free (Tree : in out Project_Tree_Appdata); -- Should be overridden if your derive your own data type Project_Tree_Data (Is_Root_Tree : Boolean := True) is record -- The root tree is the one loaded by the user from the command line. -- Is_Root_Tree is only false for projects aggregated within a root -- aggregate project. Projects : Project_List; -- List of projects in this tree Replaced_Sources : Replaced_Source_HTable.Instance; -- The list of sources that have been replaced by sources with -- different file names. Replaced_Source_Number : Natural := 0; -- The number of entries in Replaced_Sources Units_HT : Units_Htable.Instance; -- Unit name to Unit_Index (and from there to Source_Id) Source_Files_HT : Source_Files_Htable.Instance; -- Base source file names to Source_Id list Source_Paths_HT : Source_Paths_Htable.Instance; -- Full path to Source_Id -- ??? What is behavior for multi-unit source files, where there are -- several source_id per file ? Source_Info_File_Name : String_Access := null; -- The name of the source info file, if specified by the builder Source_Info_File_Exists : Boolean := False; -- True when a source info file has been successfully read Shared : Shared_Project_Tree_Data_Access; -- The shared data for this tree and all aggregated trees Appdata : Project_Tree_Appdata_Access; -- Application-specific data for this tree case Is_Root_Tree is when True => Shared_Data : aliased Shared_Project_Tree_Data; -- Do not access directly, only through Shared when False => null; end case; end record; -- Data for a project tree function Debug_Name (Tree : Project_Tree_Ref) return Name_Id; -- If debug traces are activated, return an identitier for the project -- tree. This modifies Name_Buffer. procedure Initialize (Tree : Project_Tree_Ref); -- This procedure must be called before using any services from the Prj -- hierarchy. Namet.Initialize must be called before Prj.Initialize. procedure Reset (Tree : Project_Tree_Ref); -- This procedure resets all the tables that are used when processing a -- project file tree. Initialize must be called before the call to Reset. package Project_Boolean_Htable is new Simple_HTable (Header_Num => Header_Num, Element => Boolean, No_Element => False, Key => Project_Id, Hash => Hash, Equal => "="); -- A table that associates a project to a boolean. This is used to detect -- whether a project was already processed for instance. generic with procedure Action (Project : Project_Id; Tree : Project_Tree_Ref); procedure For_Project_And_Aggregated (Root_Project : Project_Id; Root_Tree : Project_Tree_Ref); -- Execute Action for Root_Project and all its aggregated projects -- recursively. generic type State is limited private; with procedure Action (Project : Project_Id; Tree : Project_Tree_Ref; With_State : in out State); procedure For_Every_Project_Imported (By : Project_Id; Tree : Project_Tree_Ref; With_State : in out State; Include_Aggregated : Boolean := True; Imported_First : Boolean := False); -- Call Action for each project imported directly or indirectly by project -- By, as well as extended projects. -- -- The order of processing depends on Imported_First: -- -- If False, Action is called according to the order of importation: if A -- imports B, directly or indirectly, Action will be called for A before -- it is called for B. If two projects import each other directly or -- indirectly (using at least one "limited with"), it is not specified -- for which of these two projects Action will be called first. -- -- The order is reversed if Imported_First is True -- -- With_State may be used by Action to choose a behavior or to report some -- global result. -- -- If Include_Aggregated is True, then an aggregate project will recurse -- into the projects it aggregates. Otherwise, the latter are never -- returned. -- -- In_Aggregate_Lib is True if the project is in an aggregate library -- -- The Tree argument passed to the callback is required in the case of -- aggregated projects, since they might not be using the same tree as 'By' type Project_Context is record In_Aggregate_Lib : Boolean; -- True if the project is part of an aggregate library From_Encapsulated_Lib : Boolean; -- True if the project is imported from an encapsulated library end record; generic type State is limited private; with procedure Action (Project : Project_Id; Tree : Project_Tree_Ref; Context : Project_Context; With_State : in out State); procedure For_Every_Project_Imported_Context (By : Project_Id; Tree : Project_Tree_Ref; With_State : in out State; Include_Aggregated : Boolean := True; Imported_First : Boolean := False); -- As for For_Every_Project_Imported but with an associated context generic with procedure Action (Project : Project_Id; Tree : Project_Tree_Ref; Context : Project_Context); procedure For_Project_And_Aggregated_Context (Root_Project : Project_Id; Root_Tree : Project_Tree_Ref); -- As for For_Project_And_Aggregated but with an associated context function Extend_Name (File : File_Name_Type; With_Suffix : String) return File_Name_Type; -- Replace the extension of File with With_Suffix function Object_Name (Source_File_Name : File_Name_Type; Object_File_Suffix : Name_Id := No_Name) return File_Name_Type; -- Returns the object file name corresponding to a source file name function Object_Name (Source_File_Name : File_Name_Type; Source_Index : Int; Index_Separator : Character; Object_File_Suffix : Name_Id := No_Name) return File_Name_Type; -- Returns the object file name corresponding to a unit in a multi-source -- file. function Dependency_Name (Source_File_Name : File_Name_Type; Dependency : Dependency_File_Kind) return File_Name_Type; -- Returns the dependency file name corresponding to a source file name function Switches_Name (Source_File_Name : File_Name_Type) return File_Name_Type; -- Returns the switches file name corresponding to a source file name procedure Set_Path_File_Var (Name : String; Value : String); -- Call Setenv, after calling To_Host_File_Spec function Current_Source_Path_File_Of (Shared : Shared_Project_Tree_Data_Access) return Path_Name_Type; -- Get the current include path file name procedure Set_Current_Source_Path_File_Of (Shared : Shared_Project_Tree_Data_Access; To : Path_Name_Type); -- Record the current include path file name function Current_Object_Path_File_Of (Shared : Shared_Project_Tree_Data_Access) return Path_Name_Type; -- Get the current object path file name procedure Set_Current_Object_Path_File_Of (Shared : Shared_Project_Tree_Data_Access; To : Path_Name_Type); -- Record the current object path file name ----------- -- Flags -- ----------- type Processing_Flags is private; -- Flags used while parsing and processing a project tree to configure the -- behavior of the parser, and indicate how to report error messages. This -- structure does not allocate memory and never needs to be freed type Error_Warning is (Silent, Warning, Error, Decide_Later); -- Severity of some situations, such as: no Ada sources in a project where -- Ada is one of the language. -- -- When the situation occurs, the behaviour depends on the setting: -- -- - Silent: no action -- - Warning: issue a warning, does not cause the tool to fail -- - Error: issue an error, causes the tool to fail -- - Decide_Later: keep the message until call to Messages_Decision subtype Decided_Message is Error_Warning range Error_Warning'First .. Error; type Error_Handler is access procedure (Project : Project_Id; Is_Warning : Boolean); -- This warns when an error was found when parsing a project. The error -- itself is handled through Prj.Err (and Prj.Err.Finalize should be called -- to actually print the error). This ensures that duplicate error messages -- are always correctly removed, that errors msgs are sorted, and that all -- tools will report the same error to the user. function Create_Flags (Report_Error : Error_Handler; When_No_Sources : Error_Warning; Require_Sources_Other_Lang : Boolean := True; Allow_Duplicate_Basenames : Boolean := True; Compiler_Driver_Mandatory : Boolean := False; Error_On_Unknown_Language : Boolean := True; Require_Obj_Dirs : Error_Warning := Error; Allow_Invalid_External : Error_Warning := Error; Missing_Project_Files : Error_Warning := Error; Missing_Source_Files : Error_Warning := Error; Ignore_Missing_With : Boolean := False; Check_Configuration_Only : Boolean := False) return Processing_Flags; -- Function used to create Processing_Flags structure -- -- If Allow_Duplicate_Basenames, then files with the same base names are -- authorized within a project for source-based languages (never for unit -- based languages). -- -- If Compiler_Driver_Mandatory is true, then a Compiler.Driver attribute -- for each language must be defined, or we will not look for its source -- files. -- -- When_No_Sources indicates what should be done when no sources of a -- language are found in a project where this language is declared. -- If Require_Sources_Other_Lang is true, then all languages must have at -- least one source file, or an error is reported via When_No_Sources. If -- it is false, this is only required for Ada (and only if it is a language -- of the project). When this parameter is set to False, we do not check -- that a proper naming scheme is defined for languages other than Ada. -- -- If Report_Error is null, use the standard error reporting mechanism -- (Errout). Otherwise, report errors using Report_Error. -- -- If Error_On_Unknown_Language is true, an error is displayed if some of -- the source files listed in the project do not match any naming scheme -- -- If Require_Obj_Dirs is true, then all object directories must exist -- (possibly after they have been created automatically if the appropriate -- switches were specified), or an error is raised. -- -- If Allow_Invalid_External is Silent, then no error is reported when an -- invalid value is used for an external variable (and it doesn't match its -- type). Instead, the first possible value is used. -- -- Missing_Source_Files indicates whether it is an error or a warning that -- a source file mentioned in the Source_Files attributes is not actually -- found in the source directories. This also impacts errors for missing -- source directories. -- -- If Ignore_Missing_With is True, then a "with" statement that cannot be -- resolved will simply be ignored. However, in such a case, the flag -- Incomplete_With in the project tree will be set to True. -- This is meant for use by tools so that they can properly set the -- project path in such a case: -- * no "gnatls" found (so no default project path) -- * user project sets Project.IDE'gnatls attribute to a cross gnatls -- * user project also includes a "with" that can only be resolved -- once we have found the gnatls procedure Set_Ignore_Missing_With (Flags : in out Processing_Flags; Value : Boolean); -- Set the value of component Ignore_Missing_With in Flags to Value procedure Set_Require_Obj_Dirs (Flags : in out Processing_Flags; Value : Error_Warning); -- Set the value of component Require_Object_Dirs in Flags to Value procedure Set_Check_Configuration_Only (Flags : in out Processing_Flags; Value : Boolean); -- Set the value of component Check_Configuration_Only in Flags to Value procedure Set_Missing_Source_Files (Flags : in out Processing_Flags; Value : Error_Warning); -- Set the value of component Missing_Source_Files in Flags to Value Gprbuild_Flags : constant Processing_Flags; Gprinstall_Flags : constant Processing_Flags; Gprclean_Flags : constant Processing_Flags; Gprname_Flags : constant Processing_Flags; Gprls_Flags : constant Processing_Flags; -- Flags used by the various tools. They all display the error messages -- through Prj.Err. ---------------- -- Temp Files -- ---------------- procedure Record_Temp_File (Shared : Shared_Project_Tree_Data_Access; Path : Path_Name_Type); -- Record the path of a newly created temporary file, so that it can be -- deleted later. procedure Delete_All_Temp_Files (Shared : Shared_Project_Tree_Data_Access); -- Delete all recorded temporary files. -- Does nothing if Debug.Debug_Flag_N is set procedure Delete_Temporary_File (Shared : Shared_Project_Tree_Data_Access := null; Path : Path_Name_Type); procedure Delete_Temporary_File (Shared : Shared_Project_Tree_Data_Access := null; Path : String); -- Delete a temporary file from the disk. The file is also removed from the -- list of temporary files to delete at the end of the program, in case -- another program running on the same machine has recreated it. Does -- nothing if Debug.Debug_Flag_N is set Virtual_Prefix : constant String := "v$"; -- The prefix for virtual extending projects. Because of the '$', which is -- normally forbidden for project names, there cannot be any name clash. ----------- -- Debug -- ----------- type Verbosity is (Default, Medium, High); pragma Ordered (Verbosity); -- Verbosity when parsing GNAT Project Files -- Default is default (very quiet, if no errors). -- Medium is more verbose. -- High is extremely verbose. Current_Verbosity : Verbosity := Default; -- The current value of the verbosity the project files are parsed with procedure Debug_Indent; -- Inserts a series of blanks depending on the current indentation level procedure Debug_Output (Str : String); procedure Debug_Output (Str : String; Str2 : Name_Id); -- If Current_Verbosity is not Default, outputs Str. -- This indents Str based on the current indentation level for traces -- Debug_Error is intended to be used to report an error in the traces. procedure Debug_Increase_Indent (Str : String := ""; Str2 : Name_Id := No_Name); procedure Debug_Decrease_Indent (Str : String := ""); -- Increase or decrease the indentation level for debug traces. This -- indentation level only affects output done through Debug_Output. Total_Errors_Detected : Nat := 0; Warnings_Detected : Nat := 0; Native_Target : Boolean := False; -- True when no target is specified on the command line or in the main -- project. function To_Hash (Item : Name_Id) return Ada.Containers.Hash_Type; package Name_Id_Maps is new Ada.Containers.Hashed_Maps (Key_Type => Name_Id, Element_Type => Name_Id, Hash => To_Hash, Equivalent_Keys => "="); package Language_Maps renames Name_Id_Maps; -- Hash table to keep the languages and its required versions used in -- the project tree. package Path_Name_HTable is new GNAT.Dynamic_HTables.Simple_HTable (Header_Num => Header_Num, Element => Boolean, No_Element => False, Key => Path_Name_Type, Hash => Hash, Equal => "="); Shared_Libgcc_Default : Character with Import, Convention => C, Size => Character'Size, External_Name => "__gnat_shared_libgcc_default"; private function To_Hash (Item : Name_Id) return Ada.Containers.Hash_Type is (Ada.Containers.Hash_Type (Item)); Tool_Name : String_Access := null; Serious_Errors_Detected : Nat := 0; Warnings_Treated_As_Errors : Nat := 0; Info_Messages : Nat := 0; Gprls_Mode : Boolean := False; -- When True, an ALI file may be found in an extending project, even if -- the corresponding object file is not found in the same project. -- This is only for gprls. All_Packages : constant String_List_Access := null; No_Project_Tree : constant Project_Tree_Ref := null; Ignored : constant Variable_Kind := Single; Nil_Variable_Value : constant Variable_Value := (Project => No_Project, Kind => Undefined, Location => No_Location, Default => False, String_Type => Empty_Project_Node, From_Implicit_Target => False); type Source_Iterator is record In_Tree : Project_Tree_Ref; Project : Project_List; All_Projects : Boolean; -- Current project and whether we should move on to the next Language : Language_Ptr; -- Current language processed Language_Name : Name_Id; -- Only sources of this language will be returned (or all if No_Name) Current : Source_Id; Encapsulated_Libs : Boolean; -- True if we want to include the sources from encapsulated libs Locally_Removed : Boolean; end record; procedure Add_To_Buffer (S : String; To : in out String_Access; Last : in out Natural); -- Append a String to the Buffer -- Table used to store the path name of all the created temporary files, so -- that they can be deleted at the end, or when the program is interrupted. function Distance (L, R : String) return Natural; -- Damerau Levenshtein distance between L and R strings. -- Calculated in minimum number of elementary operations to convert one -- string to another. The operations are deletion, insertion, substitution, -- and transposition (swap 2 adjacent characters). package Temp_Files_Table is new GNAT.Dynamic_Tables (Table_Component_Type => Path_Name_Type, Table_Index_Type => Integer, Table_Low_Bound => 1, Table_Initial => 10, Table_Increment => 10); -- The following type is used to represent the part of a project tree which -- is private to the Project Manager. type Private_Project_Tree_Data is record Temp_Files : Temp_Files_Table.Instance; -- Temporary files created as part of running tools (pragma files, -- mapping files,...) Current_Source_Path_File : Path_Name_Type := No_Path; -- Current value of project source path file env var. Used to avoid -- setting the env var to the same value. When different from No_Path, -- this indicates that environment variables were created and should be -- deassigned to avoid polluting the environment. For gnatmake only. Current_Object_Path_File : Path_Name_Type := No_Path; -- Current value of project object path file env var. Used to avoid -- setting the env var to the same value. -- gnatmake only end record; Executable_Extension_On_Target : Name_Id := No_Name; -- The following type is used to hold processing flags which show what -- functions are required for the various tools that are handled. type Processing_Flags is record Require_Sources_Other_Lang : Boolean; Report_Error : Error_Handler; When_No_Sources : Error_Warning; Allow_Duplicate_Basenames : Boolean; Compiler_Driver_Mandatory : Boolean; Error_On_Unknown_Language : Boolean; Require_Obj_Dirs : Error_Warning; Allow_Invalid_External : Error_Warning; Missing_Project_Files : Error_Warning; Missing_Source_Files : Error_Warning; Ignore_Missing_With : Boolean; Check_Configuration_Only : Boolean; Incomplete_Withs : Boolean := False; -- This flag is set to True when the projects are parsed while ignoring -- missing withed project and some withed projects are not found. end record; Gprbuild_Flags : constant Processing_Flags := (Report_Error => null, When_No_Sources => Warning, Require_Sources_Other_Lang => True, Allow_Duplicate_Basenames => False, Compiler_Driver_Mandatory => True, Error_On_Unknown_Language => True, Require_Obj_Dirs => Error, Allow_Invalid_External => Error, Missing_Project_Files => Error, Missing_Source_Files => Error, Ignore_Missing_With => False, Incomplete_Withs => False, Check_Configuration_Only => False); Gprinstall_Flags : constant Processing_Flags := (Report_Error => null, When_No_Sources => Warning, Require_Sources_Other_Lang => True, Allow_Duplicate_Basenames => False, Compiler_Driver_Mandatory => True, Error_On_Unknown_Language => True, Require_Obj_Dirs => Silent, Allow_Invalid_External => Error, Missing_Project_Files => Error, Missing_Source_Files => Error, Ignore_Missing_With => False, Incomplete_Withs => False, Check_Configuration_Only => False); Gprclean_Flags : constant Processing_Flags := (Report_Error => null, When_No_Sources => Warning, Require_Sources_Other_Lang => True, Allow_Duplicate_Basenames => False, Compiler_Driver_Mandatory => True, Error_On_Unknown_Language => True, Require_Obj_Dirs => Warning, Allow_Invalid_External => Error, Missing_Project_Files => Error, Missing_Source_Files => Error, Ignore_Missing_With => False, Incomplete_Withs => False, Check_Configuration_Only => False); Gprname_Flags : constant Processing_Flags := (Report_Error => null, When_No_Sources => Warning, Require_Sources_Other_Lang => True, Allow_Duplicate_Basenames => False, Compiler_Driver_Mandatory => True, Error_On_Unknown_Language => True, Require_Obj_Dirs => Error, Allow_Invalid_External => Error, Missing_Project_Files => Error, Missing_Source_Files => Error, Ignore_Missing_With => False, Incomplete_Withs => False, Check_Configuration_Only => True); Gprls_Flags : constant Processing_Flags := (Report_Error => null, When_No_Sources => Warning, Require_Sources_Other_Lang => True, Allow_Duplicate_Basenames => False, Compiler_Driver_Mandatory => True, Error_On_Unknown_Language => True, Require_Obj_Dirs => Error, Allow_Invalid_External => Error, Missing_Project_Files => Error, Missing_Source_Files => Error, Ignore_Missing_With => False, Incomplete_Withs => False, Check_Configuration_Only => False); end GPR; gprbuild-25.0.0/gpr/src/gpr_build_util.adb000066400000000000000000002756761470075373400205020ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2004-2021, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; use Ada.Text_IO; with Ada.Unchecked_Deallocation; with Ada.Strings.Fixed; use Ada.Strings.Fixed; with Ada.Containers.Indefinite_Vectors; with Ada.Environment_Variables; with GNAT.Case_Util; use GNAT.Case_Util; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.HTable; with GNAT.Regexp; use GNAT.Regexp; with GPR.Opt; use GPR.Opt; with GPR.Osint; use GPR.Osint; with GPR.Com; with GPR.Debug; with GPR.Err; use GPR.Err; with GPR.Erroutc; use GPR.Erroutc; with GPR.Ext; with GPR.Names; use GPR.Names; with GPR.Output; use GPR.Output; with GPR.Tempdir; package body Gpr_Build_Util is use ALI; function File_Not_A_Source_Of (Project_Tree : Project_Tree_Ref; Uname : Name_Id; Sfile : File_Name_Type) return Boolean; -- Check that file name Sfile is one of the source of unit Uname. Returns -- True if the unit is in one of the project file, but the file name is not -- one of its source. Returns False otherwise. procedure Verbose_Msg (N1 : Name_Id; S1 : String; N2 : Name_Id := No_Name; S2 : String := ""; Prefix : String := " -> "; Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low); -- If the verbose flag (Verbose_Mode) is set and the verbosity level is at -- least equal to Minimum_Verbosity, then print Prefix to standard output -- followed by N1 and S1. If N2 /= No_Name then N2 is printed after S1. S2 -- is printed last. Both N1 and N2 are printed in quotation marks. The two -- forms differ only in taking Name_Id or File_name_Type arguments. --------- -- Add -- --------- procedure Add (Option : String_Access; To : in out String_List_Access; Last : in out Natural) is begin if Last = To'Last then declare New_Options : constant String_List_Access := new String_List (1 .. To'Last * 2); begin New_Options (To'Range) := To.all; -- Set all elements of the original options to null to avoid -- deallocation of copies. To.all := (others => null); Free (To); To := New_Options; end; end if; Last := Last + 1; To (Last) := Option; end Add; procedure Add (Option : String; To : in out String_List_Access; Last : in out Natural) is begin Add (Option => new String'(Option), To => To, Last => Last); end Add; --------------------------- -- Add_Gpr_Tool_External -- --------------------------- procedure Add_Gpr_Tool_External is use Ada.Environment_Variables; Gpr_Tool : constant String := Value ("GPR_TOOL", ""); begin -- Set GPR_TOOL unless already set if Gpr_Tool = "" then Ada.Environment_Variables.Set ("GPR_TOOL", "gprbuild"); end if; end Add_Gpr_Tool_External; ---------------------------- -- Aggregate_Libraries_In -- ---------------------------- function Aggregate_Libraries_In (Tree : Project_Tree_Ref) return Boolean is List : Project_List; begin List := Tree.Projects; while List /= null loop if List.Project.Qualifier = Aggregate_Library then return True; end if; List := List.Next; end loop; return False; end Aggregate_Libraries_In; ------------------------- -- Base_Name_Index_For -- ------------------------- function Base_Name_Index_For (Main : String; Main_Index : Int; Index_Separator : Character) return File_Name_Type is Result : File_Name_Type; begin Set_Name_Buffer (Base_Name (Main)); -- Remove the extension, if any, that is the last part of the base name -- starting with a dot and following some characters. for J in reverse 2 .. Name_Len loop if Name_Buffer (J) = '.' then Name_Len := J - 1; exit; end if; end loop; -- Add the index info, if index is different from 0 if Main_Index > 0 then Add_Char_To_Name_Buffer (Index_Separator); declare Img : constant String := Main_Index'Img; begin Add_Str_To_Name_Buffer (Img (2 .. Img'Last)); end; end if; Result := Name_Find; return Result; end Base_Name_Index_For; ------------------------------ -- Check_Source_Info_In_ALI -- ------------------------------ function Check_Source_Info_In_ALI (The_ALI : ALI.ALI_Id; Tree : Project_Tree_Ref) return Name_Id is Result : Name_Id := No_Name; Unit_Name : Name_Id; begin -- Loop through units for U in ALIs.Table (The_ALI).First_Unit .. ALIs.Table (The_ALI).Last_Unit loop -- Check if the file name is one of the source of the unit Get_Name_String (Units.Table (U).Uname); Name_Len := Name_Len - 2; Unit_Name := Name_Find; if File_Not_A_Source_Of (Tree, Unit_Name, Units.Table (U).Sfile) then return No_Name; end if; if Result = No_Name then Result := Unit_Name; end if; -- Loop to do same check for each of the withed units for W in Units.Table (U).First_With .. Units.Table (U).Last_With loop declare WR : ALI.With_Record renames Withs.Table (W); begin if WR.Sfile /= No_File then Get_Name_String (WR.Uname); Name_Len := Name_Len - 2; Unit_Name := Name_Find; if File_Not_A_Source_Of (Tree, Unit_Name, WR.Sfile) then return No_Name; end if; end if; end; end loop; end loop; -- Loop to check subunits and replaced sources for D in ALIs.Table (The_ALI).First_Sdep .. ALIs.Table (The_ALI).Last_Sdep loop declare SD : Sdep_Record renames Sdep.Table (D); begin Unit_Name := SD.Subunit_Name; if Unit_Name = No_Name then -- Check if this source file has been replaced by a source with -- a different file name. if Tree /= null and then Tree.Replaced_Source_Number > 0 then declare Replacement : constant File_Name_Type := Replaced_Source_HTable.Get (Tree.Replaced_Sources, SD.Sfile); begin if Replacement /= No_File then if Opt.Verbosity_Level > Opt.Low then Put_Line ("source file" & Get_Name_String_Safe (SD.Sfile) & " has been replaced by " & Get_Name_String_Safe (Replacement)); end if; return No_Name; end if; end; end if; -- Check that a dependent source for a unit that is from a -- project is indeed a source of this unit. Unit_Name := SD.Unit_Name; if Unit_Name /= No_Name -- and then not Fname.Is_Internal_File_Name (SD.Sfile) and then File_Not_A_Source_Of (Tree, Unit_Name, SD.Sfile) then return No_Name; end if; else -- For separates, the file is no longer associated with the -- unit ("proc-sep.adb" is not associated with unit "proc.sep") -- so we need to check whether the source file still exists in -- the source tree: it will if it matches the naming scheme -- (and then will be for the same unit). if GPR.Find_Source (In_Tree => Tree, Project => No_Project, Base_Name => SD.Sfile) = No_Source then Get_Name_String (SD.Sfile); if Name_Len < 3 or else Name_Buffer (2) /= '-' or else (Name_Buffer (1) /= 'a' and then Name_Buffer (1) /= 'g' and then Name_Buffer (1) /= 'i' and then Name_Buffer (1) /= 's') then if Opt.Verbosity_Level > Opt.Low then Put_Line ("While parsing ALI file, file " & Get_Name_String_Safe (SD.Sfile) & " is indicated as containing subunit " & Get_Name_String_Safe (Unit_Name) & " but this does not match what was found while" & " parsing the project. Will recompile"); end if; return No_Name; end if; end if; end if; end; end loop; return Result; end Check_Source_Info_In_ALI; -------------------------------- -- Create_Binder_Mapping_File -- -------------------------------- function Create_Binder_Mapping_File (Project_Tree : Project_Tree_Ref) return Path_Name_Type is Mapping_Path : Path_Name_Type := No_Path; Mapping_FD : File_Descriptor := Invalid_FD; -- A File Descriptor for an eventual mapping file ALI_Unit : Unit_Name_Type := No_Unit_Name; -- The unit name of an ALI file ALI_Name : File_Name_Type := No_File; -- The file name of the ALI file ALI_Project : Project_Id := No_Project; -- The project of the ALI file Bytes : Integer; OK : Boolean := False; Unit : Unit_Index; Status : Boolean; -- For call to Close Iter : Source_Iterator := For_Each_Source (In_Tree => Project_Tree, Language => Name_Ada, Encapsulated_Libs => False, Locally_Removed => False); Source : GPR.Source_Id; begin Tempdir.Create_Temp_File (Mapping_FD, Mapping_Path); Record_Temp_File (Project_Tree.Shared, Mapping_Path); if Mapping_FD /= Invalid_FD then OK := True; loop Source := Element (Iter); exit when Source = No_Source; Unit := Source.Unit; if Source.Replaced_By /= No_Source or else Unit = No_Unit_Index or else Unit.Name = No_Name then ALI_Name := No_File; -- If this is a body, put it in the mapping elsif Source.Kind = Impl and then Unit.File_Names (Impl) /= No_Source and then Unit.File_Names (Impl).Project /= No_Project then Get_Name_String (Unit.Name); Add_Str_To_Name_Buffer ("%b"); ALI_Unit := Name_Find; ALI_Name := Lib_File_Name (Unit.File_Names (Impl).Display_File); ALI_Project := Unit.File_Names (Impl).Project; -- Otherwise, if this is a spec and there is no body, put it in -- the mapping. elsif Source.Kind = Spec and then Unit.File_Names (Impl) = No_Source and then Unit.File_Names (Spec) /= No_Source and then Unit.File_Names (Spec).Project /= No_Project then Get_Name_String (Unit.Name); Add_Str_To_Name_Buffer ("%s"); ALI_Unit := Name_Find; ALI_Name := Lib_File_Name (Unit.File_Names (Spec).Display_File); ALI_Project := Unit.File_Names (Spec).Project; else ALI_Name := No_File; end if; -- If we have something to put in the mapping then do it now. If -- the project is extended, look for the ALI file in the project, -- then in the extending projects in order, and use the last one -- found. if ALI_Name /= No_File then -- Look in the project and the projects that are extending it -- to find the real ALI file. declare ALI : constant String := Get_Name_String (ALI_Name); ALI_Path : Name_Id := No_Name; begin loop -- For library projects, use the library ALI directory, -- for other projects, use the object directory. if ALI_Project.Library then Get_Name_String (ALI_Project.Library_ALI_Dir.Display_Name); else Get_Name_String (ALI_Project.Object_Directory.Display_Name); end if; Add_Str_To_Name_Buffer (ALI); if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then ALI_Path := Name_Find; end if; ALI_Project := ALI_Project.Extended_By; exit when ALI_Project = No_Project; end loop; if ALI_Path /= No_Name then -- First line is the unit name Get_Name_String (ALI_Unit); Add_Char_To_Name_Buffer (ASCII.LF); Bytes := Write (Mapping_FD, Name_Buffer (1)'Address, Name_Len); OK := Bytes = Name_Len; exit when not OK; -- Second line is the ALI file name Get_Name_String (ALI_Name); Add_Char_To_Name_Buffer (ASCII.LF); Bytes := Write (Mapping_FD, Name_Buffer (1)'Address, Name_Len); OK := (Bytes = Name_Len); exit when not OK; -- Third line is the ALI path name Get_Name_String (ALI_Path); Add_Char_To_Name_Buffer (ASCII.LF); Bytes := Write (Mapping_FD, Name_Buffer (1)'Address, Name_Len); OK := (Bytes = Name_Len); -- If OK is False, it means we were unable to write a -- line. No point in continuing with the other units. exit when not OK; end if; end; end if; Next (Iter); end loop; Close (Mapping_FD, Status); OK := OK and Status; end if; -- If the creation of the mapping file was successful, we add the switch -- to the arguments of gnatbind. if OK then return Mapping_Path; else return No_Path; end if; end Create_Binder_Mapping_File; ----------------- -- Escape_Path -- ----------------- function Escape_Path (Path : String) return String is Result : String (1 .. Path'Length * 2); Last : Natural := 0; begin for J in Path'Range loop if Path (J) in '\' | ' ' | '"' then Last := Last + 1; Result (Last) := '\'; end if; Last := Last + 1; Result (Last) := Path (J); end loop; return Result (1 .. Last); end Escape_Path; -------------------------- -- File_Not_A_Source_Of -- -------------------------- function File_Not_A_Source_Of (Project_Tree : Project_Tree_Ref; Uname : Name_Id; Sfile : File_Name_Type) return Boolean is Unit : constant Unit_Index := Units_Htable.Get (Project_Tree.Units_HT, Uname); At_Least_One_File : Boolean := False; begin if Unit /= No_Unit_Index then for F in Unit.File_Names'Range loop if Unit.File_Names (F) /= null then At_Least_One_File := True; if Unit.File_Names (F).File = Sfile then return False; end if; end if; end loop; if not At_Least_One_File then -- The unit was probably created initially for a separate unit -- (which are initially created as IMPL when both suffixes are the -- same). Later on, Override_Kind changed the type of the file, -- and the unit is no longer valid in fact. return False; end if; Verbose_Msg (Uname, "sources do not include ", Name_Id (Sfile)); return True; end if; return False; end File_Not_A_Source_Of; --------------------- -- Get_Directories -- --------------------- procedure Get_Directories (Project_Tree : Project_Tree_Ref; For_Project : Project_Id; Activity : Activity_Type; Languages : Name_Ids) is procedure Recursive_Add (Project : Project_Id; Tree : Project_Tree_Ref; Extended : in out Boolean); -- Add all the source directories of a project to the path only if -- this project has not been visited. Calls itself recursively for -- projects being extended, and imported projects. procedure Add_Dir (Value : Path_Name_Type); -- Add directory Value in table Directories, if it is defined and not -- already there. ------------- -- Add_Dir -- ------------- procedure Add_Dir (Value : Path_Name_Type) is Add_It : Boolean := True; begin if Value /= No_Path and then Is_Directory (Get_Name_String (Value)) then for Index in 1 .. Directories.Last loop if Directories.Table (Index) = Value then Add_It := False; exit; end if; end loop; if Add_It then Directories.Increment_Last; Directories.Table (Directories.Last) := Value; end if; end if; end Add_Dir; ------------------- -- Recursive_Add -- ------------------- procedure Recursive_Add (Project : Project_Id; Tree : Project_Tree_Ref; Extended : in out Boolean) is Current : String_List_Id; Dir : String_Element; OK : Boolean := False; Lang_Proc : Language_Ptr := Project.Languages; Lang_Is_Ada : Boolean := False; begin -- Add to path all directories of this project if Activity = Compilation then for J in Languages'Range loop if Languages (J) = Name_Ada then OK := True; Lang_Is_Ada := True; exit; end if; end loop; if not OK then Lang_Loop : while Lang_Proc /= No_Language_Index loop for J in Languages'Range loop OK := Lang_Proc.Name = Languages (J); exit Lang_Loop when OK; end loop; Lang_Proc := Lang_Proc.Next; end loop Lang_Loop; end if; if OK then Current := Project.Source_Dirs; while Current /= Nil_String loop Dir := Tree.Shared.String_Elements.Table (Current); -- For Ada we put all the source directories, as a -- preprocessing data file may be in a source directory -- with no source. if Lang_Is_Ada or else not Lang_Proc.Config.Only_Dirs_With_Sources then Add_Dir (Path_Name_Type (Dir.Value)); else -- For other languages, if Only_Dirs_With_Sources has -- been set to True, put the source directories with -- at least one source of the language(s). declare Dir_Name : constant String := Get_Name_String (Dir.Value); Src : GPR.Source_Id := Lang_Proc.First_Source; begin while Src /= No_Source loop if Index (Get_Name_String (Src.Path.Name), Dir_Name) = 1 then Add_Dir (Path_Name_Type (Dir.Value)); exit; end if; Src := Src.Next_In_Lang; end loop; end; end if; Current := Dir.Next; end loop; end if; elsif Project.Library then if Activity = SAL_Binding and then Extended then Add_Dir (Project.Object_Directory.Display_Name); else Add_Dir (Project.Library_ALI_Dir.Display_Name); end if; else Add_Dir (Project.Object_Directory.Display_Name); end if; if Project.Extends = No_Project then Extended := False; end if; end Recursive_Add; procedure For_All_Projects is new For_Every_Project_Imported (Boolean, Recursive_Add); Extended : Boolean := True; -- Start of processing for Get_Directories begin Directories.Init; For_All_Projects (For_Project, Project_Tree, Extended); end Get_Directories; ------------ -- Inform -- ------------ procedure Inform (N : File_Name_Type; Msg : String) is begin Inform (Name_Id (N), Msg); end Inform; procedure Inform (N : Name_Id := No_Name; Msg : String) is begin Write_Program_Name; if N /= No_Name then Write_Char ('"'); declare Name : constant String := Get_Name_String (N); begin if Debug.Debug_Flag_F and then Is_Absolute_Path (Name) then Write_Str (File_Name (Name)); else Write_Str (Name); end if; end; Write_Str (""" "); end if; Write_Line (Msg); end Inform; ---------------------------- -- Is_External_Assignment -- ---------------------------- function Is_External_Assignment (Env : GPR.Tree.Environment; Argv : String) return Boolean is Start : Positive := 3; Finish : Natural := Argv'Last; pragma Assert (Argv'First = 1); pragma Assert (Argv (1 .. 2) = "-X"); begin if Argv'Last < 5 then return False; elsif Argv (3) = '"' then if Argv (Argv'Last) /= '"' or else Argv'Last < 7 then return False; else Start := 4; Finish := Argv'Last - 1; end if; end if; return GPR.Ext.Check (Self => Env.External, Declaration => Argv (Start .. Finish)); end Is_External_Assignment; ------------------- -- Lib_File_Name -- ------------------- function Lib_File_Name (Source_File : File_Name_Type; Munit_Index : Nat := 0) return File_Name_Type is begin Get_Name_String (Source_File); for J in reverse 2 .. Name_Len loop if Name_Buffer (J) = '.' then Name_Len := J - 1; exit; end if; end loop; if Munit_Index /= 0 then Add_Char_To_Name_Buffer (Multi_Unit_Index_Character); Add_Nat_To_Name_Buffer (Munit_Index); end if; Add_Str_To_Name_Buffer (".ali"); return Name_Find; end Lib_File_Name; ----------- -- Mains -- ----------- package body Mains is package Main_Info_Vectors is new Ada.Containers.Indefinite_Vectors (Positive, Main_Info); -- The vector that stores the mains Names : Main_Info_Vectors.Vector; Current : Natural := 0; -- The index of the last main retrieved from the table Count_Of_Mains_With_No_Tree : Natural := 0; -- Number of main units for which we do not know the project tree -------------- -- Add_Main -- -------------- procedure Add_Main (Name : String; Index : Int := 0; Location : Source_Ptr := No_Location; Project : Project_Id := No_Project; Tree : Project_Tree_Ref := null) is Canonical_Name : File_Name_Type; begin Set_Name_Buffer (Name); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); Canonical_Name := Name_Find; -- Check if this main is already in table Names. If it is, do not -- put it again, to avoid binding and linking the same main several -- times in parallel when -jnn is used, as this does not work on all -- platforms. for N of Names loop if Canonical_Name = N.File and then Index = N.Index and then Project = N.Project then return; end if; end loop; if Current_Verbosity = High then Debug_Output ("Add_Main """ & Name & """ " & Index'Img & " with_tree? " & Boolean'Image (Tree /= null)); end if; Set_Name_Buffer (Name); Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); Names.Append ((Name_Find, Index, Location, No_Source, Project, Tree, String_Vectors.Empty_Vector), 1); if Tree /= null then Builder_Data (Tree).Number_Of_Mains := Builder_Data (Tree).Number_Of_Mains + 1; else Mains.Count_Of_Mains_With_No_Tree := Mains.Count_Of_Mains_With_No_Tree + 1; end if; end Add_Main; -------------------- -- Complete_Mains -- -------------------- procedure Complete_Mains (Flags : Processing_Flags; Root_Project : Project_Id; Project_Tree : Project_Tree_Ref; Unique_Compile : Boolean := False) is procedure Do_Complete (Project : Project_Id; Tree : Project_Tree_Ref); -- Check the mains for this specific project procedure Complete_All is new For_Project_And_Aggregated (Do_Complete); procedure Add_Multi_Unit_Sources (Tree : Project_Tree_Ref; Source : GPR.Source_Id); -- Add all units from the same file as the multi-unit Source function Find_File_Add_Extension (Tree : Project_Tree_Ref; Base_Main : String) return GPR.Source_Id; -- Search for Main in the project, adding body or spec extensions ---------------------------- -- Add_Multi_Unit_Sources -- ---------------------------- procedure Add_Multi_Unit_Sources (Tree : Project_Tree_Ref; Source : GPR.Source_Id) is Iter : Source_Iterator; Src : GPR.Source_Id; begin Debug_Output ("found multi-unit source file in project", Source.Project.Name); Iter := For_Each_Source (In_Tree => Tree, Project => Source.Project); while Element (Iter) /= No_Source loop Src := Element (Iter); if Src.File = Source.File and then Src.Index /= Source.Index then if Src.File = Source.File then Debug_Output ("add main in project, index=" & Src.Index'Img); end if; Names.Append ((File => Src.File, Index => Src.Index, Location => No_Location, Source => Src, Project => Src.Project, Tree => Tree, Command => String_Vectors.Empty_Vector), 1); Builder_Data (Tree).Number_Of_Mains := Builder_Data (Tree).Number_Of_Mains + 1; end if; Next (Iter); end loop; end Add_Multi_Unit_Sources; ----------------------------- -- Find_File_Add_Extension -- ----------------------------- function Find_File_Add_Extension (Tree : Project_Tree_Ref; Base_Main : String) return GPR.Source_Id is Spec_Source : GPR.Source_Id := No_Source; Source : GPR.Source_Id; Iter : Source_Iterator; Suffix : File_Name_Type; begin Source := No_Source; Iter := For_Each_Source (Tree); -- In all projects loop Source := GPR.Element (Iter); exit when Source = No_Source; if Source.Kind = Impl then Get_Name_String (Source.File); if Name_Len > Base_Main'Length and then Name_Buffer (1 .. Base_Main'Length) = Base_Main then Suffix := Source.Language.Config.Naming_Data.Body_Suffix; if Suffix /= No_File then declare Suffix_Str : String := Get_Name_String (Suffix); begin Canonical_Case_File_Name (Suffix_Str); exit when Name_Buffer (Base_Main'Length + 1 .. Name_Len) = Suffix_Str; end; end if; end if; elsif Source.Kind = Spec and then Source.Language.Config.Kind = Unit_Based then -- An Ada spec needs to be taken into account unless there -- is also a body. So we delay the decision for them. Get_Name_String (Source.File); if Name_Len > Base_Main'Length and then Name_Buffer (1 .. Base_Main'Length) = Base_Main then Suffix := Source.Language.Config.Naming_Data.Spec_Suffix; if Suffix /= No_File then declare Suffix_Str : String := Get_Name_String (Suffix); begin Canonical_Case_File_Name (Suffix_Str); if Name_Buffer (Base_Main'Length + 1 .. Name_Len) = Suffix_Str then Spec_Source := Source; end if; end; end if; end if; end if; Next (Iter); end loop; if Source = No_Source then Source := Spec_Source; end if; return Source; end Find_File_Add_Extension; ----------------- -- Do_Complete -- ----------------- procedure Do_Complete (Project : Project_Id; Tree : Project_Tree_Ref) is J : Integer; begin if Mains.Number_Of_Mains (Tree) > 0 or else Mains.Count_Of_Mains_With_No_Tree > 0 then -- Traverse in reverse order, since in the case of multi-unit -- files we will be adding extra files at the end, and there's -- no need to process them in turn. J := Names.Last_Index; Main_Loop : loop declare File : Main_Info := Names (J); Main_Id : File_Name_Type := File.File; Main : constant String := Get_Name_String (Main_Id); Base : constant String := Base_Name (Main); Source : GPR.Source_Id := No_Source; Absolute : array (Boolean) of File_Name_Type := (others => No_File); begin if Base /= Main then -- Keep 2 absolute path values with and without -- symbolic names resolution, so that users can -- specify any name on the command line. If the -- project itself uses links, the user will be using -- -eL anyway, and thus files are also stored with -- resolved names. for Links in Absolute'Range loop Absolute (Links) := Create_Name (Normalize_Pathname (Name => Main, Directory => "", Resolve_Links => Links, Case_Sensitive => False)); end loop; Main_Id := Create_Name (Base); end if; -- If no project or tree was specified for the main, it -- came from the command line. -- Note that the assignments below will not modify inside -- the table itself. if File.Project = null then File.Project := Project; end if; if File.Tree = null then File.Tree := Tree; end if; if File.Source = null then if Current_Verbosity = High then Debug_Output ("search for main """ & Main & '"' & File.Index'Img & " in " & Get_Name_String_Safe (Debug_Name (File.Tree)) & ", project", Project.Name); end if; -- First, look for the main as specified. We need to -- search for the base name though, and if needed -- check later that we found the correct file. declare Sources : constant Source_Ids := Find_All_Sources (In_Tree => File.Tree, Project => File.Project, Base_Name => Main_Id, Index => File.Index, In_Imported_Only => True); begin if Absolute (False) /= No_File then for S of Sources loop if File_Name_Type (S.Path.Name) in Absolute (False) | Absolute (True) then Source := S; File.File := File_Name_Type (S.Path.Name); exit; end if; end loop; elsif Sources'Length > 1 then -- This is only allowed if the units are from -- the same multi-unit source file. Source := Sources (1); for J in 2 .. Sources'Last loop if Sources (J).Path /= Source.Path or else Sources (J).Index = Source.Index then Error_Msg_File_1 := Main_Id; GPR.Err.Error_Msg (Flags, "several main sources {", No_Location, File.Project); exit Main_Loop; end if; end loop; elsif Sources'Length = 1 then Source := Sources (Sources'First); end if; end; if Source = No_Source then Source := Find_File_Add_Extension (File.Tree, Get_Name_String (Main_Id)); end if; if Absolute (False) /= No_File and then Source /= No_Source and then File_Name_Type (Source.Path.Name) /= File.File then Debug_Output ("Found a non-matching file", Name_Id (Source.Path.Display_Name)); Source := No_Source; end if; if Source /= No_Source then if not Is_Allowed_Language (Source.Language.Name) then -- Remove any main that is not in the list of -- restricted languages. Names.Delete (J); else -- If we have found a multi-unit source file but -- did not specify an index initially, we'll -- need to compile all the units from the same -- source file. if Source.Index /= 0 and then File.Index = 0 then Add_Multi_Unit_Sources (File.Tree, Source); end if; -- A main cannot be a source of a library -- project. if (not Opt.Compile_Only or else Opt.Bind_Only) and then not Unique_Compile and then Source.Project.Library then Error_Msg_File_1 := Main_Id; GPR.Err.Error_Msg (Flags, "main cannot be a source" & " of a library project: {", No_Location, File.Project); else -- Now update the original Main, otherwise it -- will be reported as not found. Debug_Output ("found main in project", Source.Project.Name); Names (J).File := Source.File; Names (J).Project := Source.Project; if Names (J).Tree = null then Names (J).Tree := File.Tree; Builder_Data (File.Tree).Number_Of_Mains := Builder_Data (File.Tree).Number_Of_Mains + 1; Mains.Count_Of_Mains_With_No_Tree := Mains.Count_Of_Mains_With_No_Tree - 1; end if; Names (J).Source := Source; Names (J).Index := Source.Index; end if; end if; elsif File.Location /= No_Location then -- If the main is declared in package Builder of -- the main project, report an error. If the main -- is on the command line, it may be a main from -- another project, so do nothing: if the main does -- not exist in another project, an error will be -- reported later. Error_Msg_File_1 := Main_Id; Error_Msg_Name_1 := File.Project.Name; GPR.Err.Error_Msg (Flags, "{ is not a source of project %%", File.Location, File.Project); end if; end if; end; J := J - 1; exit Main_Loop when J < Names.First_Index; end loop Main_Loop; end if; if Total_Errors_Detected > 0 then Fail_Program (Tree, "problems with main sources", Exit_Code => E_General); end if; end Do_Complete; -- Start of processing for Complete_Mains begin Complete_All (Root_Project, Project_Tree); for N of Names loop if N.Source = No_Source then Fail_Program (Project_Tree, '"' & Get_Name_String_Safe (N.File) & """ was not found in the sources of any project", Exit_Code => E_General); end if; end loop; end Complete_Mains; ------------ -- Delete -- ------------ procedure Delete is begin Names.Clear; Mains.Reset; end Delete; ----------------------- -- Fill_From_Project -- ----------------------- procedure Fill_From_Project (Root_Project : Project_Id; Project_Tree : Project_Tree_Ref) is procedure Add_Mains_From_Project (Project : Project_Id; Tree : Project_Tree_Ref); -- Add the main units from this project into Mains. -- This takes into account the aggregated projects ---------------------------- -- Add_Mains_From_Project -- ---------------------------- procedure Add_Mains_From_Project (Project : Project_Id; Tree : Project_Tree_Ref) is List : String_List_Id; Element : String_Element; begin if Number_Of_Mains (Tree) = 0 and then Mains.Count_Of_Mains_With_No_Tree = 0 then Debug_Output ("Add_Mains_From_Project", Project.Name); List := Project.Mains; if List /= GPR.Nil_String then -- The attribute Main is not an empty list. Get the mains in -- the list. while List /= GPR.Nil_String loop Element := Tree.Shared.String_Elements.Table (List); Debug_Output ("Add_Main", Element.Value); if Project.Library then Fail_Program (Tree, "cannot specify a main program " & "for a library project file"); end if; Add_Main (Name => Get_Name_String (Element.Value), Index => Element.Index, Location => Element.Location, Project => Project, Tree => Tree); List := Element.Next; end loop; end if; end if; if Total_Errors_Detected > 0 then Fail_Program (Tree, "problems with main sources"); end if; end Add_Mains_From_Project; procedure Fill_All is new For_Project_And_Aggregated (Add_Mains_From_Project); -- Start of processing for Fill_From_Project begin Fill_All (Root_Project, Project_Tree); end Fill_From_Project; --------------- -- Next_Main -- --------------- function Next_Main return String is Info : constant Main_Info := Next_Main; begin if Info = No_Main_Info then return ""; else return Get_Name_String (Info.File); end if; end Next_Main; function Next_Main return Main_Info is begin if Current >= Names.Last_Index then return No_Main_Info; else Current := Current + 1; return Names (Current); end if; end Next_Main; --------------------- -- Number_Of_Mains -- --------------------- function Number_Of_Mains (Tree : Project_Tree_Ref) return Natural is begin if Tree = null then return Names.Last_Index; else return Builder_Data (Tree).Number_Of_Mains; end if; end Number_Of_Mains; ----------- -- Reset -- ----------- procedure Reset is begin Current := 0; end Reset; -------------------------- -- Set_Multi_Unit_Index -- -------------------------- procedure Set_Multi_Unit_Index (Project_Tree : Project_Tree_Ref := null; Index : Int := 0) is begin if Index /= 0 then if Names.Last_Index = 0 then Fail_Program (Project_Tree, "cannot specify a multi-unit index but no main on the" & " command line", Exit_Code => E_General); elsif Names.Last_Index > 1 then Fail_Program (Project_Tree, "cannot specify several mains with a multi-unit index", Exit_Code => E_General); else Names (Names.Last_Index).Index := Index; end if; end if; end Set_Multi_Unit_Index; end Mains; ----------------------- -- Path_Or_File_Name -- ----------------------- function Path_Or_File_Name (Path : Path_Name_Type) return String is Path_Name : constant String := Get_Name_String (Path); begin if Debug.Debug_Flag_F then return File_Name (Path_Name); else return Path_Name; end if; end Path_Or_File_Name; ----------------- -- Verbose_Msg -- ----------------- procedure Verbose_Msg (N1 : Name_Id; S1 : String; N2 : Name_Id := No_Name; S2 : String := ""; Prefix : String := " -> "; Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low) is begin if not Opt.Verbose_Mode or else Minimum_Verbosity > Opt.Verbosity_Level then return; end if; Put (Prefix); Put (""""); Put (Get_Name_String (N1)); Put (""" "); Put (S1); if N2 /= No_Name then Put (" """); Put (Get_Name_String (N2)); Put (""" "); end if; Put (S2); New_Line; end Verbose_Msg; ----------- -- Queue -- ----------- package body Queue is type Q_Record is record Info : Source_Info; Processed : Boolean; end record; package Q is new GNAT.Table (Table_Component_Type => Q_Record, Table_Index_Type => Natural, Table_Low_Bound => 1, Table_Initial => 1000, Table_Increment => 100); -- This is the actual Queue package Busy_Obj_Dirs is new GNAT.HTable.Simple_HTable (Header_Num => GPR.Header_Num, Element => Boolean, No_Element => False, Key => Path_Name_Type, Hash => Hash, Equal => "="); Q_Processed : Natural := 0; Q_Initialized : Boolean := False; Q_First : Natural := 1; -- Points to the first valid element in the queue Q_Prev_First : Natural := 1; -- Points to the previous first valid element in the queue One_Queue_Per_Obj_Dir : Boolean := False; -- See parameter to Initialize function Available_Obj_Dir (S : Source_Info) return Boolean; -- Whether the object directory for S is available for a build procedure Debug_Display (S : Source_Info); -- A debug display for S function Insert_No_Roots (Source : Source_Info; Repeat : Boolean := False) return Boolean; -- Insert Source, but do not look for its roots (see doc for Insert). -- If Repeat is True the source inserted even if it was ----------------------- -- Available_Obj_Dir -- ----------------------- function Available_Obj_Dir (S : Source_Info) return Boolean is begin return not Busy_Obj_Dirs.Get (S.Id.Project.Object_Directory.Name); end Available_Obj_Dir; ------------------- -- Debug_Display -- ------------------- procedure Debug_Display (S : Source_Info) is begin Put (Get_Name_String (S.Id.File)); if S.Id.Index /= 0 then Put (","); Put (S.Id.Index'Img); end if; end Debug_Display; ------------- -- Extract -- ------------- procedure Extract (Found : out Boolean; Source : out Source_Info) is begin Found := False; if One_Queue_Per_Obj_Dir then for J in Q_First .. Q.Last loop if not Q.Table (J).Processed and then Available_Obj_Dir (Q.Table (J).Info) then Found := True; Source := Q.Table (J).Info; Q.Table (J).Processed := True; if J = Q_First then while Q_First <= Q.Last and then Q.Table (Q_First).Processed loop Q_First := Q_First + 1; end loop; end if; exit; end if; end loop; elsif Q_First <= Q.Last then Source := Q.Table (Q_First).Info; Q.Table (Q_First).Processed := True; Q_First := Q_First + 1; Found := True; end if; if Found then Q_Processed := Q_Processed + 1; end if; if Found and then Debug.Debug_Flag_Q then Ada.Text_IO.Put (" Q := Q - [ "); Debug_Display (Source); Ada.Text_IO.Put (" ]"); New_Line; Ada.Text_IO.Put (" Q_First ="); Ada.Text_IO.Put (Q_First'Img); New_Line; Ada.Text_IO.Put (" Q.Last ="); Ada.Text_IO.Put (Q.Last'Img); New_Line; end if; end Extract; --------- -- Get -- --------- procedure Get (Found : out Boolean; Source : out Source_Info) is begin Found := False; if One_Queue_Per_Obj_Dir then for J in Q_First .. Q.Last loop if not Q.Table (J).Processed and then Available_Obj_Dir (Q.Table (J).Info) then Found := True; Source := Q.Table (J).Info; if Q_First /= J then Q_Prev_First := Q_First; end if; Q_First := J; exit; end if; end loop; elsif Q_First <= Q.Last then Source := Q.Table (Q_First).Info; Found := True; end if; if Found and then Debug.Debug_Flag_Q then Ada.Text_IO.Put (" Q := Q = [ "); Debug_Display (Source); Ada.Text_IO.Put (" ]"); New_Line; Ada.Text_IO.Put (" Q_First ="); Ada.Text_IO.Put (Q_First'Img); New_Line; Ada.Text_IO.Put (" Q_Prev_First ="); Ada.Text_IO.Put (Q_Prev_First'Img); New_Line; Ada.Text_IO.Put (" Q.Last ="); Ada.Text_IO.Put (Q.Last'Img); New_Line; end if; end Get; ---------- -- Next -- ---------- procedure Next is begin Q.Table (Q_First).Processed := True; Q_Processed := Q_Processed + 1; if Debug.Debug_Flag_Q then Ada.Text_IO.Put (" Q := Q - [ "); Debug_Display (Q.Table (Q_First).Info); Ada.Text_IO.Put (" ]"); New_Line; end if; if One_Queue_Per_Obj_Dir and then Q_First /= Q_Prev_First then Q_First := Q_Prev_First; while Q_First <= Q.Last and then Q.Table (Q_First).Processed loop Q_First := Q_First + 1; end loop; Q_Prev_First := Q_First; else Q_First := Q_First + 1; Q_Prev_First := Q_First; end if; if Debug.Debug_Flag_Q then Ada.Text_IO.Put (" Q_First ="); Ada.Text_IO.Put (Q_First'Img); New_Line; Ada.Text_IO.Put (" Q_Prev_First ="); Ada.Text_IO.Put (Q_Prev_First'Img); New_Line; Ada.Text_IO.Put (" Q.Last ="); Ada.Text_IO.Put (Q.Last'Img); New_Line; end if; end Next; --------------- -- Processed -- --------------- function Processed return Natural is begin return Q_Processed; end Processed; ---------------- -- Initialize -- ---------------- procedure Initialize (Queue_Per_Obj_Dir : Boolean; Force : Boolean := False) is begin if Force or else not Q_Initialized then Q_Initialized := True; for J in 1 .. Q.Last loop Q.Table (J).Info.Id.In_The_Queue := False; end loop; Q.Init; Q_Processed := 0; Q_First := 1; One_Queue_Per_Obj_Dir := Queue_Per_Obj_Dir; end if; end Initialize; --------------------- -- Insert_No_Roots -- --------------------- function Insert_No_Roots (Source : Source_Info; Repeat : Boolean := False) return Boolean is begin pragma Assert (Source.Id /= No_Source); -- Only insert in the Q if it is not already done, to avoid -- simultaneous compilations if -jnnn is used. if not Repeat and then Source.Id.In_The_Queue then return False; end if; -- Check if a source has already been inserted in the queue from the -- same project in a different project tree. for J in (if Repeat then Q_First + 1 else 1) .. Q.Last loop if Source.Id.Path.Name = Q.Table (J).Info.Id.Path.Name and then Source.Id.Index = Q.Table (J).Info.Id.Index and then Ultimate_Extending_Project_Of (Source.Id.Project).Path.Name = Ultimate_Extending_Project_Of (Q.Table (J).Info.Id.Project). Path.Name then -- No need to insert this source in the queue, but still -- return True as we may need to insert its roots. return True; end if; end loop; if Current_Verbosity = High then Put ("Adding """); Debug_Display (Source); Put_Line (""" to the queue"); end if; Q.Append (New_Val => (Info => Source, Processed => False)); Source.Id.In_The_Queue := True; if Debug.Debug_Flag_Q then Ada.Text_IO.Put (" Q := Q + [ "); Debug_Display (Source); Ada.Text_IO.Put (" ] "); New_Line; Ada.Text_IO.Put (" Q_First ="); Ada.Text_IO.Put (Q_First'Img); New_Line; Ada.Text_IO.Put (" Q.Last ="); Ada.Text_IO.Put (Q.Last'Img); New_Line; end if; return True; end Insert_No_Roots; ------------ -- Insert -- ------------ function Insert (Source : Source_Info; With_Roots : Boolean := False; Repeat : Boolean := False) return Boolean is Root_Arr : Array_Element_Id; Roots : Variable_Value; List : String_List_Id; Elem : String_Element; Unit_Name : Name_Id; Pat_Root : Boolean; Root_Pattern : Regexp; Root_Found : Boolean; Roots_Found : Boolean; Root_Source : GPR.Source_Id; Iter : Source_Iterator; Dummy : Boolean; begin if not Insert_No_Roots (Source, Repeat) then -- Was already in the queue return False; end if; if With_Roots then Debug_Output ("looking for roots of", Name_Id (Source.Id.File)); Root_Arr := GPR.Util.Value_Of (Name => Name_Roots, In_Arrays => Source.Id.Project.Decl.Arrays, Shared => Source.Tree.Shared); Roots := GPR.Util.Value_Of (Index => Name_Id (Source.Id.File), Src_Index => 0, In_Array => Root_Arr, Shared => Source.Tree.Shared); -- If there is no roots for the specific main, try the language if Roots = Nil_Variable_Value then Roots := GPR.Util.Value_Of (Index => Source.Id.Language.Name, Src_Index => 0, In_Array => Root_Arr, Shared => Source.Tree.Shared, Force_Lower_Case_Index => True); end if; -- Then try "*" if Roots = Nil_Variable_Value then Roots := GPR.Util.Value_Of (Index => The_Star_String, Src_Index => 0, In_Array => Root_Arr, Shared => Source.Tree.Shared, Force_Lower_Case_Index => True); end if; if Roots = Nil_Variable_Value then Debug_Output (" -> no roots declared"); else List := Roots.Values; -- case of empty root list if List = Nil_String then Source.Id.Roots := new Source_Roots' (Root => No_Source, Next => null); end if; Pattern_Loop : while List /= Nil_String loop Elem := Source.Tree.Shared.String_Elements.Table (List); Get_Name_String (Elem.Value); To_Lower (Name_Buffer (1 .. Name_Len)); Unit_Name := Name_Find; -- Check if it is a unit name or a pattern Pat_Root := False; for J in 1 .. Name_Len loop if Name_Buffer (J) not in 'a' .. 'z' | '0' .. '9' | '_' | '.' then Pat_Root := True; exit; end if; end loop; if Pat_Root then begin Root_Pattern := Compile (Pattern => Name_Buffer (1 .. Name_Len), Glob => True); exception when Error_In_Regexp => Error_Msg_Name_1 := Unit_Name; Error_Msg ("invalid pattern %", Roots.Location); exit Pattern_Loop; end; end if; Roots_Found := False; Iter := For_Each_Source (Source.Tree); Source_Loop : loop Root_Source := GPR.Element (Iter); exit Source_Loop when Root_Source = No_Source; Root_Found := False; if Pat_Root then Root_Found := Root_Source.Unit /= No_Unit_Index and then Match (Get_Name_String (Root_Source.Unit.Name), Root_Pattern); else Root_Found := Root_Source.Unit /= No_Unit_Index and then Root_Source.Unit.Name = Unit_Name; end if; if Root_Found then case Root_Source.Kind is when Impl => null; when Spec => Root_Found := Other_Part (Root_Source) = No_Source; when Sep => Root_Found := False; end case; end if; if Root_Found then Roots_Found := True; Debug_Output (" -> ", Name_Id (Root_Source.Display_File)); Dummy := Queue.Insert_No_Roots (Source => (Tree => Source.Tree, Id => Root_Source, Closure => False)); Initialize_Source_Record (Root_Source); if Other_Part (Root_Source) /= No_Source then Initialize_Source_Record (Other_Part (Root_Source)); end if; -- Save the root for the binder Source.Id.Roots := new Source_Roots' (Root => Root_Source, Next => Source.Id.Roots); exit Source_Loop when not Pat_Root; end if; Next (Iter); end loop Source_Loop; if not Roots_Found then if Pat_Root then if not Quiet_Output then Error_Msg_Name_1 := Unit_Name; Error_Msg ("?no unit matches pattern %", Roots.Location); end if; else Error_Msg ("Unit " & Get_Name_String_Safe (Unit_Name) & " does not exist", Roots.Location); end if; end if; List := Elem.Next; end loop Pattern_Loop; end if; end if; return True; end Insert; ------------ -- Insert -- ------------ procedure Insert (Source : Source_Info; With_Roots : Boolean := False; Repeat : Boolean := False) is Discard : Boolean; begin Discard := Insert (Source, With_Roots, Repeat); end Insert; -------------- -- Is_Empty -- -------------- function Is_Empty return Boolean is begin return Q_Processed >= Q.Last; end Is_Empty; ------------------------ -- Is_Virtually_Empty -- ------------------------ function Is_Virtually_Empty return Boolean is begin if One_Queue_Per_Obj_Dir then for J in Q_First .. Q.Last loop if not Q.Table (J).Processed and then Available_Obj_Dir (Q.Table (J).Info) then return False; end if; end loop; return True; else return Is_Empty; end if; end Is_Virtually_Empty; ---------------------- -- Set_Obj_Dir_Busy -- ---------------------- procedure Set_Obj_Dir_Busy (Obj_Dir : Path_Name_Type) is begin if One_Queue_Per_Obj_Dir then Busy_Obj_Dirs.Set (Obj_Dir, True); end if; end Set_Obj_Dir_Busy; ---------------------- -- Set_Obj_Dir_Free -- ---------------------- procedure Set_Obj_Dir_Free (Obj_Dir : Path_Name_Type) is begin if One_Queue_Per_Obj_Dir then Busy_Obj_Dirs.Set (Obj_Dir, False); end if; end Set_Obj_Dir_Free; ---------- -- Size -- ---------- function Size return Natural is begin return Q.Last; end Size; ------------- -- Element -- ------------- function Element (Rank : Positive) return File_Name_Type is begin if Rank <= Q.Last then return Q.Table (Rank).Info.Id.File; else return No_File; end if; end Element; ---------------------------- -- Insert_Project_Sources -- ---------------------------- procedure Insert_Project_Sources (Project : Project_Id; Project_Tree : Project_Tree_Ref; All_Projects : Boolean; Unique_Compile : Boolean) is procedure Do_Insert (Project : Project_Id; Tree : Project_Tree_Ref; Context : Project_Context); -- Insert appropriate project sources into compilation queue --------------- -- Do_Insert -- --------------- procedure Do_Insert (Project : Project_Id; Tree : Project_Tree_Ref; Context : Project_Context) is Unit_Based : constant Boolean := Unique_Compile or else not Builder_Data (Tree).Closure_Needed; -- When Unit_Based is True, we enqueue all compilable sources -- including the unit based (Ada) one. When Unit_Based is False, -- put the Ada sources only when they are in a library project. Iter : Source_Iterator; Source : GPR.Source_Id; OK : Boolean; Closure : Boolean; Proj : Project_Id; Location : Source_Ptr; function String_List_Contains (List : String_List_Id; Item : File_Name_Type) return Boolean; -- Returns True if Item is in the List -------------------------- -- String_List_Contains -- -------------------------- function String_List_Contains (List : String_List_Id; Item : File_Name_Type) return Boolean is Iterate : String_List_Id := List; Element : String_Element; begin while Iterate /= Nil_String loop Element := Project_Tree.Shared.String_Elements.Table (Iterate); if Element.Value = Name_Id (Item) then return True; end if; Iterate := Element.Next; end loop; return False; end String_List_Contains; begin -- Nothing to do when "-u" was specified and some files were -- specified on the command line if Unique_Compile and then Mains.Number_Of_Mains (Tree) > 0 then return; end if; Iter := For_Each_Source (Tree); loop Source := GPR.Element (Iter); exit when Source = No_Source; Proj := Ultimate_Extending_Project_Of (Source.Project); if not Proj.Externally_Built then -- Fail if no compiler if Is_Allowed_Language (Source.Language.Name) and then Source.Language.Config.Compiler_Driver = No_File then -- Always provide a non null location if Source.Location = No_Location then Location := Source.Project.Location; else Location := Source.Location; end if; Error_Msg_Name_1 := Source.Language.Display_Name; Error_Msg_File_1 := Source.File; Error_Msg ("no compiler for language %%, cannot compile {{", Flag_Location => Location); Compilation_Phase_Failed (Project_Tree); end if; if Is_Allowed_Language (Source.Language.Name) and then Is_Compilable (Source) and then (All_Projects or else Is_Extending (Project, Source.Project)) and then not Source.Locally_Removed and then Source.Replaced_By = No_Source and then Source.Kind /= Sep and then Source.Path /= No_Path_Information then if Source.Kind = Impl or else (Source.Unit /= No_Unit_Index and then Source.Kind = Spec and then (Other_Part (Source) = No_Source or else Other_Part (Source).Locally_Removed)) then if (Unit_Based or else Source.Unit = No_Unit_Index or else Proj.Library or else Context.In_Aggregate_Lib or else Project.Qualifier = Aggregate_Library) and then not Is_Subunit (Source) then OK := True; Closure := False; if (Proj.Library or else Project.Qualifier = Aggregate_Library or else Context.In_Aggregate_Lib) and then Source.Project.Standalone_Library /= No then -- Check if the source is in the interface if Source.Unit = No_Unit_Index then OK := True; Closure := String_List_Contains (Source.Project.Other_Interfaces, Source.File); else OK := String_List_Contains (Source.Project.Lib_Interface_ALIs, Source.Dep_Name); Closure := OK; end if; end if; if OK then Queue.Insert (Source => (Tree => Tree, Id => Source, Closure => Closure), With_Roots => Closure); end if; end if; end if; end if; end if; Next (Iter); end loop; end Do_Insert; procedure Insert_All is new For_Project_And_Aggregated_Context (Do_Insert); begin Insert_All (Project, Project_Tree); end Insert_Project_Sources; ------------------------------- -- Insert_Withed_Sources_For -- ------------------------------- procedure Insert_Withed_Sources_For (The_ALI : ALI.ALI_Id; Project_Tree : Project_Tree_Ref; Excluding_Shared_SALs : Boolean := False) is Sfile : File_Name_Type; Afile : File_Name_Type; Src_Id : GPR.Source_Id; begin -- Insert in the queue the unmarked source files (i.e. those which -- have never been inserted in the queue and hence never considered). for J in ALI.ALIs.Table (The_ALI).First_Unit .. ALI.ALIs.Table (The_ALI).Last_Unit loop for K in ALI.Units.Table (J).First_With .. ALI.Units.Table (J).Last_With loop Sfile := ALI.Withs.Table (K).Sfile; -- Skip generics if Sfile /= No_File then Afile := ALI.Withs.Table (K).Afile; Src_Id := Source_Files_Htable.Get (Project_Tree.Source_Files_HT, Sfile); while Src_Id /= No_Source loop Initialize_Source_Record (Src_Id); if Is_Compilable (Src_Id) and then Src_Id.Dep_Name = Afile then case Src_Id.Kind is when Spec => declare Bdy : constant GPR.Source_Id := Other_Part (Src_Id); begin if Bdy /= No_Source and then not Bdy.Locally_Removed then Src_Id := Other_Part (Src_Id); end if; end; when Impl => if Is_Subunit (Src_Id) then Src_Id := No_Source; end if; when Sep => Src_Id := No_Source; end case; exit; end if; Src_Id := Src_Id.Next_With_File_Name; end loop; -- If Excluding_Shared_SALs is True, do not insert in the -- queue the sources of a shared Stand-Alone Library. if Src_Id /= No_Source and then (not Excluding_Shared_SALs or else Src_Id.Project.Standalone_Library = No or else Src_Id.Project.Library_Kind = Static) then Queue.Insert (Source => (Tree => Project_Tree, Id => Src_Id, Closure => True)); end if; end if; end loop; end loop; end Insert_Withed_Sources_For; end Queue; ---------- -- Free -- ---------- procedure Free (Data : in out Builder_Project_Tree_Data) is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Binding_Data_Record, Binding_Data); TmpB, Binding : Binding_Data := Data.Binding; begin while Binding /= null loop TmpB := Binding.Next; Unchecked_Free (Binding); Binding := TmpB; end loop; end Free; ------------------ -- Builder_Data -- ------------------ function Builder_Data (Tree : Project_Tree_Ref) return Builder_Data_Access is begin if Tree.Appdata = null then Tree.Appdata := new Builder_Project_Tree_Data; end if; return Builder_Data_Access (Tree.Appdata); end Builder_Data; -------------------------------- -- Compute_Compilation_Phases -- -------------------------------- procedure Compute_Compilation_Phases (Tree : Project_Tree_Ref; Root_Project : Project_Id; Option_Unique_Compile : Boolean := False; -- Was "-u" specified ? Option_Compile_Only : Boolean := False; -- Was "-c" specified ? Option_Bind_Only : Boolean := False; Option_Link_Only : Boolean := False) is procedure Do_Compute (Project : Project_Id; Tree : Project_Tree_Ref); ---------------- -- Do_Compute -- ---------------- procedure Do_Compute (Project : Project_Id; Tree : Project_Tree_Ref) is Data : constant Builder_Data_Access := Builder_Data (Tree); All_Phases : constant Boolean := not Option_Compile_Only and then not Option_Bind_Only and then not Option_Link_Only; -- Whether the command line asked for all three phases. Depending on -- the project settings, we might still disable some of the phases. Has_Mains : constant Boolean := Data.Number_Of_Mains > 0; -- Whether there are some main units defined for this project tree -- (either from one of the projects, or from the command line) begin if Option_Unique_Compile then -- If -u or -U is specified on the command line, disregard any -c, -- -b or -l switch: only perform compilation. Data.Closure_Needed := False; Data.Need_Compilation := True; Data.Need_Binding := False; Data.Need_Linking := False; else Data.Closure_Needed := Has_Mains or else (Root_Project.Library and then Root_Project.Standalone_Library /= No); Data.Need_Compilation := All_Phases or Option_Compile_Only; Data.Need_Binding := All_Phases or Option_Bind_Only; Data.Need_Linking := (All_Phases or Option_Link_Only) and Has_Mains; end if; if Current_Verbosity = High then Debug_Output ("compilation phases: " & " compile=" & Data.Need_Compilation'Img & " bind=" & Data.Need_Binding'Img & " link=" & Data.Need_Linking'Img & " closure=" & Data.Closure_Needed'Img & " mains=" & Data.Number_Of_Mains'Img, Project.Name); end if; end Do_Compute; procedure Compute_All is new For_Project_And_Aggregated (Do_Compute); begin Compute_All (Root_Project, Tree); end Compute_Compilation_Phases; ------------------------------ -- Compute_Builder_Switches -- ------------------------------ procedure Compute_Builder_Switches (Project_Tree : Project_Tree_Ref; Env : GPR.Tree.Environment; Main_Project : Project_Id; Only_For_Lang : Name_Id := No_Name) is Builder_Package : constant Package_Id := Value_Of (Name_Builder, Main_Project.Decl.Packages, Project_Tree.Shared); Global_Compilation_Array : Array_Element_Id := No_Array_Element; Global_Compilation_Elem : Array_Element; Global_Compilation_Switches : Variable_Value; Default_Switches_Array : Array_Id; Builder_Switches_Lang : Name_Id := No_Name; List : String_List_Id; Element : String_Element; Index : Name_Id; Source : GPR.Source_Id; Lang : Name_Id := No_Name; -- language index for Switches Switches_For_Lang : Variable_Value := Nil_Variable_Value; -- Value of Builder'Default_Switches(lang) Name : Name_Id := No_Name; -- main file index for Switches Switches_For_Main : Variable_Value := Nil_Variable_Value; -- Switches for a specific main. When there are several mains, Name is -- set to No_Name, and Switches_For_Main might be left with an actual -- value (so that we can display a warning that it was ignored). Other_Switches : Variable_Value := Nil_Variable_Value; -- Value of Builder'Switches(others) Defaults : Variable_Value := Nil_Variable_Value; Switches : Variable_Value := Nil_Variable_Value; -- The computed builder switches Success : Boolean := False; begin if Builder_Package /= No_Package then Global_Compilation_Array := Value_Of (Name => Name_Global_Compilation_Switches, In_Arrays => Project_Tree.Shared.Packages.Table (Builder_Package).Decl.Arrays, Shared => Project_Tree.Shared); if Main_Project.Qualifier = Aggregate or else Main_Project.Qualifier = Aggregate_Library then Other_Switches := GPR.Util.Value_Of (Name => All_Other_Names, Index => 0, Attribute_Or_Array_Name => Name_Switches, In_Package => Builder_Package, Shared => Project_Tree.Shared); else Mains.Reset; -- If there is no main, and there is only one compilable language, -- use this language as the switches index. if Mains.Number_Of_Mains (Project_Tree) = 0 then if Only_For_Lang = No_Name then declare Language : Language_Ptr := Main_Project.Languages; begin while Language /= No_Language_Index loop if Language.Config.Compiler_Driver not in No_File | Empty_File then if Lang /= No_Name then Lang := No_Name; exit; else Lang := Language.Name; end if; end if; Language := Language.Next; end loop; end; else Lang := Only_For_Lang; end if; else for Index in 1 .. Mains.Number_Of_Mains (Project_Tree) loop Source := Mains.Next_Main.Source; if Source /= No_Source then if Switches_For_Main = Nil_Variable_Value then Switches_For_Main := Value_Of (Name => Name_Id (Source.File), Attribute_Or_Array_Name => Name_Switches, In_Package => Builder_Package, Shared => Project_Tree.Shared, Force_Lower_Case_Index => False, Allow_Wildcards => True); -- If not found, try without extension. -- That's because gnatmake accepts truncated file -- names in Builder'Switches if Switches_For_Main = Nil_Variable_Value and then Source.Unit /= null then Switches_For_Main := Value_Of (Name => Source.Unit.Name, Attribute_Or_Array_Name => Name_Switches, In_Package => Builder_Package, Shared => Project_Tree.Shared, Force_Lower_Case_Index => False, Allow_Wildcards => True); end if; end if; if Index = 1 then Lang := Source.Language.Name; Name := Name_Id (Source.File); else Name := No_Name; -- Can't use main specific switches if Lang /= Source.Language.Name then Lang := No_Name; end if; end if; end if; end loop; end if; Default_Switches_Array := Project_Tree.Shared.Packages.Table (Builder_Package).Decl.Arrays; while Default_Switches_Array /= No_Array and then Project_Tree.Shared.Arrays.Table (Default_Switches_Array).Name /= Name_Default_Switches loop Default_Switches_Array := Project_Tree.Shared.Arrays.Table (Default_Switches_Array).Next; end loop; if Lang /= No_Name then Switches_For_Lang := GPR.Util.Value_Of (Name => Lang, Index => 0, Attribute_Or_Array_Name => Name_Switches, In_Package => Builder_Package, Shared => Project_Tree.Shared, Force_Lower_Case_Index => True); Defaults := GPR.Util.Value_Of (Name => Lang, Index => 0, Attribute_Or_Array_Name => Name_Default_Switches, In_Package => Builder_Package, Shared => Project_Tree.Shared, Force_Lower_Case_Index => True); end if; Other_Switches := GPR.Util.Value_Of (Name => All_Other_Names, Index => 0, Attribute_Or_Array_Name => Name_Switches, In_Package => Builder_Package, Shared => Project_Tree.Shared); if not Quiet_Output and then Mains.Number_Of_Mains (Project_Tree) > 1 and then Switches_For_Main /= Nil_Variable_Value then -- More than one main, but we had main-specific switches that -- are ignored. if Switches_For_Lang /= Nil_Variable_Value then Put_Line ("Warning: using Builder'Switches(""" & Get_Name_String_Safe (Lang) & """), as there are several mains"); elsif Other_Switches /= Nil_Variable_Value then Put_Line ("Warning: using Builder'Switches(others), " & "as there are several mains"); elsif Defaults /= Nil_Variable_Value then Put_Line ("Warning: using Builder'Default_Switches(""" & Get_Name_String_Safe (Lang) & """), as there are several mains"); else Put_Line ("Warning: using no switches from package " & "Builder, as there are several mains"); end if; end if; end if; Builder_Switches_Lang := Lang; if Name /= No_Name then -- Get the switches for the single main Switches := Switches_For_Main; end if; if Switches = Nil_Variable_Value or else Switches.Default then -- Get the switches for the common language of the mains Switches := Switches_For_Lang; end if; if Switches = Nil_Variable_Value or else Switches.Default then Switches := Other_Switches; end if; -- For backward compatibility with gnatmake, if no Switches -- are declared, check for Default_Switches (). if Switches = Nil_Variable_Value or else Switches.Default then Switches := Defaults; end if; -- If switches have been found, scan them if Switches /= Nil_Variable_Value and then not Switches.Default then List := Switches.Values; while List /= Nil_String loop Element := Project_Tree.Shared.String_Elements.Table (List); Get_Name_String (Element.Value); if Name_Len /= 0 then declare -- Add_Switch might itself be using the name_buffer, so -- we make a temporary here. Switch : constant String := Name_Buffer (1 .. Name_Len); begin Success := Add_Switch (Switch => Switch, For_Lang => Builder_Switches_Lang, For_Builder => True, Has_Global_Compilation_Switches => Global_Compilation_Array /= No_Array_Element); end; if not Success then for J in reverse 1 .. Name_Len loop Name_Buffer (J + J) := Name_Buffer (J); Name_Buffer (J + J - 1) := '''; end loop; Name_Len := Name_Len + Name_Len; GPR.Err.Error_Msg (Env.Flags, '"' & Name_Buffer (1 .. Name_Len) & """ is not a builder switch. Consider moving " & "it to Global_Compilation_Switches.", Element.Location); Fail_Program (Project_Tree, "*** illegal switch """ & Get_Name_String_Safe (Element.Value) & '"', Exit_Code => E_General); end if; end if; List := Element.Next; end loop; end if; -- Reset the Builder Switches language Builder_Switches_Lang := No_Name; -- Take into account attributes Global_Compilation_Switches while Global_Compilation_Array /= No_Array_Element loop Global_Compilation_Elem := Project_Tree.Shared.Array_Elements.Table (Global_Compilation_Array); Get_Name_String (Global_Compilation_Elem.Index); To_Lower (Name_Buffer (1 .. Name_Len)); Index := Name_Find; if Only_For_Lang = No_Name or else Index = Only_For_Lang then Global_Compilation_Switches := Global_Compilation_Elem.Value; if Global_Compilation_Switches /= Nil_Variable_Value and then not Global_Compilation_Switches.Default then -- We have found an attribute -- Global_Compilation_Switches for a language: put the -- switches in the appropriate table. List := Global_Compilation_Switches.Values; while List /= Nil_String loop Element := Project_Tree.Shared.String_Elements.Table (List); if Element.Value /= No_Name then Success := Add_Switch (Switch => Get_Name_String (Element.Value), For_Lang => Index, For_Builder => False, Has_Global_Compilation_Switches => Global_Compilation_Array /= No_Array_Element); end if; List := Element.Next; end loop; end if; end if; Global_Compilation_Array := Global_Compilation_Elem.Next; end loop; end if; end Compute_Builder_Switches; -------------- -- Unescape -- -------------- function Unescape (Path : String) return String is Result : String (Path'Range); Source : Natural := Path'First; Target : Integer := Path'First - 1; begin while Source <= Path'Last loop if Source < Path'Last and then Path (Source .. Source + 1) in "\\" | "\#" | "\ " | "\:" | "$$" then Source := Source + 1; end if; Target := Target + 1; Result (Target) := Path (Source); Source := Source + 1; end loop; return Result (Path'First .. Target); end Unescape; --------------------- -- Write_Path_File -- --------------------- procedure Write_Path_File (FD : File_Descriptor) is Last : Natural; Status : Boolean; begin Name_Len := 0; for Index in Directories.First .. Directories.Last loop Get_Name_String_And_Append (Directories.Table (Index)); Add_Char_To_Name_Buffer (ASCII.LF); end loop; Last := Write (FD, Name_Buffer (1)'Address, Name_Len); if Last = Name_Len then Close (FD, Status); else Status := False; end if; if not Status then GPR.Com.Fail ("could not write temporary file"); end if; end Write_Path_File; end Gpr_Build_Util; gprbuild-25.0.0/gpr/src/gpr_build_util.ads000066400000000000000000000532621470075373400205040ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2004-2022, Free Software Foundation, Inc. -- -- -- -- This library is free software; you can redistribute it and/or modify it -- -- under terms of the GNU General Public License as published by the Free -- -- Software Foundation; either version 3, or (at your option) any later -- -- version. This library is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package contains various subprograms used by the builders, in -- particular those subprograms related to project management and build -- queue management. with Ada.Containers.Vectors; with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.Table; with GPR; use GPR; with GPR.ALI; with GPR.Snames; use GPR.Snames; with GPR.Tree; with GPR.Util; use GPR.Util; package Gpr_Build_Util is Multi_Unit_Index_Character : constant Character := '~'; -- The character before the index of the unit in a multi-unit source in ALI -- and object file names. Root_Environment : GPR.Tree.Environment; -- The environment coming from environment variables and command line -- switches. When we do not have an aggregate project, this is used for -- parsing the project tree. When we have an aggregate project, this is -- used to parse the aggregate project; the latter then generates another -- environment (with additional external values and project path) to parse -- the aggregated projects. Source_Info_Option : constant String := "--source-info="; -- Switch to indicate the source info file Subdirs_Option : constant String := "--subdirs="; -- Switch used to indicate that the real directories (object, exec, -- library, ...) are subdirectories of those in the project file. Src_Subdirs_Option : constant String := "--src-subdirs="; -- Switch used to indicate that there may be subdirectories of source -- directories specified in the project file, overriding source files. Relocate_Build_Tree_Option : constant String := "--relocate-build-tree"; -- Switch to build out-of-tree. In this context the object, exec and -- library directories are relocated to the current working directory -- or the directory specified as parameter to this option. Implicit_With_Option : constant String := "--implicit-with="; -- Switch to add projects into with list for all projects in tree Root_Dir_Option : constant String := "--root-dir"; -- The root directory under which all artifacts (objects, library, ali) -- directory are to be found for the current compilation. This directory -- will be used to relocate artifacts based on this directory. If this -- option is not specificed the default value is the directory of the -- main project. Getrusage_Option : constant String := "--getrusage="; -- Option to set the file where the getrusage call results will be printed. -- Working only in Linux. Unchecked_Shared_Lib_Imports : constant String := "--unchecked-shared-lib-imports"; -- Command line switch to allow shared library projects to import projects -- that are not shared library projects. Single_Compile_Per_Obj_Dir_Switch : constant String := "--single-compile-per-obj-dir"; -- Switch to forbid simultaneous compilations for the same object directory -- when project files are used. Create_Map_File_Switch : constant String := "--create-map-file"; -- Switch to create a map file when an executable is linked No_Exit_Message_Option : constant String := "--no-exit-message"; -- Switch to suppress exit error message when there are compilation -- failures. This is useful when a tool, such as gnatprove, silently calls -- the builder and does not want to pollute its output with error messages -- coming from the builder. This is an internal switch. Keep_Temp_Files_Option : constant String := "--keep-temp-files"; -- Switch to suppress deletion of temp files created by the builder. -- Note that debug switch -gnatdn also has this effect. Autodetect_Jobserver_Option : constant String := "--autodetect-jobserver"; -- Switch to activate the autodetection of sharing job slots with GNU make. package Project_Vectors is new Ada.Containers.Vectors (Positive, Project_Id); package Source_Vectors is new Ada.Containers.Vectors (Positive, Source_Id); package Name_Vectors is new Ada.Containers.Vectors (Positive, Name_Id); package Directories is new GNAT.Table (Table_Component_Type => Path_Name_Type, Table_Index_Type => Integer, Table_Low_Bound => 1, Table_Initial => 200, Table_Increment => 100); -- Table of all the source or object directories, filled up by -- Get_Directories. procedure Add (Option : String_Access; To : in out String_List_Access; Last : in out Natural); procedure Add (Option : String; To : in out String_List_Access; Last : in out Natural); -- Add a string to a list of strings function Lib_File_Name (Source_File : File_Name_Type; Munit_Index : Nat := 0) return File_Name_Type; -- Returns the ALI file name for source Source_File with multi-unit index -- Munit_Index. function Create_Binder_Mapping_File (Project_Tree : Project_Tree_Ref) return Path_Name_Type; -- Create a binder mapping file and returns its path name function Base_Name_Index_For (Main : String; Main_Index : Int; Index_Separator : Character) return File_Name_Type; -- Returns the base name of Main, without the extension, followed by the -- Index_Separator followed by the Main_Index if it is non-zero. procedure Inform (N : Name_Id := No_Name; Msg : String); procedure Inform (N : File_Name_Type; Msg : String); -- Prints out the program name followed by a colon, N and S function Check_Source_Info_In_ALI (The_ALI : ALI.ALI_Id; Tree : Project_Tree_Ref) return Name_Id; -- Check whether all file references in ALI are still valid (i.e. the -- source files are still associated with the same units). Return the name -- of the unit if everything is still valid. Return No_Name otherwise. function Is_External_Assignment (Env : GPR.Tree.Environment; Argv : String) return Boolean; -- Verify that an external assignment switch is syntactically correct -- -- Correct forms are: -- -- -Xname=value -- -X"name=other value" -- -- Assumptions: 'First = 1, Argv (1 .. 2) = "-X" -- -- When this function returns True, the external assignment has been -- entered by a call to GPR.Ext.Add, so that in a project file, -- External ("name") will return "value". type Name_Ids is array (Positive range <>) of Name_Id; No_Names : constant Name_Ids := (1 .. 0 => No_Name); -- Name_Ids is used for list of language names in procedure Get_Directories -- below. Ada_Only : constant Name_Ids := (1 => Name_Ada); -- Used to invoke Get_Directories in gnatmake type Activity_Type is (Compilation, Executable_Binding, SAL_Binding); procedure Get_Directories (Project_Tree : Project_Tree_Ref; For_Project : Project_Id; Activity : Activity_Type; Languages : Name_Ids); -- Put in table Directories the source (when Sources is True) or -- object/library (when Sources is False) directories of project -- For_Project and of all the project it imports directly or indirectly. -- The source directories of imported projects are only included if one -- of the declared languages is in the list Languages. function Aggregate_Libraries_In (Tree : Project_Tree_Ref) return Boolean; -- Return True iff there is one or more aggregate library projects in -- the project tree Tree. procedure Write_Path_File (FD : File_Descriptor); -- Write in the specified open path file the directories in table -- Directories, then closed the path file. function Path_Or_File_Name (Path : Path_Name_Type) return String; -- Returns a file name if -df is used, otherwise return a path name function Is_Static (Project : Project_Id) return Boolean is (Project.Library_Kind in Static | Static_Pic); -- Return True if the library project correspond to a static library. function Unescape (Path : String) return String; -- Remove the character '\' if it is before ' ', '#', ':', or '\'. -- Remove the character '$' if it is before '$'. function Escape_Path (Path : String) return String; -- Escapes the characters '\', ' ' and '"' with character '\' before them procedure Add_Gpr_Tool_External; -- Add the GPR_TOOL external variable with default "gprbuild" -------------- -- Switches -- -------------- generic with function Add_Switch (Switch : String; For_Lang : Name_Id; For_Builder : Boolean; Has_Global_Compilation_Switches : Boolean) return Boolean; -- For_Builder is true if we have a builder switch. This function -- should return True in case of success (the switch is valid), -- False otherwise. The error message will be displayed by -- Compute_Builder_Switches itself. -- -- Has_Global_Compilation_Switches is True if the attribute -- Global_Compilation_Switches is defined in the project. procedure Compute_Builder_Switches (Project_Tree : Project_Tree_Ref; Env : GPR.Tree.Environment; Main_Project : Project_Id; Only_For_Lang : Name_Id := No_Name); -- Compute the builder switches and global compilation switches. Every time -- a switch is found in the project, it is passed to Add_Switch. You can -- provide a value for Only_For_Lang so that we only look for this language -- when parsing the global compilation switches. ----------------------- -- Project_Tree data -- ----------------------- -- The following types are specific to builders, and associated with each -- of the loaded project trees. type Binding_Data_Record; type Binding_Data is access Binding_Data_Record; type Binding_Data_Record is record Language : Language_Ptr; Language_Name : Name_Id; Binder_Driver_Name : File_Name_Type; Binder_Driver_Path : String_Access; Binder_Prefix : Name_Id; Next : Binding_Data; end record; -- Data for a language that have a binder driver type Builder_Project_Tree_Data is new Project_Tree_Appdata with record Binding : Binding_Data; There_Are_Binder_Drivers : Boolean := False; -- True when there is a binder driver. Set by Get_Configuration when -- an attribute Language_Processing'Binder_Driver is declared. -- Reset to False if there are no sources of the languages with binder -- drivers. Number_Of_Mains : Natural := 0; -- Number of main units in this project tree Closure_Needed : Boolean := False; -- If True, we need to add the closure of the file we just compiled to -- the queue. If False, it is assumed that all files are already on the -- queue so we do not waste time computing the closure. Need_Compilation : Boolean := True; Need_Binding : Boolean := True; Need_Linking : Boolean := True; -- Which of the compilation phases are needed for this project tree end record; type Builder_Data_Access is access all Builder_Project_Tree_Data; procedure Free (Data : in out Builder_Project_Tree_Data); -- Free all memory allocated for Data function Builder_Data (Tree : Project_Tree_Ref) return Builder_Data_Access; -- Return (allocate if needed) tree-specific data procedure Compute_Compilation_Phases (Tree : Project_Tree_Ref; Root_Project : Project_Id; Option_Unique_Compile : Boolean := False; -- Was "-u" specified ? Option_Compile_Only : Boolean := False; -- Was "-c" specified ? Option_Bind_Only : Boolean := False; Option_Link_Only : Boolean := False); -- Compute which compilation phases will be needed for Tree. This also does -- the computation for aggregated trees. This also check whether we'll need -- to check the closure of the files we have just compiled to add them to -- the queue. ----------- -- Mains -- ----------- -- Package Mains is used to store the mains specified on the command line -- and to retrieve them when a project file is used, to verify that the -- files exist and that they belong to a project file. -- Mains are stored in a table. An index is used to retrieve the mains -- from the table. type Main_Info is record File : File_Name_Type; -- Always canonical casing Index : Int := 0; Location : Source_Ptr := No_Location; Source : GPR.Source_Id := No_Source; Project : Project_Id; Tree : Project_Tree_Ref; Command : String_Vectors.Vector; end record; No_Main_Info : constant Main_Info := (No_File, 0, No_Location, No_Source, No_Project, null, String_Vectors.Empty_Vector); package Main_Info_Vectors is new Ada.Containers.Vectors (Positive, Main_Info); package Mains is procedure Add_Main (Name : String; Index : Int := 0; Location : Source_Ptr := No_Location; Project : Project_Id := No_Project; Tree : Project_Tree_Ref := null); -- Add one main to the table. This is in general used to add the main -- files specified on the command line. Index is used for multi-unit -- source files, and indicates which unit in the source is concerned. -- Location is the location within the project file (if a project file -- is used). Project and Tree indicate to which project the main should -- belong. In particular, for aggregate projects, this isn't necessarily -- the main project tree. These can be set to No_Project and null when -- not using projects. procedure Delete; -- Empty the table procedure Reset; -- Reset the cursor to the beginning of the table procedure Set_Multi_Unit_Index (Project_Tree : Project_Tree_Ref := null; Index : Int := 0); -- If a single main file was defined, this subprogram indicates which -- unit inside it is the main (case of a multi-unit source files). -- Errors are raised if zero or more than one main file was defined, -- and Index is non-zaero. This subprogram is used for the handling -- of the command line switch. function Next_Main return String; function Next_Main return Main_Info; -- Moves the cursor forward and returns the new current entry. Returns -- No_Main_Info there are no more mains in the table. function Number_Of_Mains (Tree : Project_Tree_Ref) return Natural; -- Returns the number of mains in this project tree (if Tree is null, it -- returns the total number of project trees) procedure Fill_From_Project (Root_Project : Project_Id; Project_Tree : Project_Tree_Ref); -- If no main was already added (presumably from the command line), add -- the main units from root_project (or in the case of an aggregate -- project from all the aggregated projects). procedure Complete_Mains (Flags : Processing_Flags; Root_Project : Project_Id; Project_Tree : Project_Tree_Ref; Unique_Compile : Boolean := False); -- If some main units were already added from the command line, check -- that they all belong to the root project, and that they are full -- paths rather than (partial) base names (e.g. no body suffix was -- specified). end Mains; ----------- -- Queue -- ----------- package Queue is -- The queue of sources to be checked for compilation. There can be a -- single such queue per application. type Source_Info is record Tree : Project_Tree_Ref := No_Project_Tree; Id : Source_Id := No_Source; Closure : Boolean := False; end record; -- Information about files stored in the queue No_Source_Info : constant Source_Info := (null, null, False); procedure Initialize (Queue_Per_Obj_Dir : Boolean; Force : Boolean := False); -- Initialize the queue -- -- Queue_Per_Obj_Dir matches the --single-compile-per-obj-dir switch: -- when True, there cannot be simultaneous compilations with the object -- files in the same object directory when project files are used. -- -- Nothing is done if Force is False and the queue was already -- initialized. function Is_Empty return Boolean; -- Returns True if the queue is empty function Is_Virtually_Empty return Boolean; -- Returns True if queue is empty or if all object directories are busy procedure Insert (Source : Source_Info; With_Roots : Boolean := False; Repeat : Boolean := False); function Insert (Source : Source_Info; With_Roots : Boolean := False; Repeat : Boolean := False) return Boolean; -- Insert source in the queue. The second version returns False if the -- Source was already marked in the queue. If With_Roots is True, this -- procedure also includes the "Roots" for this Source, ie all the other -- files that must be included in the library or binary (in particular -- to combine Ada and C files connected through pragma Export/Import). -- When the roots are computed, they are also stored in the -- corresponding Source_Id for later reuse by the binder. -- If Repeat is True source inserted into the queue even if it was -- alredy processed. procedure Insert_Project_Sources (Project : Project_Id; Project_Tree : Project_Tree_Ref; All_Projects : Boolean; Unique_Compile : Boolean); -- Insert all the compilable sources of the project in the queue. If -- All_Project is true, then all sources from imported projects are also -- inserted. Unique_Compile should be true if "-u" was specified on the -- command line: if True and some files were given on the command line), -- only those files will be compiled (so Insert_Project_Sources will do -- nothing). If True and no file was specified on the command line, all -- files of the project(s) will be compiled. This procedure also -- processed aggregated projects. procedure Insert_Withed_Sources_For (The_ALI : ALI.ALI_Id; Project_Tree : Project_Tree_Ref; Excluding_Shared_SALs : Boolean := False); -- Insert in the queue those sources withed by The_ALI, if there are not -- already in the queue and Only_Interfaces is False or they are part of -- the interfaces of their project. procedure Extract (Found : out Boolean; Source : out Source_Info); -- Get the first source that can be compiled from the queue. If no -- source may be compiled, sets Found to False. In this case, the value -- for Source is undefined. procedure Get (Found : out Boolean; Source : out Source_Info); -- Get the first source that can be compiled from the queue. If no -- source may be compiled, sets Found to False. In this case, the value -- for Source is undefined. -- The queue first index does not move until Next is called. procedure Next; -- Move the first index of the queue to the next source function Size return Natural; -- Return the total size of the queue, including the sources already -- extracted. function Processed return Natural; -- Return the number of sources in the queue that have already been -- processed. procedure Set_Obj_Dir_Busy (Obj_Dir : Path_Name_Type); procedure Set_Obj_Dir_Free (Obj_Dir : Path_Name_Type); -- Mark Obj_Dir as busy or free (see the parameter to Initialize) function Element (Rank : Positive) return File_Name_Type; -- Get the file name for element of index Rank in the queue end Queue; end Gpr_Build_Util; gprbuild-25.0.0/gpr/src/gpr_imports.c000066400000000000000000000107271470075373400175170ustar00rootroot00000000000000/**************************************************************************** * * * GPR TECHNOLOGY * * * * Copyright (C) 1992-2021, Free Software Foundation, Inc. * * * * This library is free software; you can redistribute it and/or modify it * * under terms of the GNU General Public License as published by the Free * * Software Foundation; either version 3, or (at your option) any later * * version. This library is distributed in the hope that it will be useful, * * but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- * * TABILITY or FITNESS FOR A PARTICULAR PURPOSE. * * * * As a special exception under Section 7 of GPL version 3, you are granted * * additional permissions described in the GCC Runtime Library Exception, * * version 3.1, as published by the Free Software Foundation. * * * * You should have received a copy of the GNU General Public License and * * a copy of the GCC Runtime Library Exception along with this program; * * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see * * . * * * ****************************************************************************/ #ifdef __cplusplus extern "C" { #endif #define _FILE_OFFSET_BITS 64 /* Defines that 64 bit file system interface shall be used in stat call below * even if it happens in 32 bit OS */ #ifdef IN_GCC #include "auto-host.h" #endif #include /* link_max is a conservative system specific threshold (in bytes) of the */ /* argument length passed to the linker which will trigger a file being */ /* used instead of the command line directly. */ /* shared_libgcc_default gives the system dependent link method that */ /* be used by default for linking libgcc (shared or static) */ /* default_libgcc_subdir is the subdirectory name (from the installation */ /* root) where we may find a shared libgcc to use by default. */ #define SHARED 'H' #define STATIC 'T' #if defined (__WIN32) int __gnat_link_max = 30000; char __gnat_shared_libgcc_default = STATIC; const char *__gnat_default_libgcc_subdir = "lib"; #elif defined (__hpux__) int __gnat_link_max = 5000; char __gnat_shared_libgcc_default = STATIC; const char *__gnat_default_libgcc_subdir = "lib"; #elif defined (__FreeBSD__) int __gnat_link_max = 8192; char __gnat_shared_libgcc_default = STATIC; const char *__gnat_default_libgcc_subdir = "lib"; #elif defined (__APPLE__) int __gnat_link_max = 262144; char __gnat_shared_libgcc_default = SHARED; const char *__gnat_default_libgcc_subdir = "lib"; #elif defined (linux) || defined(__GLIBC__) int __gnat_link_max = 8192; char __gnat_shared_libgcc_default = STATIC; #if defined (__x86_64) # if defined (__LP64__) const char *__gnat_default_libgcc_subdir = "lib64"; # else const char *__gnat_default_libgcc_subdir = "libx32"; # endif #else const char *__gnat_default_libgcc_subdir = "lib"; #endif #elif defined (_AIX) int __gnat_link_max = 15000; char __gnat_shared_libgcc_default = STATIC; const char *__gnat_default_libgcc_subdir = "lib"; #elif (HAVE_GNU_LD) int __gnat_link_max = 8192; char __gnat_shared_libgcc_default = STATIC; const char *__gnat_default_libgcc_subdir = "lib"; #elif defined (sun) int __gnat_link_max = 2147483647; char __gnat_shared_libgcc_default = STATIC; #if defined (__sparc_v9__) || defined (__sparcv9) const char *__gnat_default_libgcc_subdir = "lib/sparcv9"; #elif defined (__x86_64) const char *__gnat_default_libgcc_subdir = "lib/amd64"; #else const char *__gnat_default_libgcc_subdir = "lib"; #endif #elif defined (__svr4__) && defined (i386) int __gnat_link_max = 2147483647; char __gnat_shared_libgcc_default = STATIC; const char *__gnat_default_libgcc_subdir = "lib"; #else int __gnat_link_max = 2147483647; char __gnat_shared_libgcc_default = STATIC; const char *__gnat_default_libgcc_subdir = "lib"; #endif #ifdef __cplusplus } #endif gprbuild-25.0.0/gprbuild.gpr000066400000000000000000000136101470075373400157430ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2004-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ with "xmlada.gpr"; with "gpr/gpr.gpr"; project Gprbuild is type Build_Type is ("debug", "production", "coverage", "profiling"); Bld : Build_Type := external ("GPRBUILD_BUILD", external ("BUILD", "debug")); type Target_type is ("Windows_NT", "UNIX"); Target : Target_Type := external ("OS", "UNIX"); type Install_Mode_Type is ("all", "nointernal", "internal"); Install_Mode : Install_Mode_Type := external ("INSTALL_MODE", "all"); Processors := external ("PROCESSORS", "0"); for Languages use ("Ada"); Main_Bin := ("gprconfig-main.adb", "gprbuild-main.adb", "gprclean-main.adb", "gprinstall-main.adb", "gprslave.adb", "gprname-main.adb", "gprls-main.adb"); Main_Libexec := ("gprbind.adb", "gprlib.adb"); case Install_Mode is when "all" => for Main use Main_Bin & Main_Libexec; when "nointernal" => for Main use Main_Bin; when "internal" => for Main use Main_Libexec; end case; for Source_Dirs use ("src"); for Object_Dir use "obj/" & Bld; for Exec_Dir use "exe/" & Bld; ------------- -- Builder -- ------------- package Builder is for Executable ("gprconfig-main.adb") use "gprconfig"; for Executable ("gprbuild-main.adb") use "gprbuild"; for Executable ("gprclean-main.adb") use "gprclean"; for Executable ("gprinstall-main.adb") use "gprinstall"; for Executable ("gprls-main.adb") use "gprls"; for Executable ("gprname-main.adb") use "gprname"; for Default_Switches ("Ada") use ("-s", "-m", "-j" & Processors); end Builder; -------------- -- Compiler -- -------------- package Compiler is Common_Switches := ("-gnat2020", "-gnaty", "-gnatQ", "-gnata", "-gnateE"); case Bld is when "debug" => for Default_Switches ("Ada") use Common_Switches & ("-g", "-gnatVa", "-gnatwaCJI", "-gnatwe", "-gnatyg"); for Local_Configuration_Pragmas use "debug.adc"; when "coverage" => for Default_Switches ("Ada") use Common_Switches & ("-ftest-coverage", "-fprofile-arcs"); when "profiling" => for Default_Switches ("Ada") use Common_Switches & ("-pg", "-g"); when "production" => for Default_Switches ("Ada") use Common_Switches & ("-O2", "-gnatn", "-gnatws"); -- Compile all GPRbuild sources to support symbolic-traceback for Switches ("gpr*.ad?") use Compiler'Default_Switches ("Ada") & ("-g1"); end case; end Compiler; ------------ -- Binder -- ------------ package Binder is Common_Switches := ("-Es", "-static"); case Bld is when "debug" => for Default_Switches ("Ada") use Common_Switches & ("-Sin"); when "coverage" | "profiling" | "production" => for Default_Switches ("Ada") use Common_Switches; end case; end Binder; ------------ -- Linker -- ------------ package Linker is case Bld is when "production" => null; when "debug" => for Default_Switches ("Ada") use ("-g"); when "coverage" => for Default_Switches ("Ada") use ("-lgcov"); when "profiling" => for Default_Switches ("Ada") use ("-pg", "-g"); end case; end Linker; ------------- -- Install -- ------------- package Install is case Install_Mode is when "all" | "nointernal" => for Artifacts ("share/examples/gprbuild") use ("examples/*"); for Artifacts ("share/doc/gprbuild/txt") use ("doc/txt/*.txt"); for Artifacts ("share/doc/gprbuild/info") use ("doc/info/*.info"); for Artifacts ("share/doc/gprbuild/pdf") use ("doc/pdf/*.pdf"); for Artifacts ("share/doc/gprbuild") use ("doc/html"); for Artifacts ("share") use ("share/gprconfig"); for Artifacts ("share/gpr") use ("share/_default.gpr"); case Target is when "Windows_NT" => for Artifacts ("bin") use ("src/gprinstall.exe.manifest"); when "UNIX" => for Artifacts (".") use ("doinstall"); end case; when "internal" => for Exec_Subdir use "libexec/gprbuild"; end case; end Install; --------- -- IDE -- --------- package IDE is for VCS_Kind use "Git"; end IDE; end Gprbuild; gprbuild-25.0.0/share/000077500000000000000000000000001470075373400145225ustar00rootroot00000000000000gprbuild-25.0.0/share/_default.gpr000066400000000000000000000000511470075373400170130ustar00rootroot00000000000000standard project Default is end Default; gprbuild-25.0.0/share/share.gpr000066400000000000000000000001431470075373400163340ustar00rootroot00000000000000project Share is for Languages use ("XML"); for Source_Dirs use ("gprconfig"); end Share; gprbuild-25.0.0/src/000077500000000000000000000000001470075373400142075ustar00rootroot00000000000000gprbuild-25.0.0/src/create_ada_runtime_project.adb000066400000000000000000000305701470075373400222250ustar00rootroot00000000000000------------------------------------------------------------------------------ -- GNAT SYSTEM UTILITIES -- -- -- -- C R E A T E _ A D A _ R U N T I M E _ P R O J E C T -- -- -- -- B o d y -- -- -- -- Copyright (C) 2006-2012, Free Software Foundation, Inc. -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- -- License for more details. You should have received a copy of the GNU -- -- General Public License distributed with this software; see file -- -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- -- of the license. -- ------------------------------------------------------------------------------ -- This utility creates the Ada runtime project file ada_runtime.gpr -- This project file resides in the parent directory of adainclude (the source -- directory) and adalib (the object directory). It is "externally built". Its -- package Naming gives the mapping of the source file names to unit names. with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with GNAT.Command_Line; use GNAT.Command_Line; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.HTable; use GNAT.HTable; procedure Create_Ada_Runtime_Project is Err : exception; -- Raised to terminate execution Project_File : Ada.Text_IO.File_Type; -- The project file being created Adainclude : String_Access := new String'("adainclude"); -- The path name of the adainclude directory, given as argument of the -- utility. Dir : Dir_Type; Str : String (1 .. 1_000); Last : Natural; Gcc : constant String := "gcc"; Gcc_Path : String_Access; Args : Argument_List (1 .. 6) := (1 => new String'("-c"), 2 => new String'("-gnats"), 3 => new String'("-gnatu"), 4 => new String'("-x"), 5 => new String'("ada"), 6 => null); -- The arguments used when invoking the Ada compiler to get the name and -- kind (spec or body) of the unit contained in a source file. Success : Boolean; Return_Code : Integer; Mapping_File_Name : String_Access := new String'("gnat_runtime.mapping"); -- Location of the default mapping file. Output_File : String_Access := new String'("ada_runtime.gpr"); -- Name of the final project file being created Output_File_Name : constant String := "output.txt"; Output : Ada.Text_IO.File_Type; -- The text file where the output of the compiler invocation is stored. -- This is temporary output from gcc Line : String (1 .. 1_000); Line_Last : Natural; Spec : Boolean; Verbose_Mode : Boolean := False; -- True if switch -v is used subtype Header_Num is Natural range 0 .. 4095; function Hash (Key : String_Access) return Header_Num; function Equal (K1, K2 : String_Access) return Boolean; type Element is record Spec : Boolean := False; Unit : String_Access := null; end record; No_Element : constant Element := (False, null); package Mapping is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, Element => Element, No_Element => No_Element, Key => String_Access, Hash => Hash, Equal => Equal); -- A hash table to keep the mapping of source file names to unit names -- found in file gnat_runtime.mapping. Key : String_Access; Elem : Element; function Hash is new GNAT.HTable.Hash (Header_Num); procedure Get_Mapping (Mapping_File : String); -- Read file mapping file to get the mapping of source file names -- to unit names and populate hash table Mapping. -- If the file doesn't exist, nothing is done, but -- Create_Ada_Runtime_Project will execute more slowly procedure Fail (S : String); -- Outputs S to Standard_Error, followed by a newline and then raises the -- exception Err. procedure Help; -- Display help on using this application ----------- -- Equal -- ----------- function Equal (K1, K2 : String_Access) return Boolean is begin if K1 = null or else K2 = null then return K1 = K2; else return K1.all = K2.all; end if; end Equal; ---------- -- Fail -- ---------- procedure Fail (S : String) is begin Put_Line (Standard_Error, S); raise Err; end Fail; ----------------- -- Get_Mapping -- ----------------- procedure Get_Mapping (Mapping_File : String) is File : File_Type; Line : String (1 .. 1_000); Last : Natural; begin Open (File, In_File, Mapping_File); while not End_Of_File (File) loop Get_Line (File, Line, Last); -- Skip the line if it is a comment line if Last > 2 and then Line (1 .. 2) /= "--" then Key := new String'(Line (1 .. Last)); Get_Line (File, Line, Last); Elem.Spec := Line (1 .. Last) = "spec"; Get_Line (File, Line, Last); Elem.Unit := new String'(Line (1 .. Last)); Mapping.Set (Key, Elem); end if; end loop; Close (File); exception when others => if Is_Open (File) then Close (File); end if; if Verbose_Mode then Put_Line (Standard_Error, "Could not read " & Mapping_File); end if; end Get_Mapping; ---------- -- Hash -- ---------- function Hash (Key : String_Access) return Header_Num is begin if Key = null then return 0; else return Hash (Key.all); end if; end Hash; ---------- -- Help -- ---------- procedure Help is begin Put_Line (" -adainclude : Location of the adainclude directory"); Put_Line (" -mapping : Location of the pre-built mapping file"); Put_Line (" -o : Output file name"); Put_Line (" -v : Verbose mode"); Put_Line (" Default is " & Output_File.all); end Help; -- Start of processing for Create_Ada_Runtime_Project begin -- The utility needs to be invoked with only one argument: the path name -- of the adainclude directory. loop case Getopt ("adainclude: o: mapping: h v") is when 'a' => Free (Adainclude); Adainclude := new String'(Parameter); when 'm' => Free (Mapping_File_Name); Mapping_File_Name := new String'(Parameter); when 'o' => Free (Output_File); Output_File := new String'(Parameter); when 'h' => Help; return; when 'v' => Verbose_Mode := True; when others => exit; end case; end loop; Gcc_Path := Locate_Exec_On_Path (Gcc); if Gcc_Path = null then Fail ("cannot find " & Gcc); end if; Get_Mapping (Mapping_File_Name.all); -- Change the working directory to the adainclude directory begin Change_Dir (Adainclude.all); exception when Directory_Error => Fail ("cannot find adainclude directory " & Adainclude.all); end; -- Create the project file in the parent directory of adainclude Create (Project_File, Out_File, Output_File.all); -- Put the first lines that are always the same Put_Line (Project_File, "project Ada_Runtime is"); New_Line (Project_File); Put_Line (Project_File, " for Languages use (""Ada"");"); Put_Line (Project_File, " for Source_Dirs use (""" & Adainclude.all & """);"); Put_Line (Project_File, " for Object_Dir use """ & Adainclude.all & ".." & Directory_Separator & "adalib"";"); New_Line (Project_File); Put_Line (Project_File, " for Externally_Built use ""true"";"); New_Line (Project_File); Put_Line (Project_File, " package Naming is"); Open (Dir, "."); -- For each regular file in the adainclude directory, invoke the compiler -- to get the unit name. loop Read (Dir, Str, Last); exit when Last = 0; if Is_Regular_File (Str (1 .. Last)) then Key := new String'(Str (1 .. Last)); Elem := Mapping.Get (Key); -- Mapping found in hash table if Elem /= No_Element then if To_Lower (Elem.Unit.all) /= Str (1 .. Last - 4) then Put (Project_File, " for "); if Elem.Spec then Put (Project_File, "Spec ("""); else Put (Project_File, "Body ("""); end if; Put (Project_File, Elem.Unit.all); Put (Project_File, """) use """); Put (Project_File, Str (1 .. Last)); Put_Line (Project_File, """;"); end if; -- Case where Mapping.Get returned no element: use the compiler -- to get the unit name. else Args (Args'Last) := new String'(Str (1 .. Last)); if Verbose_Mode then Put (Gcc_Path.all); for J in Args'Range loop Put (' ' & Args (J).all); end loop; New_Line; end if; Spawn (Gcc_Path.all, Args, Output_File_Name, Success, Return_Code); if Success then Open (Output, In_File, Output_File_Name); if not End_Of_File (Output) then Get_Line (Output, Line, Line_Last); -- Find the first closing parenthesis Char_Loop : for J in 1 .. Line_Last loop if Line (J) = ')' then if J >= 13 and then Line (1 .. 4) = "Unit" then -- No need for a spec or body declaration if the -- file name is as expected. if To_Lower (Line (6 .. J - 7)) /= Str (1 .. Last - 4) then Spec := Line (J - 5 .. J) = "(spec)"; Put (Project_File, " for "); if Spec then Put (Project_File, "Spec ("""); else Put (Project_File, "Body ("""); end if; Put (Project_File, Line (6 .. J - 7)); Put (Project_File, """) use """); Put (Project_File, Str (1 .. Last)); Put_Line (Project_File, """;"); end if; end if; exit Char_Loop; end if; end loop Char_Loop; end if; Close (Output); end if; end if; end if; end loop; -- Put the closing lines and close the project file Put_Line (Project_File, " end Naming;"); New_Line (Project_File); Put_Line (Project_File, "end Ada_Runtime;"); Close (Project_File); -- Clean up: delete the output file Delete_File (Output_File_Name, Success); exception when Invalid_Switch | Invalid_Parameter => Put_Line ("Invalid switch: " & Full_Switch); Help; when Err => Set_Exit_Status (1); when others => Put_Line ("unexpected exception"); raise; end Create_Ada_Runtime_Project; gprbuild-25.0.0/src/gprbind.adb000066400000000000000000001246251470075373400163160ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2006-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ -- gprbind is the executable called by gprbuild to bind Ada sources. It is -- the driver for gnatbind. It gets its input from gprbuild through the -- binding exchange file and gives back its results through the same file. with Ada.Command_Line; use Ada.Command_Line; with Ada.Containers.Indefinite_Vectors; with Ada.Directories; with Ada.Text_IO; use Ada.Text_IO; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.OS_Lib; use GNAT.OS_Lib; with Gprexch; use Gprexch; with GPR.Script; use GPR, GPR.Script; with GPR.ALI; use GPR.ALI; with GPR.Names; use GPR.Names; with GPR.Osint; use GPR.Osint; with GPR.Tempdir; with GPR.Util; use GPR.Util; procedure Gprbind is Executable_Suffix : constant String_Access := Get_Executable_Suffix; -- The suffix of executables on this platforms GNATBIND : String_Access := new String'("gnatbind"); -- The file name of the gnatbind executable. May be modified by an option -- in the Minimum_Binder_Options. Gnatbind_Prefix_Equal : constant String := "gnatbind_prefix="; -- Start of the option to specify a prefix for the gnatbind executable Gnatbind_Path_Equal : constant String := "--gnatbind_path="; -- Start of the option to specify the absolute path of gnatbind Ada_Binder_Equal : constant String := "ada_binder="; -- Start of the option to specify the full name of the Ada binder -- executable. Introduced for GNAAMP, where it is gnaambind. Quiet_Output : Boolean := False; Verbose_Low_Mode : Boolean := False; Verbose_Higher_Mode : Boolean := False; Dash_O_Specified : Boolean := False; Dash_O_File_Specified : Boolean := False; There_Are_Stand_Alone_Libraries : Boolean := False; -- Set to True if the corresponding label is in the exchange file No_Main_Option : constant String := "-n"; Dash_o : constant String := "-o"; Dash_x : constant String := "-x"; Dash_Fequal : constant String := "-F="; Dash_OO : constant String := "-O"; -- Minimum switches to be used to compile the binder generated file Dash_c : constant String := "-c"; Dash_gnatA : constant String := "-gnatA"; Dash_gnatWb : constant String := "-gnatWb"; Dash_gnatiw : constant String := "-gnatiw"; Dash_gnatws : constant String := "-gnatws"; IO_File : File_Type; -- The file to get the inputs and to put the results of the binding Line : String (1 .. 1_000); Last : Natural; Exchange_File_Name : String_Access; Ada_Compiler_Path : String_Access; FULL_GNATBIND : String_Access; Gnatbind_Path : String_Access; Gnatbind_Path_Specified : Boolean := False; Compiler_Options : String_Vectors.Vector; Compiler_Trailing_Options : String_Vectors.Vector; Gnatbind_Options : String_Vectors.Vector; Main_ALI : String_Access := null; Main_Base_Name : String_Access := null; Binder_Generated_File : String_Access := null; BG_File : File_Type; Mapping_File : String_Access := null; Success : Boolean := False; Return_Code : Integer; Adalib_Dir : String_Access; Prefix_Path : String_Access; Lib_Path : String_Access; Static_Libs : Boolean := True; Current_Section : Binding_Section := No_Binding_Section; All_Binding_Options : Boolean; Get_Option : Boolean; Xlinker_Seen : Boolean; Stack_Equal_Seen : Boolean; GNAT_Version : String_Access := new String'("000"); -- The version of GNAT, coming from the Toolchain_Version for Ada GNAT_Version_First_2 : String (1 .. 2); GNAT_Version_Set : Boolean := False; -- True when the toolchain version is in the input exchange file Delete_Temp_Files : Boolean := True; FD_Objects : File_Descriptor; Objects_Path : Path_Name_Type; Objects_File : File_Type; Ada_Object_Suffix : String_Access := Get_Object_Suffix; Display_Line : String_Access := new String (1 .. 1_000); Display_Last : Natural := 0; -- A String buffer to store temporarily the displayed gnatbind command -- invoked by gprbind. procedure Add_To_Display_Line (S : String); -- Add an argument to the Display_Line procedure Output_Lib_Path_Or_Line (Lib_Name : String); -- Output to IO_File full library pathname to the Other_Arguments if found -- in Prefix_Path, Output Line (1 .. Last) otherwise. Binding_Options_Table : String_Vectors.Vector; Binding_Option_Dash_V_Specified : Boolean := False; -- Set to True if -v is specified in the binding options GNAT_6_Or_Higher : Boolean := False; -- Set to True when GNAT version is neither 3.xx nor 5.xx GNAT_6_4_Or_Higher : Boolean := False; -- Set to True when GNAT_6_Or_Higher is True and if GNAT version is 6.xy -- with x >= 4. ALI_Files_Table : String_Vectors.Vector; type Path_And_Stamp (Path_Len, Stamp_Len : Natural) is record Path : String (1 .. Path_Len); Stamp : String (1 .. Stamp_Len); end record; package PS_Vectors is new Ada.Containers.Indefinite_Vectors (Positive, Path_And_Stamp); Project_Paths : PS_Vectors.Vector; type Bound_File; type Bound_File_Access is access Bound_File; type Bound_File is record Name : String_Access; Next : Bound_File_Access; end record; Bound_Files : Bound_File_Access; ------------------------- -- Add_To_Display_Line -- ------------------------- procedure Add_To_Display_Line (S : String) is begin while Display_Last + 1 + S'Length > Display_Line'Last loop declare New_Buffer : constant String_Access := new String (1 .. 2 * Display_Line'Length); begin New_Buffer (1 .. Display_Last) := Display_Line (1 .. Display_Last); Free (Display_Line); Display_Line := New_Buffer; end; end loop; if Display_Last > 0 then Display_Last := Display_Last + 1; Display_Line (Display_Last) := ' '; end if; Display_Line (Display_Last + 1 .. Display_Last + S'Length) := S; Display_Last := Display_Last + S'Length; end Add_To_Display_Line; ----------------------------- -- Output_Lib_Path_Or_Line -- ----------------------------- procedure Output_Lib_Path_Or_Line (Lib_Name : String) is begin Lib_Path := Locate_Regular_File (Lib_Name, Prefix_Path.all); if Lib_Path /= null then Put_Line (IO_File, Lib_Path.all); Free (Lib_Path); else Put_Line (IO_File, Line (1 .. Last)); end if; end Output_Lib_Path_Or_Line; begin Set_Program_Name ("gprbind"); -- As the section header has alreading been displayed when gprlib was -- invoked, indicate that it should not be displayed again. GPR.Set (Section => GPR.Bind); if Argument_Count /= 1 then Fail_Program (null, "incorrect invocation"); end if; Exchange_File_Name := new String'(Argument (1)); -- DEBUG: save a copy of the exchange file declare Gprbind_Debug : constant String := Getenv ("GPRBIND_DEBUG").all; begin if Gprbind_Debug = "TRUE" then Copy_File (Exchange_File_Name.all, Exchange_File_Name.all & "__saved", Success, Mode => Overwrite, Preserve => Time_Stamps); end if; end; -- Open the binding exchange file begin Open (IO_File, In_File, Exchange_File_Name.all); exception when others => Fail_Program (null, "could not read " & Exchange_File_Name.all); end; -- Get the information from the binding exchange file while not End_Of_File (IO_File) loop Get_Line (IO_File, Line, Last); if Last > 0 then if Line (1) = '[' then Current_Section := Get_Binding_Section (Line (1 .. Last)); case Current_Section is when No_Binding_Section => Fail_Program (null, "unknown section: " & Line (1 .. Last)); when Quiet => Quiet_Output := True; Verbose_Low_Mode := False; Verbose_Higher_Mode := False; when Verbose_Low => Quiet_Output := False; Verbose_Low_Mode := True; Verbose_Higher_Mode := False; when Verbose_Higher => Quiet_Output := False; Verbose_Low_Mode := True; Verbose_Higher_Mode := True; when Shared_Libs => Static_Libs := False; when Gprexch.There_Are_Stand_Alone_Libraries => There_Are_Stand_Alone_Libraries := True; when others => null; end case; else case Current_Section is when No_Binding_Section => Fail_Program (null, "no section specified: " & Line (1 .. Last)); when Quiet => Fail_Program (null, "quiet section should be empty"); when Verbose_Low | Verbose_Higher => Fail_Program (null, "verbose section should be empty"); when Shared_Libs => Fail_Program (null, "shared libs section should be empty"); when Gprexch.There_Are_Stand_Alone_Libraries => Fail_Program (null, "stand-alone libraries section should be empty"); when Gprexch.Main_Base_Name => if Main_Base_Name /= null then Fail_Program (null, "main base name specified multiple times"); end if; Main_Base_Name := new String'(Line (1 .. Last)); when Gprexch.Mapping_File => Mapping_File := new String'(Line (1 .. Last)); when Compiler_Path => if Ada_Compiler_Path /= null then Fail_Program (null, "compiler path specified multiple times"); end if; Ada_Compiler_Path := new String'(Line (1 .. Last)); when Compiler_Leading_Switches => Compiler_Options.Append (Line (1 .. Last)); when Compiler_Trailing_Switches => Compiler_Trailing_Options.Append (Line (1 .. Last)); when Main_Dependency_File => if Main_ALI /= null then Fail_Program (null, "main ALI file specified multiple times"); end if; Main_ALI := new String'(Line (1 .. Last)); when Dependency_Files => ALI_Files_Table.Append (Line (1 .. Last)); when Binding_Options => -- Check if a gnatbind absolute is specified if Last > Gnatbind_Path_Equal'Length and then Line (1 .. Gnatbind_Path_Equal'Length) = Gnatbind_Path_Equal then Gnatbind_Path := new String' (Line (Gnatbind_Path_Equal'Length + 1 .. Last)); Gnatbind_Path_Specified := True; -- Check if a gnatbind prefix is specified elsif Starts_With (Line (1 .. Last), Gnatbind_Prefix_Equal) then -- Ignore an empty prefix if Last > Gnatbind_Prefix_Equal'Length then -- There is always a '-' between and -- "gnatbind". Add one if not already in . if Line (Last) /= '-' then Last := Last + 1; Line (Last) := '-'; end if; GNATBIND := new String' (Line (Gnatbind_Prefix_Equal'Length + 1 .. Last) & "gnatbind"); end if; elsif Last > Ada_Binder_Equal'Length and then Line (1 .. Ada_Binder_Equal'Length) = Ada_Binder_Equal then GNATBIND := new String' (Line (Ada_Binder_Equal'Length + 1 .. Last)); -- When -O is used, instead of -O=file, -v is ignored to -- avoid polluting the output. Record occurence of -v and -- check the GNAT version later. elsif Line (1 .. Last) = "-v" then Binding_Option_Dash_V_Specified := True; -- Ignore -C, as the generated sources are always in Ada elsif Line (1 .. Last) /= "-C" then Binding_Options_Table.Append (Line (1 .. Last)); end if; when Project_Files => if End_Of_File (IO_File) then Fail_Program (null, "no time stamp for " & Line (1 .. Last)); else declare Path : constant String := Line (1 .. Last); begin Get_Line (IO_File, Line, Last); Project_Paths.Append (Path_And_Stamp' (Path_Len => Path'Length, Stamp_Len => Last, Path => Path, Stamp => Line (1 .. Last))); end; end if; when Gprexch.Toolchain_Version => if End_Of_File (IO_File) then Fail_Program (null, "no toolchain version for language " & Line (1 .. Last)); elsif Line (1 .. Last) = "ada" then Get_Line (IO_File, Line, Last); if Last > 5 and then Line (1 .. 5) = GNAT_And_Space then GNAT_Version := new String'(Line (6 .. Last)); GNAT_Version_Set := True; GNAT_Version_First_2 := (if Last = 6 then Line (6) & ' ' else Line (6 .. 7)); end if; else Skip_Line (IO_File); end if; when Gprexch.Delete_Temp_Files => begin Delete_Temp_Files := Boolean'Value (Line (1 .. Last)); exception when Constraint_Error => null; end; when Gprexch.Object_File_Suffix => if End_Of_File (IO_File) then Fail_Program (null, "no object file suffix for language " & Line (1 .. Last)); elsif Line (1 .. Last) = "ada" then Get_Line (IO_File, Line, Last); Ada_Object_Suffix := new String'(Line (1 .. Last)); else Skip_Line (IO_File); end if; when Script_Path => Build_Script_Name := new String'(Line (1 .. Last)); when Nothing_To_Bind | Generated_Object_File | Generated_Source_Files | Bound_Object_Files | Resulting_Options | Run_Path_Option => null; end case; end if; end if; end loop; if Main_Base_Name = null then Fail_Program (null, "no main base name specified"); else Binder_Generated_File := new String'("b__" & Main_Base_Name.all & ".adb"); end if; Close (IO_File); -- Modify binding option -A= if is not an absolute path if not Project_Paths.Is_Empty then declare Project_Dir : constant String := Ada.Directories.Containing_Directory (Project_Paths.First_Element.Path); begin for J in 1 .. Binding_Options_Table.Last_Index loop if Binding_Options_Table.Element (J)'Length >= 4 and then Binding_Options_Table (J) (1 .. 3) = "-A=" then declare Value : constant String := Binding_Options_Table.Element (J); File : constant String := Value (4 .. Value'Last); begin if not Is_Absolute_Path (File) then declare New_File : constant String := Normalize_Pathname (File, Project_Dir, Resolve_Links => False); begin Binding_Options_Table.Replace_Element (J, "-A=" & New_File); end; end if; end; end if; end loop; end; end if; -- Check if GNAT version is 6.4 or higher if GNAT_Version_Set and then GNAT_Version.all /= "000" and then GNAT_Version_First_2 not in "3." | "5." then GNAT_6_Or_Higher := True; if GNAT_Version_First_2 /= "6." or else GNAT_Version.all >= "6.4" then GNAT_6_4_Or_Higher := True; end if; end if; -- Check if binding option -v was specified and issue it only if the GNAT -- version is 6.4 or higher, otherwise the output of gnatbind -O will be -- polluted. if Binding_Option_Dash_V_Specified and then GNAT_6_4_Or_Higher then Binding_Options_Table.Append ("-v"); end if; if not Static_Libs then Gnatbind_Options.Append (Dash_Shared); end if; -- Specify the name of the generated file to gnatbind Gnatbind_Options.Append (Dash_o); Gnatbind_Options.Append (Binder_Generated_File.all); if Ada_Compiler_Path = null then Fail_Program (null, "no Ada compiler path specified"); elsif not Is_Regular_File (Ada_Compiler_Path.all) then Fail_Program (null, "could not find the Ada compiler"); end if; if Main_ALI /= null then Gnatbind_Options.Append (Main_ALI.all); end if; -- If there are Stand-Alone Libraries, invoke gnatbind with -F (generate -- checks of elaboration flags) to avoid multiple elaborations. if There_Are_Stand_Alone_Libraries and then GNAT_Version_Set and then GNAT_Version_First_2 /= "3." then Gnatbind_Options.Append ("-F"); end if; Gnatbind_Options.Append_Vector (ALI_Files_Table); for Option of Binding_Options_Table loop Gnatbind_Options.Append (Option); if Option = Dash_OO then Dash_O_Specified := True; elsif Starts_With (Option, Dash_OO & '=') then Dash_O_Specified := True; Dash_O_File_Specified := True; Objects_Path := Get_Path_Name_Id (Option (4 .. Option'Last)); end if; end loop; -- Add -x at the end, so that if -s is specified in the binding options, -- gnatbind does not try to look for sources, as the binder mapping file -- specified by -F- is not for sources, but for ALI files. Gnatbind_Options.Append (Dash_x); if Is_Absolute_Path (GNATBIND.all) then FULL_GNATBIND := GNATBIND; else FULL_GNATBIND := new String' (Dir_Name (Ada_Compiler_Path.all) & Directory_Separator & GNATBIND.all); end if; if Gnatbind_Path_Specified then FULL_GNATBIND := Gnatbind_Path; end if; Gnatbind_Path := Locate_Exec_On_Path (FULL_GNATBIND.all); -- If gnatbind is not found and its full path was not specified, check for -- gnatbind on the path. if Gnatbind_Path = null and then not Gnatbind_Path_Specified then Gnatbind_Path := Locate_Exec_On_Path (GNATBIND.all); end if; if Gnatbind_Path = null then -- Make sure Namelen has a non negative value Name_Len := 0; declare Path_Of_Gnatbind : String_Access := GNATBIND; begin if Gnatbind_Path_Specified then Path_Of_Gnatbind := FULL_GNATBIND; end if; Finish_Program (null, Osint.E_Fatal, "could not locate " & Path_Of_Gnatbind.all); end; else -- Normalize the path, so that gnaampbind does not complain about not -- being in a "bin" directory. But don't resolve symbolic links, -- because in GNAT 5.01a1 and previous releases, gnatbind was a symbolic -- link for .gnat_wrapper. Gnatbind_Path := new String' (Normalize_Pathname (Gnatbind_Path.all, Resolve_Links => False)); end if; if Main_ALI = null then Gnatbind_Options.Append (No_Main_Option); end if; -- Add the switch -F= if the mapping file was specified -- and the version of GNAT is recent enough. if Mapping_File /= null and then GNAT_Version_Set and then GNAT_Version_First_2 /= "3." then Gnatbind_Options.Append (Dash_Fequal & Mapping_File.all); end if; -- Create temporary file to get the list of objects if not Dash_O_File_Specified then Tempdir.Create_Temp_File (FD_Objects, Objects_Path); Record_Temp_File (null, Objects_Path); end if; if GNAT_6_4_Or_Higher then if not Dash_O_File_Specified then Gnatbind_Options.Append (Dash_OO & "=" & Get_Name_String (Objects_Path)); Close (FD_Objects); end if; elsif not Dash_O_Specified then Gnatbind_Options.Append (Dash_OO); end if; if not Quiet_Output then if Verbose_Low_Mode then Display_Last := 0; Add_To_Display_Line (Gnatbind_Path.all); for Option of Gnatbind_Options loop Add_To_Display_Line (Option); end loop; Put_Line (Display_Line (1 .. Display_Last)); else if Main_ALI /= null then Display (Section => GPR.Bind, Command => "Ada", Argument => Base_Name (Main_ALI.all)); elsif not ALI_Files_Table.Is_Empty then Display (Section => GPR.Bind, Command => "Ada", Argument => Base_Name (ALI_Files_Table.First_Element) & " " & No_Main_Option); end if; end if; end if; declare Size : Natural := 0; Args_List : String_List_Access; begin for Option of Gnatbind_Options loop Size := Size + Option'Length + 1; end loop; -- Invoke gnatbind with the arguments if the size is not too large or -- if the version of GNAT is not recent enough. Script_Write (Gnatbind_Path.all, Gnatbind_Options); if not GNAT_6_Or_Higher or else Size <= Maximum_Size then Args_List := new String_List'(To_Argument_List (Gnatbind_Options)); if not GNAT_6_4_Or_Higher then Spawn (Gnatbind_Path.all, Args_List.all, FD_Objects, Return_Code, Err_To_Out => False); Success := Return_Code = 0; else Return_Code := Spawn (Gnatbind_Path.all, Args_List.all); end if; Free (Args_List); else -- Otherwise create a temporary response file declare FD : File_Descriptor; Path : Path_Name_Type; Args : Argument_List (1 .. 1); EOL : constant String (1 .. 1) := (1 => ASCII.LF); Status : Integer; Quotes_Needed : Boolean; Last_Char : Natural; Ch : Character; begin Tempdir.Create_Temp_File (FD, Path); Record_Temp_File (null, Path); Args (1) := new String'("@" & Get_Name_String (Path)); for Option of Gnatbind_Options loop -- Check if the argument should be quoted Quotes_Needed := False; Last_Char := Option'Length; for J in Option'Range loop Ch := Option (J); if Ch = ' ' or else Ch = ASCII.HT or else Ch = '"' then Quotes_Needed := True; exit; end if; end loop; if Quotes_Needed then -- Quote the argument, doubling '"' declare Arg : String (1 .. Option'Length * 2 + 2); begin Arg (1) := '"'; Last_Char := 1; for J in Option'Range loop Ch := Option (J); Last_Char := Last_Char + 1; Arg (Last_Char) := Ch; if Ch = '"' then Last_Char := Last_Char + 1; Arg (Last_Char) := '"'; end if; end loop; Last_Char := Last_Char + 1; Arg (Last_Char) := '"'; Status := Write (FD, Arg'Address, Last_Char); end; else Status := Write (FD, Option (Option'First)'Address, Last_Char); end if; if Status /= Last_Char then Fail_Program (null, "disk full"); end if; Status := Write (FD, EOL (1)'Address, 1); if Status /= 1 then Fail_Program (null, "disk full"); end if; end loop; Close (FD); -- And invoke gnatbind with this response file if not GNAT_6_4_Or_Higher then Spawn (Gnatbind_Path.all, Args, FD_Objects, Return_Code, Err_To_Out => False); else Return_Code := Spawn (Gnatbind_Path.all, Args); end if; end; end if; end; if not GNAT_6_4_Or_Higher and then not Dash_O_File_Specified then Close (FD_Objects); end if; if Return_Code /= 0 then Fail_Program (null, "invocation of gnatbind failed"); end if; Compiler_Options.Append (Dash_c); Compiler_Options.Append (Dash_gnatA); Compiler_Options.Append (Dash_gnatWb); Compiler_Options.Append (Dash_gnatiw); Compiler_Options.Append (Dash_gnatws); -- Read the ALI file of the first ALI file. Fetch the back end switches -- from this ALI file and use these switches to compile the binder -- generated file. if Main_ALI /= null or else not ALI_Files_Table.Is_Empty then Initialize_ALI; declare F : constant File_Name_Type := Get_File_Name_Id (if Main_ALI = null then ALI_Files_Table.First_Element else Main_ALI.all); T : Text_Buffer_Ptr; A : ALI_Id; begin -- Load the ALI file T := Osint.Read_Library_Info (F, True); -- Read it. Note that we ignore errors, since we only want very -- limited information from the ali file, and likely a slightly -- wrong version will be just fine, though in normal operation -- we don't expect this to happen. A := Scan_ALI (F, T, Ignore_ED => False, Err => False, Read_Lines => "A"); if A /= No_ALI_Id then for Index in Units.Table (ALIs.Table (A).First_Unit).First_Arg .. Units.Table (ALIs.Table (A).First_Unit).Last_Arg loop -- Do not compile with the front end switches declare Arg : String_Access renames Args.Table (Index); Argv : constant String (1 .. Arg'Length) := Arg.all; begin if (Argv'Last <= 2 or else Argv (1 .. 2) /= "-I") and then (Argv'Last <= 5 or else Argv (1 .. 5) /= "-gnat") and then (Argv'Last <= 6 or else Argv (1 .. 6) /= "--RTS=") then Compiler_Options.Append (Arg.all); end if; end; end loop; end if; end; end if; Compiler_Options.Append (Binder_Generated_File.all); declare Object : constant String := "b__" & Main_Base_Name.all & Ada_Object_Suffix.all; begin Compiler_Options.Append (Dash_o); Compiler_Options.Append (Object); -- Add the trailing options, if any Compiler_Options.Append_Vector (Compiler_Trailing_Options); if Verbose_Low_Mode then Set_Name_Buffer (Ada_Compiler_Path.all); -- Remove the executable suffix, if present if Executable_Suffix'Length > 0 and then Name_Len > Executable_Suffix'Length and then Name_Buffer (Name_Len - Executable_Suffix'Length + 1 .. Name_Len) = Executable_Suffix.all then Name_Len := Name_Len - Executable_Suffix'Length; end if; Display_Last := 0; Add_To_Display_Line (Name_Buffer (1 .. Name_Len)); for Option of Compiler_Options loop Add_To_Display_Line (Option); end loop; Put_Line (Display_Line (1 .. Display_Last)); end if; Spawn_And_Script_Write (Ada_Compiler_Path.all, Compiler_Options, Success); if not Success then Fail_Program (null, "compilation of binder generated file failed"); end if; Create (IO_File, Out_File, Exchange_File_Name.all); -- First, the generated object file Put_Line (IO_File, Binding_Label (Generated_Object_File)); Put_Line (IO_File, Object); -- Repeat the project paths with their time stamps Put_Line (IO_File, Binding_Label (Project_Files)); for PS of Project_Paths loop Put_Line (IO_File, PS.Path); Put_Line (IO_File, PS.Stamp); end loop; -- Get the bound object files from the Object file Open (Objects_File, In_File, Get_Name_String (Objects_Path)); Put_Line (IO_File, Binding_Label (Bound_Object_Files)); while not End_Of_File (Objects_File) loop Get_Line (Objects_File, Line, Last); -- Only put in the exchange file the path of the object files. -- Output anything else on standard output. if Is_Regular_File (Line (1 .. Last)) then Put_Line (IO_File, Line (1 .. Last)); Bound_Files := new Bound_File' (Name => new String'(Line (1 .. Last)), Next => Bound_Files); if Dash_O_Specified and then not Dash_O_File_Specified then Put_Line (Line (1 .. Last)); end if; elsif not Dash_O_File_Specified then Put_Line (Line (1 .. Last)); end if; end loop; Close (Objects_File); -- For the benefit of gprclean, the generated files other than the -- generated object file. Put_Line (IO_File, Binding_Label (Generated_Source_Files)); Put_Line (IO_File, "b__" & Main_Base_Name.all & ".ads"); Put_Line (IO_File, Binder_Generated_File.all); Put_Line (IO_File, "b__" & Main_Base_Name.all & ".ali"); -- Get the options from the binder generated file Open (BG_File, In_File, Binder_Generated_File.all); while not End_Of_File (BG_File) loop Get_Line (BG_File, Line, Last); exit when Line (1 .. Last) = Begin_Info; end loop; if not End_Of_File (BG_File) then Put_Line (IO_File, Binding_Label (Resulting_Options)); All_Binding_Options := False; Xlinker_Seen := False; Stack_Equal_Seen := False; loop Get_Line (BG_File, Line, Last); exit when Line (1 .. Last) = End_Info; Line (1 .. Last - 8) := Line (9 .. Last); Last := Last - 8; if Line (1) = '-' then -- After the first switch, we take all options, because some -- of the options specified in pragma Linker_Options may not -- start with '-'. All_Binding_Options := True; end if; Get_Option := All_Binding_Options or else Base_Name (Line (1 .. Last)) in "g-trasym.o" | "g-trasym.obj"; -- g-trasym is a special case as it is not included in libgnat -- Avoid duplication of object file if Get_Option then declare BF : Bound_File_Access := Bound_Files; begin while BF /= null loop if BF.Name.all = Line (1 .. Last) then Get_Option := False; exit; else BF := BF.Next; end if; end loop; end; end if; if Get_Option then if Line (1 .. Last) = "-Xlinker" then Xlinker_Seen := True; elsif Xlinker_Seen then Xlinker_Seen := False; -- Make sure that only the first switch --stack= is put in -- the exchange file. if Last > 8 and then Line (1 .. 8) = "--stack=" then if not Stack_Equal_Seen then Stack_Equal_Seen := True; Put_Line (IO_File, "-Xlinker"); Put_Line (IO_File, Line (1 .. Last)); end if; else Put_Line (IO_File, "-Xlinker"); Put_Line (IO_File, Line (1 .. Last)); end if; elsif Last > 12 and then Line (1 .. 12) = "-Wl,--stack=" then if not Stack_Equal_Seen then Stack_Equal_Seen := True; Put_Line (IO_File, Line (1 .. Last)); end if; elsif Last >= 3 and then Line (1 .. 2) = "-L" then -- Set Adalib_Dir only if libgnat is found inside. if Is_Regular_File (Line (3 .. Last) & Directory_Separator & "libgnat.a") then Adalib_Dir := new String'(Line (3 .. Last)); if Verbose_Higher_Mode then Put_Line ("Adalib_Dir = """ & Adalib_Dir.all & '"'); end if; -- Build the Prefix_Path, where to look for some -- archives: libaddr2line.a, libbfd.a, libgnatmon.a, -- libgnalasup.a and libiberty.a. It contains three -- directories: $(adalib)/.., $(adalib)/../.. and the -- subdirectory "lib" ancestor of $(adalib). declare Dir_Last : Positive; Prev_Dir_Last : Positive; First : Positive; Prev_Dir_First : Positive; Nmb : Natural; begin Set_Name_Buffer (Line (3 .. Last)); while Name_Buffer (Name_Len) = Directory_Separator or else Name_Buffer (Name_Len) = '/' loop Name_Len := Name_Len - 1; end loop; while Name_Buffer (Name_Len) /= Directory_Separator and then Name_Buffer (Name_Len) /= '/' loop Name_Len := Name_Len - 1; end loop; while Name_Buffer (Name_Len) = Directory_Separator or else Name_Buffer (Name_Len) = '/' loop Name_Len := Name_Len - 1; end loop; Dir_Last := Name_Len; Nmb := 0; Dir_Loop : loop Prev_Dir_Last := Dir_Last; First := Dir_Last - 1; while First > 3 and then Name_Buffer (First) /= Directory_Separator and then Name_Buffer (First) /= '/' loop First := First - 1; end loop; Prev_Dir_First := First + 1; exit Dir_Loop when First <= 3; Dir_Last := First - 1; while Name_Buffer (Dir_Last) = Directory_Separator or else Name_Buffer (Dir_Last) = '/' loop Dir_Last := Dir_Last - 1; end loop; Nmb := Nmb + 1; if Nmb <= 1 then Add_Char_To_Name_Buffer (Path_Separator); Add_Str_To_Name_Buffer (Name_Buffer (1 .. Dir_Last)); elsif Name_Buffer (Prev_Dir_First .. Prev_Dir_Last) = "lib" then Add_Char_To_Name_Buffer (Path_Separator); Add_Str_To_Name_Buffer (Name_Buffer (1 .. Prev_Dir_Last)); exit Dir_Loop; end if; end loop Dir_Loop; Prefix_Path := new String'(Name_Buffer (1 .. Name_Len)); if Verbose_Higher_Mode then Put_Line ("Prefix_Path = """ & Prefix_Path.all & '"'); end if; end; end if; Put_Line (IO_File, Line (1 .. Last)); elsif Line (1 .. Last) in Static_Libgcc | Shared_Libgcc then Put_Line (IO_File, Line (1 .. Last)); -- For a number of archives, we need to indicate the full -- path of the archive, if we find it, to be sure that the -- correct archive is used by the linker. elsif Line (1 .. Last) = Dash_Lgnat then if Adalib_Dir = null then if Verbose_Higher_Mode then Put_Line ("No Adalib_Dir"); end if; Put_Line (IO_File, Dash_Lgnat); elsif Static_Libs then Put_Line (IO_File, Adalib_Dir.all & "libgnat.a"); else Put_Line (IO_File, Dash_Lgnat); end if; elsif Line (1 .. Last) = Dash_Lgnarl and then Static_Libs and then Adalib_Dir /= null then Put_Line (IO_File, Adalib_Dir.all & "libgnarl.a"); elsif Line (1 .. Last) = "-laddr2line" and then Prefix_Path /= null then Output_Lib_Path_Or_Line ("libaddr2line.a"); elsif Line (1 .. Last) = "-lbfd" and then Prefix_Path /= null then Output_Lib_Path_Or_Line ("libbfd.a"); elsif Line (1 .. Last) = "-lgnalasup" and then Prefix_Path /= null then Output_Lib_Path_Or_Line ("libgnalasup.a"); elsif Line (1 .. Last) = "-lgnatmon" and then Prefix_Path /= null then Output_Lib_Path_Or_Line ("libgnatmon.a"); elsif Line (1 .. Last) = "-liberty" and then Prefix_Path /= null then Output_Lib_Path_Or_Line ("libiberty.a"); else Put_Line (IO_File, Line (1 .. Last)); end if; end if; end loop; end if; Close (BG_File); if not Static_Libs and then Adalib_Dir /= null then Put_Line (IO_File, Binding_Label (Run_Path_Option)); Put_Line (IO_File, Adalib_Dir.all); Name_Len := Adalib_Dir'Length; Name_Buffer (1 .. Name_Len) := Adalib_Dir.all; for J in reverse 2 .. Name_Len - 4 loop if Name_Buffer (J) = Directory_Separator and then Name_Buffer (J + 4) = Directory_Separator and then Name_Buffer (J + 1 .. J + 3) = "lib" then Name_Len := J + 3; Put_Line (IO_File, Name_Buffer (1 .. Name_Len)); exit; end if; end loop; end if; Close (IO_File); end; if Delete_Temp_Files then Delete_All_Temp_Files (null); end if; end Gprbind; gprbuild-25.0.0/src/gprbuild-compile.adb000066400000000000000000004162251470075373400201270ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2011-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ with Ada.Containers.Indefinite_Ordered_Maps; with Ada.Exceptions; use Ada.Exceptions; with Ada.Strings.Fixed; use Ada, Ada.Strings.Fixed; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with Ada.Text_IO; use Ada.Text_IO; with GNAT.Directory_Operations; use GNAT, GNAT.Directory_Operations; with GNAT.Dynamic_HTables; with GNAT.OS_Lib; use GNAT.OS_Lib; with Gpr_Build_Util; use Gpr_Build_Util; with GPR.Compilation; use GPR.Compilation; with GPR.Compilation.Process; use GPR.Compilation.Process; with GPR.Compilation.Slave; with GPR.Debug; with GPR.Env; with GPR.Jobserver; use GPR.Jobserver; with GPR.Names; use GPR.Names; with GPR.Opt; use GPR.Opt; with GPR.Snames; use GPR.Snames; with GPR.Tempdir; with GPR.Util; use GPR.Util; package body Gprbuild.Compile is procedure Add_Compilation_Switches (Source : Source_Id); -- Add to the compilation option, the switches declared in -- Compiler'Switches(), if it is defined, otherwise in -- Compiler'Default_Switches (), if it is defined. procedure Await_Compile (Source : out Queue.Source_Info; OK : out Boolean; Slave : out Unbounded_String); -- Wait for the end of a compilation and indicate that the object directory -- is free. procedure Compilation_Phase (Main_Project : Project_Id; Project_Tree : Project_Tree_Ref); procedure Recursive_Import (Project : Project_Id); -- Add to table Imports the projects imported by Project, recursively function Project_Extends (Extending : Project_Id; Extended : Project_Id) return Boolean; -- Returns True if Extending is Extended or is extending Extended directly -- or indirectly. function Directly_Imports (Project : Project_Id; Imported : Project_Id) return Boolean; -- Returns True if Project directly withs Imported or a project extending -- Imported. procedure Create_Config_File (For_Project : Project_Id; Config : Language_Config; Language : Name_Id); -- Create a new config file function Config_File_For (Project : Project_Id; Package_Name : Name_Id; Attribute_Name : Name_Id; Language : Name_Id) return Path_Information; -- Returns the name of a config file. Returns No_Name if there is no -- config file. procedure Create_Object_Path_File (Project : Project_Id; Shared : Shared_Project_Tree_Data_Access); -- Create a temporary file that contains the list of object directories -- in the correct order. procedure Print_Compilation_Outputs (For_Source : Source_Id; Always : Boolean := False); -- In complete output mode, or when Always is True, put the outputs from -- last compilation to standard output and/or standard error. function "<" (Left, Right : Source_Id) return Boolean is (Left.File < Right.File); package Bad_Compilations_Set is new Containers.Indefinite_Ordered_Maps (Source_Id, String); Bad_Compilations : Bad_Compilations_Set.Map; -- Records bad compilation with the given slave name if any Outstanding_Compiles : Natural := 0; -- The number of compilation jobs currently spawned Slave_Initialized : Boolean := False; -- Record wether the remote compilation slaves have been initialized when -- running in distributed mode. type Process_Purpose is (Compilation, Dependency); -- A type to distinguish between compilation jobs and dependency file -- building jobs. type Process_Data is record Process : GPR.Compilation.Id := GPR.Compilation.Invalid_Process; Source : Queue.Source_Info := Queue.No_Source_Info; Source_Project : Project_Id := null; Mapping_File : Path_Name_Type := No_Path; Purpose : Process_Purpose := Compilation; Options : String_Vectors.Vector; end record; -- Data recorded for each spawned jobs, compilation of dependency file -- building. No_Process_Data : constant Process_Data := (Process => GPR.Compilation.Invalid_Process, Source => Queue.No_Source_Info, Source_Project => null, Mapping_File => No_Path, Purpose => Compilation, Options => String_Vectors.Empty_Vector); package Compilation_Htable is new GNAT.HTable.Simple_HTable (Header_Num => GPR.Compilation.Process.Header_Num, Element => Process_Data, No_Element => No_Process_Data, Key => GPR.Compilation.Id, Hash => Hash, Equal => GPR.Compilation."="); -- Hash table to keep data for all spawned jobs package Naming_Data_Vectors is new Ada.Containers.Vectors (Positive, Lang_Naming_Data); Naming_Datas : Naming_Data_Vectors.Vector; -- Naming data when creating config files package Imports is new GNAT.HTable.Simple_HTable (Header_Num => GPR.Header_Num, Element => Boolean, No_Element => False, Key => Project_Id, Hash => Hash, Equal => "="); -- When --direct-import-only is used, contains the project ids a non Ada -- source is allowed to import source from. Included_Sources : Source_Vectors.Vector; Subunits : String_Vectors.Vector; -- A table to store the subunit names when switch --no-split-units is used ------------------------------ -- Add_Compilation_Switches -- ------------------------------ Inner_Cargs : constant String := "-inner-cargs"; -- When the --compiler-pkg-subst switch is given, this is used to pass -- switches from "package Compiler" to the ASIS tool and thence through to -- the actual compiler. procedure Add_Compilation_Switches (Source : Source_Id) is procedure Process_One_Package (Pkg_Name : Name_Id); -- Get the switches for the named package ------------------------- -- Process_One_Package -- ------------------------- procedure Process_One_Package (Pkg_Name : Name_Id) is Options : Variable_Value; Ignored : Boolean; begin Get_Switches (Source, Pkg_Name, Project_Tree, Options, Ignored); if Options /= Nil_Variable_Value then declare List : String_List_Id := Options.Values; Element : String_Element; begin while List /= Nil_String loop Element := Project_Tree.Shared.String_Elements.Table (List); -- Ignore empty options if Element.Value /= Empty_String then Add_Option_Internal_Codepeer (Value => Get_Option (Element.Value), To => Compilation_Options, Display => True); end if; List := Element.Next; end loop; end; end if; end Process_One_Package; begin -- If the --compiler-pkg-subst switch was given, get switches from the -- relevant package (e.g. "package Pretty_Printer"). if Compiler_Pkg_Subst /= No_Name then Process_One_Package (Compiler_Pkg_Subst); Add_Option_Internal_Codepeer (Value => Inner_Cargs, To => Compilation_Options, Display => True); end if; -- Always get switches from "package Compiler". If the -- --compiler-pkg-subst switch was given, these are preceded by -- -inner-cargs (see above) to indicate that the ASIS tool should pass -- them along to gcc. Process_One_Package (Name_Compiler); end Add_Compilation_Switches; ------------------- -- Await_Compile -- ------------------- procedure Await_Compile (Source : out Queue.Source_Info; OK : out Boolean; Slave : out Unbounded_String) is Process : GPR.Compilation.Id; Comp_Data : Process_Data; Language : Language_Ptr; Config : Language_Config; begin loop Source := Queue.No_Source_Info; Wait_Result (Process, OK); if Process = GPR.Compilation.Invalid_Process then return; end if; Comp_Data := Compilation_Htable.Get (Process); if Comp_Data /= No_Process_Data then Source := Comp_Data.Source; Queue.Set_Obj_Dir_Free (Source.Id.Project.Object_Directory.Name); if Comp_Data.Purpose = Compilation then Print_Compilation_Outputs (Source.Id, Always => not No_Complete_Output); if OK then -- We created a new dependency file, so reset the attributes -- of the old one. Source.Id.Dep_TS := Unknown_Attributes; if not Comp_Data.Options.Is_Empty and then Source.Id.Switches_Path /= No_Path and then Opt.Check_Switches then -- First, update the time stamp of the object file that -- will be written in the switches file. Source.Id.Object_TS := File_Stamp (Source.Id.Object_Path); GPR.Util.Update_File_Stamp (Source.Id.Object_Path, Source.Id.Object_TS); -- Write the switches file, now that we have the updated -- time stamp for the object file. declare File : Text_IO.File_Type; begin Create (File, Out_File, Get_Name_String (Source.Id.Switches_Path)); Put_Line (File, String (Source.Id.Object_TS)); for Arg of Comp_Data.Options loop Put_Line (File, Arg); end loop; Close (File); exception when others => Fail_Program (Source.Tree, "could not create switches file """ & Get_Name_String (Source.Id.Switches_Path) & '"'); end; -- For all languages other than Ada, update the time -- stamp of the object file as it is written in the -- global archive dependency file. For all languages, -- update the time stamp of the object file if it is in -- a library project. elsif Source.Id.Language.Config.Dependency_Kind not in ALI_Dependency or else Source.Id.Project.Library then Source.Id.Object_TS := File_Stamp (Source.Id.Object_Path); GPR.Util.Update_File_Stamp (Source.Id.Object_Path, Source.Id.Object_TS); end if; else Set_Failed_Compilation_Status (Comp_Data.Source_Project); Slave := To_Unbounded_String (Get_Slave_For (Process)); end if; Language := Source.Id.Language; -- If there is a mapping file used, recycle it in the hash -- table of the language. if Comp_Data.Mapping_File /= No_Path and then Language /= No_Language_Index then Mapping_Files_Htable.Set (T => Language.Mapping_Files, K => Comp_Data.Mapping_File, E => Comp_Data.Mapping_File); end if; Config := Language.Config; if OK and then Config.Dependency_Kind = Makefile and then Config.Compute_Dependency /= No_Name_List then declare Current_Dir : constant Dir_Name_Str := Get_Current_Dir; List : Name_List_Index := Config.Compute_Dependency; Nam : Name_Node := Source.Tree.Shared.Name_Lists.Table (List); Exec_Name : constant String := Get_Name_String (Nam.Name); Exec_Path : OS_Lib.String_Access; begin Change_Dir (Get_Name_String (Source.Id.Project.Object_Directory.Display_Name)); Comp_Data.Mapping_File := No_Path; Comp_Data.Purpose := Dependency; -- ??? We search for it on the PATH for every file, -- this is very inefficient Exec_Path := Locate_Exec_On_Path (Exec_Name); if Exec_Path = null then Fail_Program (Source.Tree, "unable to find dependency builder " & Exec_Name); end if; List := Nam.Next; Compilation_Options.Clear; if List = No_Name_List then Name_Len := 0; else loop Nam := Source.Tree.Shared.Name_Lists.Table (List); List := Nam.Next; if List = No_Name_List then Get_Name_String (Nam.Name); exit; end if; Add_Option (Nam.Name, Compilation_Options, Opt.Verbose_Mode); end loop; end if; Get_Name_String_And_Append (Source.Id.Path.Display_Name); Add_Option (Name_Buffer (1 .. Name_Len), Compilation_Options, Opt.Verbose_Mode, Simple_Name => not Opt.Verbose_Mode); if not Opt.Quiet_Output then if Opt.Verbose_Mode then Put (Exec_Path.all); else Put (Exec_Name); end if; Put (" "); for Option of Compilation_Options loop if Option.Displayed then Put (Option.Name); Put (" "); end if; end loop; New_Line; end if; Comp_Data.Process := Run (Executable => Exec_Path.all, Options => Options_List (Compilation_Options), Project => Comp_Data.Source_Project, Obj_Name => Get_Name_String (Source.Id.Object), Output_File => Get_Name_String (Source.Id.Dep_Path), Err_To_Out => True, Force_Local => True); Compilation_Htable.Set (Comp_Data.Process, Comp_Data); Free (Exec_Path); Change_Dir (Current_Dir); end; else Outstanding_Compiles := Outstanding_Compiles - 1; if Opt.Use_GNU_Make_Jobserver then Jobserver.Unregister_Token_Id (Id => Process); end if; return; end if; elsif Comp_Data.Purpose = Dependency then Outstanding_Compiles := Outstanding_Compiles - 1; if Opt.Use_GNU_Make_Jobserver then Jobserver.Unregister_Token_Id (Id => Process); end if; return; end if; end if; end loop; end Await_Compile; --------------------- -- Config_File_For -- --------------------- function Config_File_For (Project : Project_Id; Package_Name : Name_Id; Attribute_Name : Name_Id; Language : Name_Id) return Path_Information is function Normalize_Path (Path : Path_Name_Type; Project : Project_Id) return String is (GNAT.OS_Lib.Normalize_Pathname (Name => Get_Name_String (Path), Directory => Get_Name_String (Project.Directory.Display_Name))); -- Returns an normalized path for a config file Config_Package : constant Package_Id := Value_Of (Name => Package_Name, In_Packages => Project.Decl.Packages, Shared => Project_Tree.Shared); Config_Variable : Variable_Value := Value_Of (Name => Language, Attribute_Or_Array_Name => Attribute_Name, In_Package => Config_Package, Shared => Project_Tree.Shared); begin -- Get the config pragma attribute when the language is Ada and the -- config file attribute is not declared. if Config_Variable = Nil_Variable_Value and then Config_Package /= No_Package and then Language = Name_Ada then Config_Variable := Value_Of (Variable_Name => (if Attribute_Name = Name_Global_Config_File then Name_Global_Configuration_Pragmas elsif Attribute_Name = Name_Local_Config_File then Name_Local_Configuration_Pragmas else raise Program_Error with "Unexpected " & Get_Name_String_Safe (Attribute_Name)), In_Variables => Project_Tree.Shared.Packages.Table (Config_Package).Decl.Attributes, Shared => Project_Tree.Shared); end if; if Config_Variable = Nil_Variable_Value or else Config_Variable.Value = Snames.The_Empty_String then return No_Path_Information; else declare Path : String := Normalize_Path (Path_Name_Type (Config_Variable.Value), Config_Variable.Project); Result : Path_Information; begin Result.Display_Name := Get_Path_Name_Id (Path); Canonical_Case_File_Name (Path); Result.Name := Get_Path_Name_Id (Path); return Result; end; end if; end Config_File_For; ------------------------ -- Create_Config_File -- ------------------------ procedure Create_Config_File (For_Project : Project_Id; Config : Language_Config; Language : Name_Id) is File_Name : Path_Name_Type := No_Path; File : File_Descriptor := Invalid_FD; Source : Source_Id; Iter : Source_Iterator; procedure Check (Project : Project_Id; Tree : Project_Tree_Ref; Dummy : in out Boolean); -- Check the naming schemes of the different projects of the project -- tree. For each different naming scheme issue the pattern config -- declarations. procedure Check_Temp_File; -- Check if a temp file has been created. If not, create one procedure Copy_Config_File (Project : Project_Id; Package_Name : Name_Id; Attribute_Name : Name_Id; Language : Name_Id); -- If a specified config file exists, copy it in the temporary config -- file. procedure Put_Line (File : File_Descriptor; S : String); -- Output procedure, analogous to normal Text_IO proc of same name ----------- -- Check -- ----------- procedure Check (Project : Project_Id; Tree : Project_Tree_Ref; Dummy : in out Boolean) is pragma Unreferenced (Dummy, Tree); Lang_Id : Language_Ptr := Project.Languages; Current_Naming : Natural := 0; procedure Replace; ------------- -- Replace -- ------------- procedure Replace is Cur : Positive := 1; procedure Substitute (N : File_Name_Type); procedure Substitute (Name : String); ---------------- -- Substitute -- ---------------- procedure Substitute (N : File_Name_Type) is begin if N = No_File then Cur := Cur + 1; else Substitute (Get_Name_String (N)); end if; end Substitute; procedure Substitute (Name : String) is begin Name_Buffer (Cur + Name'Length .. Name_Len - 2 + Name'Length) := Name_Buffer (Cur + 2 .. Name_Len); Name_Buffer (Cur .. Cur + Name'Length - 1) := Name; Name_Len := Name_Len - 2 + Name'Length; Cur := Cur + Name'Length; end Substitute; begin while Cur < Name_Len loop if Name_Buffer (Cur) = '%' then case Name_Buffer (Cur + 1) is when 'b' => Substitute (Lang_Id.Config.Naming_Data.Body_Suffix); when 's' => Substitute (Lang_Id.Config.Naming_Data.Spec_Suffix); when 'd' => Substitute (Lang_Id.Config.Naming_Data.Dot_Replacement); when 'c' => Substitute (Image (Lang_Id.Config.Naming_Data.Casing)); when '%' => Name_Buffer (Cur .. Name_Len - 1) := Name_Buffer (Cur + 1 .. Name_Len); Name_Len := Name_Len - 1; Cur := Cur + 1; when others => Cur := Cur + 1; end case; else Cur := Cur + 1; end if; end loop; end Replace; begin if Current_Verbosity = High then Put ("Checking project file """); Put (Get_Name_String (Project.Name)); Put ("""."); New_Line; end if; while Lang_Id /= No_Language_Index loop exit when Lang_Id.Name = Language; Lang_Id := Lang_Id.Next; end loop; if Lang_Id /= No_Language_Index then Current_Naming := Natural (Naming_Datas.Find_Index (Lang_Id.Config.Naming_Data)); if Current_Naming = 0 then Naming_Datas.Append (Lang_Id.Config.Naming_Data); Check_Temp_File; if Lang_Id.Config.Config_Spec_Pattern /= No_Name then Get_Name_String (Lang_Id.Config.Config_Spec_Pattern); Replace; Put_Line (File, Name_Buffer (1 .. Name_Len)); end if; if Lang_Id.Config.Config_Body_Pattern /= No_Name then Get_Name_String (Lang_Id.Config.Config_Body_Pattern); Replace; Put_Line (File, Name_Buffer (1 .. Name_Len)); end if; end if; end if; end Check; --------------------- -- Check_Temp_File -- --------------------- procedure Check_Temp_File is begin if File = Invalid_FD then Tempdir.Create_Temp_File (File, Name => File_Name); if File = Invalid_FD then Fail_Program (Project_Tree, "unable to create temporary configuration pragmas file"); else Record_Temp_File (Project_Tree.Shared, File_Name); if Opt.Verbosity_Level > Opt.Low then Put ("Creating temp file """); Put (Get_Name_String (File_Name)); Put_Line (""""); end if; end if; end if; end Check_Temp_File; ---------------------- -- Copy_Config_File -- ---------------------- procedure Copy_Config_File (Project : Project_Id; Package_Name : Name_Id; Attribute_Name : Name_Id; Language : Name_Id) is Config_File_Path : constant Path_Name_Type := Config_File_For (Project, Package_Name, Attribute_Name, Language).Display_Name; Config_File : Text_IO.File_Type; Line : String (1 .. 1_000); Last : Natural; begin if Config_File_Path /= No_Path then begin Open (Config_File, In_File, Get_Name_String (Config_File_Path)); exception when others => Fail_Program (Project_Tree, "unable to open config file " & Get_Name_String_Safe (Config_File_Path)); end; Check_Temp_File; while not End_Of_File (Config_File) loop Get_Line (Config_File, Line, Last); Put_Line (File, Line (1 .. Last)); end loop; Close (Config_File); end if; end Copy_Config_File; -------------- -- Put_Line -- -------------- procedure Put_Line (File : File_Descriptor; S : String) is S0 : String (1 .. S'Length + 1); Last : Natural; begin -- Add an ASCII.LF to the string. As this config file is supposed to -- be used only by the compiler, we don't care about the characters -- for the end of line. In fact we could have put a space, but -- it is more convenient to be able to read gnat.adc during -- development, for which the ASCII.LF is fine. S0 (1 .. S'Length) := S; S0 (S0'Last) := ASCII.LF; Last := Write (File, S0'Address, S0'Length); if Last /= S'Length + 1 then Fail_Program (Project_Tree, "Disk full"); end if; if Current_Verbosity = High then Put_Line (S); end if; end Put_Line; procedure Check_All_Projects is new For_Every_Project_Imported (Boolean, Check); Dummy : Boolean := False; -- Start of processing for Create_Config_File begin -- Nothing to do if config has already been checked if For_Project.Config_Checked then return; end if; if Config.Config_File_Unique then -- Copy an eventual global config file Copy_Config_File (Main_Project, Name_Builder, Name_Global_Config_File, Language); -- Copy an eventual local config file Copy_Config_File (For_Project, Name_Compiler, Name_Local_Config_File, Language); end if; For_Project.Config_Checked := True; Naming_Datas.Clear; Check_All_Projects (For_Project, Project_Tree, Dummy); -- Visit all the units and issue the config declarations for those that -- need one. Iter := For_Each_Source (Project_Tree); loop Source := GPR.Element (Iter); exit when Source = No_Source; if Source.Language.Name = Language and then Source.Naming_Exception /= No and then Source.Unit /= No_Unit_Index and then not Source.Locally_Removed and then Source.Replaced_By = No_Source then Name_Len := 0; if Source.Kind = Spec then if Source.Index = 0 and then Config.Config_Spec /= No_Name then Get_Name_String (Config.Config_Spec); elsif Source.Index /= 0 and then Config.Config_Spec_Index /= No_Name then Get_Name_String (Config.Config_Spec_Index); end if; else if Source.Index = 0 and then Config.Config_Body /= No_Name then Get_Name_String (Config.Config_Body); elsif Source.Index /= 0 and then Config.Config_Body_Index /= No_Name then Get_Name_String (Config.Config_Body_Index); end if; end if; if Name_Len /= 0 then declare Cur : Positive := 1; Unit : constant String := Get_Name_String (Source.Unit.Name); File_Name : constant String := Get_Name_String (Source.Display_File); begin while Cur < Name_Len loop if Name_Buffer (Cur) /= '%' then Cur := Cur + 1; else case Name_Buffer (Cur + 1) is when 'u' => Name_Buffer (Cur + Unit'Length .. Name_Len - 2 + Unit'Length) := Name_Buffer (Cur + 2 .. Name_Len); Name_Buffer (Cur .. Cur + Unit'Length - 1) := Unit; Cur := Cur + Unit'Length; Name_Len := Name_Len - 2 + Unit'Length; when 'f' => Name_Buffer (Cur + File_Name'Length .. Name_Len - 2 + File_Name'Length) := Name_Buffer (Cur + 2 .. Name_Len); Name_Buffer (Cur .. Cur + File_Name'Length - 1) := File_Name; Cur := Cur + File_Name'Length; Name_Len := Name_Len - 2 + File_Name'Length; when 'i' => declare Index_String : constant String := Source.Index'Img; begin Name_Buffer (Cur + Index_String'Length .. Name_Len - 2 + Index_String'Length) := Name_Buffer (Cur + 2 .. Name_Len); Name_Buffer (Cur .. Cur + Index_String'Length - 1) := Index_String; Cur := Cur + Index_String'Length; Name_Len := Name_Len - 2 + Index_String'Length; end; when '%' => Name_Buffer (Cur .. Name_Len - 1) := Name_Buffer (Cur + 1 .. Name_Len); Cur := Cur + 1; Name_Len := Name_Len - 1; when others => Cur := Cur + 1; end case; end if; end loop; Put_Line (File, Name_Buffer (1 .. Name_Len)); end; end if; end if; Next (Iter); end loop; if File /= Invalid_FD then Close (File); For_Project.Config_File_Name := File_Name; end if; end Create_Config_File; ----------------------------- -- Create_Object_Path_File -- ----------------------------- procedure Create_Object_Path_File (Project : Project_Id; Shared : Shared_Project_Tree_Data_Access) is FD : File_Descriptor; Name : Path_Name_Type; LF : constant String := (1 => ASCII.LF); procedure Add (Project : Project_Id; In_Tree : Project_Tree_Ref; Dummy : in out Boolean); -- Add the object directory of a project to the file --------- -- Add -- --------- procedure Add (Project : Project_Id; In_Tree : Project_Tree_Ref; Dummy : in out Boolean) is pragma Unreferenced (In_Tree); Path : constant Path_Name_Type := Get_Object_Directory (Project, Including_Libraries => True, Only_If_Ada => False); Last : Natural; pragma Unreferenced (Last); begin if Path /= No_Path then Get_Name_String (Path); Last := Write (FD, Name_Buffer (1)'Address, Name_Len); Last := Write (FD, LF (1)'Address, 1); end if; Dummy := True; end Add; procedure For_All_Projects is new For_Every_Project_Imported (Boolean, Add); Status : Boolean := False; pragma Warnings (Off, Status); begin GPR.Env.Create_Temp_File (Shared, FD, Name, "object path file"); Project.Object_Path_File := Name; For_All_Projects (Project, Project_Tree, Status, Include_Aggregated => True); Close (FD, Status); end Create_Object_Path_File; ---------------------- -- Recursive_Import -- ---------------------- procedure Recursive_Import (Project : Project_Id) is Ext : constant Project_Id := Project.Extends; L : Project_List := Project.Imported_Projects; begin if Ext /= No_Project and then not Imports.Get (Ext) then Imports.Set (Ext, True); Recursive_Import (Ext); end if; while L /= null loop if not Imports.Get (L.Project) then Imports.Set (L.Project, True); Recursive_Import (L.Project); end if; L := L.Next; end loop; end Recursive_Import; ---------------------- -- Directly_Imports -- ---------------------- function Directly_Imports (Project : Project_Id; Imported : Project_Id) return Boolean is L : Project_List := Project.Imported_Projects; P : Project_Id; begin while L /= null loop P := L.Project; while P /= No_Project loop if Imported = P then return True; end if; P := P.Extends; end loop; L := L.Next; end loop; return False; end Directly_Imports; ------------------------------- -- Print_Compilation_Outputs -- ------------------------------- procedure Print_Compilation_Outputs (For_Source : Source_Id; Always : Boolean := False) is procedure Display_Content (Stream : File_Type; File_Path : String); -- Display content of the given Filename --------------------- -- Display_Content -- --------------------- procedure Display_Content (Stream : File_Type; File_Path : String) is File : Ada.Text_IO.File_Type; Line : String (1 .. 1_024); Last : Natural; Print_New_Line : Boolean := False; begin if OS_Lib.Is_Regular_File (File_Path) then Open (File, In_File, File_Path); while not End_Of_File (File) loop Get_Line (File, Line, Last); if Last = Line'Last then Put (Stream, Line (1 .. Last)); Print_New_Line := True; else Put_Line (Stream, Line (1 .. Last)); end if; end loop; if Print_New_Line then Put_Line (Stream, ""); end if; Close (File); end if; end Display_Content; begin if Complete_Output or else Always then declare Proj : constant Project_Id := Ultimate_Extending_Project_Of (For_Source.Project); File_Path : constant String := Get_Name_String (Proj.Object_Directory.Name) & Directory_Separator & Get_Name_String (For_Source.File); begin Display_Content (Standard_Output, File_Path & ".stdout"); Display_Content (Standard_Error, File_Path & ".stderr"); end; end if; end Print_Compilation_Outputs; --------- -- Run -- --------- procedure Run is procedure Do_Compile (Project : Project_Id; Tree : Project_Tree_Ref); ---------------- -- Do_Compile -- ---------------- procedure Do_Compile (Project : Project_Id; Tree : Project_Tree_Ref) is begin if Builder_Data (Tree).Need_Compilation then Compilation_Phase (Project, Tree); if Total_Errors_Detected > 0 or else not Bad_Compilations.Is_Empty then -- If switch -k or -jnn (with nn > 1), output a summary of the -- sources that could not be compiled. if (Opt.Keep_Going or else Get_Maximum_Processes > 1) and then not Bad_Compilations.Is_Empty and then not Opt.No_Exit_Message then New_Line; for Index in Bad_Compilations.Iterate loop declare Source : constant Source_Id := Bad_Compilations_Set.Key (Index); Slave : constant String := Bad_Compilations_Set.Element (Index); begin if Source /= No_Source then Put (" compilation of "); Put (Get_Name_String (Source.Display_File)); Put (" failed"); if Slave /= "" then Put (" on " & Slave); end if; New_Line; end if; end; end loop; New_Line; end if; if Exit_Code = Osint.E_Success then Exit_Code := (if Bad_Compilations.Is_Empty then E_Fatal else E_Subtool); end if; if Opt.Keep_Going and then Project.Qualifier = Aggregate then Bad_Compilations.Clear; else if Distributed_Mode and then Slave_Initialized then GPR.Compilation.Slave.Unregister_Remote_Slaves; end if; Compilation_Phase_Failed (Tree, Exit_Code, No_Message => Opt.No_Exit_Message); end if; end if; end if; end Do_Compile; procedure Compile_All is new For_Project_And_Aggregated (Do_Compile); begin Compile_All (Main_Project, Project_Tree); -- Unregister the slaves and get back compiled object code. This is a -- nop if no compilation has been done. GPR.Compilation.Slave.Unregister_Remote_Slaves; end Run; ----------------------- -- Compilation_Phase -- ----------------------- procedure Compilation_Phase (Main_Project : Project_Id; Project_Tree : Project_Tree_Ref) is type Local_Project_Data is record Include_Language : Language_Ptr := No_Language_Index; -- Prepared arguments for "include" parameters (-I or include file). -- These are specific to each language and project. Include_Path_File : Path_Name_Type; -- The path name of the source search directory file Imported_Dirs_Switches : Argument_List_Access; -- List of the source search switches (-I) to be used -- when compiling. Include_Path : OS_Lib.String_Access := null; -- The search source path for the project. Used as the value for an -- environment variable, specified by attribute Include_Path -- (). The names of the environment variables are in component -- Include_Path of the records Language_Config. Include_Switches_Spec_File : Path_Name_Type; end record; -- project-specific data required for this procedure. These are not -- stored in the Project_Data record so that projects kept in memory do -- not have to allocate space for these temporary data No_Local_Project_Data : constant Local_Project_Data := (Include_Language => No_Language_Index, Include_Path => null, Imported_Dirs_Switches => null, Include_Path_File => No_Path, Include_Switches_Spec_File => No_Path); package Local_Projects_HT is new Dynamic_HTables.Simple_HTable (Header_Num => GPR.Header_Num, Element => Local_Project_Data, No_Element => No_Local_Project_Data, Key => Project_Id, Hash => GPR.Hash, Equal => "="); Local_Projects : Local_Projects_HT.Instance; Keep_Dep_File : Boolean := False; -- We need to keep dependency file in some error cases for diagnostic The_Config_Paths : Config_Paths (1 .. 2 + Natural (Cmd_Line_Adc_Files.Length)); -- Paths of eventual global and local configuration pragmas files -- and files from -gnatec= command line parameters. Target_Dep_Paths : Config_Paths (1 .. Natural (Cmd_Line_Target_Dep_Info_Files.Length)); -- Paths of eventual target dependency files from -gnateT command line -- parameters. Last_Config_Path : Natural := 0; Last_Target_Dependency_Path : Natural := 0; procedure Add_Config_File_Switch (Config : Language_Config; Path_Name : Path_Name_Type); procedure Record_ALI_For (Source_Identity : Queue.Source_Info; The_ALI : ALI.ALI_Id := ALI.No_ALI_Id); -- Record the Id of an ALI file in Good_ALI table. -- The_ALI can contain the pre-parsed ali file, to save time. -- Tree is the tree to which Source_Identity belongs function Phase_2_Makefile (Src_Data : Queue.Source_Info) return Boolean; function Phase_2_ALI (Src_Data : Queue.Source_Info) return Boolean; -- Process Wait_For_Available_Slot depending on Src_Data.Dependency type -- This returns whether the compilation is considered as successful or -- not. procedure Set_Options_For_File (Id : Source_Id); -- Prepare the compiler options to use when building Id procedure Process_Project_Phase_1 (Source : Queue.Source_Info); -- If some compilation is needed for this project, perform it function Must_Exit_Because_Of_Error return Boolean; -- Return True if there were errors and the user decided to exit in such -- a case. This waits for any outstanding compilation. function Check_Switches_File (Id : Source_Id) return Boolean; -- Check in its switches file where Id was compiled with the same -- switches procedure Update_Object_Path (Id : Source_Id; Source_Project : Project_Id); -- Update, if necessary, the path of the object file, of the dependency -- file and of the switches file, in the case of the compilation of a -- source in an extended project, when the source is in a project being -- extended. procedure Add_Dependency_Options (Id : Source_Id); -- Add switches to the compilation command line to create the -- dependency file procedure Add_Object_File_Switches (Id : Source_Id); -- If there are switches to specify the name of the object file, add -- them. procedure Add_Object_Path_Switches (Id : Source_Id); -- If attribute Compiler'Object_Path_Switches has been specified, create -- the temporary object path file, if not already done, and add the -- switch(es) to the invocation of the compiler. procedure Get_Config_Paths (Id : Source_Id; Source_Project : Project_Id); -- Find the config files for the source and put their paths in -- The_Config_Paths. procedure Get_Target_Dependency_Paths; -- Find the target dependency files for the source and put their paths -- in Target_Dep_Paths. procedure Add_Config_File_Switches (Id : Source_Id; Source_Project : Project_Id); -- If Config_File_Switches is specified, check if a config file need to -- be specified. Return the path to the config file procedure Add_Trailing_Switches (Id : Source_Id); -- Add the trailing required switches, if any, so that they will be put -- in the switches file. procedure Add_Name_Of_Source_Switches (Id : Source_Id); -- Add the name of the source to be compiled function Add_Mapping_File_Switches (Source : Queue.Source_Info; Source_Project : Project_Id) return Path_Name_Type; -- If the compiler supports mapping files, add the necessary switch. -- Returns the name of the mapping file to use (or No_File) procedure Add_Multi_Unit_Switches (Id : Source_Id); -- Add, if needed, the required switches to compile a multi-unit source -- file. procedure Spawn_Compiler_And_Register (Source : Queue.Source_Info; Source_Project : Project_Id; Compiler_Path : String; Mapping_File_Path : Path_Name_Type; Last_Switches_For_File : Integer); -- Spawn the compiler with the arguments currently set in -- Compiler_Options. It registers the process we just spawned, so that -- we start monitoring it. -- This also displays on the output the command we are spawning. -- Last_Switches_For_File is the index in Compilation_Options of the -- last switch that should be written to the switches file. All -- following switches are not output in that file. function Get_Compatible_Languages (Lang : Language_Ptr) return Name_Ids; -- Return the list of languages that Id could potentially include (for -- instance "C" if Id is a "C++" file. This also includes Id's own -- language. procedure Prepare_Imported_Dirs_Switches (Data : out Local_Project_Data; Project : Project_Id; Lang : Language_Ptr); -- Add the switches for include directories to the command line (these -- are the "-I" switches in the case of C for instance). procedure Prepare_Include_Path_File (Data : out Local_Project_Data; Project : Project_Id; Lang : Language_Ptr); -- Create a file to pass the include directories to the compiler procedure Start_Compile_If_Possible; -- Checks if there is more work that we can do (ie the Queue is non -- empty). If there is, do it only if we have not yet used up all the -- available processes. procedure Wait_For_Available_Slot; -- Check if we should wait for a compilation to finish. This is the case -- if all the available processes are busy compiling sources or there is -- nothing else to do (that is the Q is empty and there are outstanding -- compilations). procedure Set_Env_For_Include_Dirs (Id : Source_Id; Source_Project : Project_Id); -- Set environment variables or switches to pass the include directories -- to the compiler procedure Check_Interface_And_Indirect_Imports (The_ALI : ALI.ALI_Id; Src_Data : Queue.Source_Info; Success : in out Boolean); -- From the given ALI data and the associated source Src_Data, checks -- the withed units for the following error cases: -- - The unit is not in the interface of the source's project -- - The unit is from an indirect import and the --no-indirect-import -- flag is set. -- Success is set to False if those occur. ------------------------------------------ -- Check_Interface_And_Indirect_Imports -- ------------------------------------------ procedure Check_Interface_And_Indirect_Imports (The_ALI : ALI.ALI_Id; Src_Data : Queue.Source_Info; Success : in out Boolean) is Sfile : File_Name_Type; Afile : File_Name_Type; Source_2 : Source_Id; begin for J in ALI.ALIs.Table (The_ALI).First_Unit .. ALI.ALIs.Table (The_ALI).Last_Unit loop for K in ALI.Units.Table (J).First_With .. ALI.Units.Table (J).Last_With loop if not ALI.Withs.Table (K).Implicit_With_From_Instantiation then Sfile := ALI.Withs.Table (K).Sfile; -- Skip generics if Sfile /= No_File then -- Look for this source Afile := ALI.Withs.Table (K).Afile; Source_2 := Source_Files_Htable.Get (Src_Data.Tree.Source_Files_HT, Sfile); while Source_2 /= No_Source loop if Is_Compilable (Source_2) and then Source_2.Dep_Name = Afile then case Source_2.Kind is when Spec => null; when Impl => if Is_Subunit (Source_2) then Source_2 := No_Source; end if; when Sep => Source_2 := No_Source; end case; exit; end if; Source_2 := Source_2.Next_With_File_Name; end loop; -- If it is the source of a project that is not the -- project of the source just compiled, check if it -- is allowed to be imported. if Source_2 /= No_Source then if not Project_Extends (Src_Data.Id.Project, Source_2.Project) and then not Project_Extends (Source_2.Project, Src_Data.Id.Project) then if not Indirect_Imports and then not Directly_Imports (Src_Data.Id.Project, Source_2.Project) then -- It is in a project that is not directly -- imported. Report an error and -- invalidate the compilation. Put ("Unit """); Put (Get_Name_String (Src_Data.Id.Unit.Name)); Put (""" cannot import unit """); Put (Get_Name_String (Source_2.Unit.Name)); Put_Line (""":"); Put (" """); Put (Get_Name_String (Src_Data.Id.Project.Display_Name)); Put (""" does not directly import project """); Put (Get_Name_String (Source_2.Project.Display_Name)); Put_Line (""""); Exit_Code := E_General; Success := False; elsif not Source_2.In_Interfaces then -- It is not an interface of its project. -- Report an error and invalidate the -- compilation. Put ("Unit """); Put (Get_Name_String (Src_Data.Id.Unit.Name)); Put (""" cannot import unit """); Put (Get_Name_String (Source_2.Unit.Name)); Put_Line (""":"); Put (" it is not part of the " & "interfaces of its project """); Put (Get_Name_String (Source_2.Project.Display_Name)); Put_Line (""""); Success := False; end if; end if; end if; end if; end if; end loop; end loop; end Check_Interface_And_Indirect_Imports; ---------------------------- -- Add_Config_File_Switch -- ---------------------------- procedure Add_Config_File_Switch (Config : Language_Config; Path_Name : Path_Name_Type) is List : Name_List_Index := Config.Config_File_Switches; Nam : Name_Node; begin while List /= No_Name_List loop Nam := Project_Tree.Shared.Name_Lists.Table (List); Get_Name_String (Nam.Name); if Nam.Next = No_Name_List then Get_Name_String_And_Append (Path_Name); end if; -- Check if the config file switch was not already included in -- the compilation options via the command line. declare Switch : constant String := Name_Buffer (1 .. Name_Len); Canonical_Switch : String := Switch; Add_Switch : Boolean := True; begin Canonical_Case_File_Name (Canonical_Switch); for Option of Compilation_Options loop if Canonical_Switch = Option.Name then Add_Switch := False; end if; end loop; if Add_Switch then Add_Option (Switch, To => Compilation_Options, Display => Opt.Verbose_Mode); end if; end; List := Nam.Next; end loop; end Add_Config_File_Switch; -------------------- -- Record_ALI_For -- -------------------- procedure Record_ALI_For (Source_Identity : Queue.Source_Info; The_ALI : ALI.ALI_Id := ALI.No_ALI_Id) is Local_ALI : ALI.ALI_Id := The_ALI; Text : Text_Buffer_Ptr; begin if The_ALI = ALI.No_ALI_Id then Text := Read_Library_Info_From_Full (File_Name_Type (Source_Identity.Id.Dep_Path), Source_Identity.Id.Dep_TS'Access); if Text /= null then -- Read the ALI file but read only the necessary lines Local_ALI := ALI.Scan_ALI (File_Name_Type (Source_Identity.Id.Dep_Path), Text, Ignore_ED => False, Err => True, Read_Lines => "W"); Free (Text); end if; end if; if Local_ALI /= ALI.No_ALI_Id then Queue.Insert_Withed_Sources_For (Local_ALI, Source_Identity.Tree); ALI.Initialize_ALI; -- ALI.Util.Initialize_ALI_Source; end if; end Record_ALI_For; ---------------------- -- Phase_2_Makefile -- ---------------------- function Phase_2_Makefile (Src_Data : Queue.Source_Info) return Boolean is Object_Path : GNAT.OS_Lib.String_Access; Dep_File : Text_File; Start : Natural; Finish : Natural; Last_Obj : Natural; Was : Boolean := False; type Src_Record (F_Len : Natural) is record File : String (1 .. F_Len); TS : Time_Stamp_Type; end record; package Src_Vectors is new Ada.Containers.Indefinite_Vectors (Positive, Src_Record); Srcs : Src_Vectors.Vector; Compilation_OK : Boolean := True; Dep_File_OK : Boolean := False; Dep_Path : constant String := Get_Name_String (Src_Data.Id.Dep_Path); begin Open (Dep_File, Dep_Path); if Is_Valid (Dep_File) then Big_Loop : loop Skip_Loop : while not End_Of_File (Dep_File) loop Get_Line (Dep_File, Name_Buffer, Name_Len); if Name_Len > 0 and then Name_Buffer (1) /= '#' then -- Skip a first line that is an empty continuation line for J in 1 .. Name_Len - 1 loop exit Skip_Loop when Name_Buffer (J) /= ' '; end loop; exit Skip_Loop when Name_Buffer (Name_Len) /= '\'; end if; end loop Skip_Loop; Start := 1; Finish := Index (Name_Buffer (1 .. Name_Len), ": "); exit Big_Loop when Finish = 0; Last_Obj := Finish; loop Last_Obj := Last_Obj - 1; exit when Last_Obj = Start or else Name_Buffer (Last_Obj) /= ' '; end loop; while Start < Last_Obj and then Name_Buffer (Start) = ' ' loop Start := Start + 1; end loop; Object_Path := new String'(Name_Buffer (Start .. Last_Obj)); Dep_File_OK := True; Start := Finish + 2; -- Process each line Line_Loop : loop declare Line : constant String := Name_Buffer (1 .. Name_Len); Last : constant Natural := Name_Len; begin Name_Loop : loop -- Find the beginning of the next source path -- name. while Start < Last and then Line (Start) = ' ' loop Start := Start + 1; end loop; -- Go to next line when there is a -- continuation character \ at the end of the -- line. exit Name_Loop when Start = Last and then Line (Start) = '\'; -- We should not be at the end of the line, -- without a continuation character \. exit Line_Loop when Start = Last; -- Look for the end of the source path name Finish := Start; while Finish < Last loop if Line (Finish) = '\' then -- On Windows, a '\' is part of the path name, -- except when it is not the first character -- followed by another '\' or by a space. -- On other platforms, when we are getting a '\' -- that is not the last character of the line, -- the next character is part of the path name, -- even if it is a space. if On_Windows and then Finish = Start and then Line (Finish + 1) = '\' then Finish := Finish + 2; if Finish > Last then Put ("file """); Put (Dep_Path); Put_Line (""" has wrong format"); Keep_Dep_File := True; Compilation_OK := False; exit Big_Loop; end if; else Finish := Finish + 1; end if; else -- A space that is not preceded by '\' -- indicates the end of the path name. exit when Line (Finish + 1) = ' '; Finish := Finish + 1; end if; end loop; -- Check this source declare Src_Name : constant String := Line (Start .. Finish); -- This is a filename encoded by GCC for use as a -- Makefile dependency, with some characters -- escaped for this specific purpose. We are about -- to reuse it in a rewritten dependency file. -- We used to Normalize the path name at this -- point, and this turned out both wrong and -- unnecessary. -- It would be an error to apply Normalize_Pathname -- on it because normalised it can be different -- filename. For example on windows -- c:\path\filename.c escaped became -- c\:path\\filename.c. Normalize_Pathname would -- not understand that it is drive letter at first -- characters and prepend it with current -- directory. We do not need filename to be -- normalised in the GPR rewritten dependency file -- because it is going to be normalised relatively -- to the object directory at reading in -- GPR.Util.Need_To_Compile.Process_Makefile_Deps. Unescaped : constant String := OS_Lib.Normalize_Pathname (Unescape (Src_Name), Directory => Dir_Name (Dep_Path), Case_Sensitive => False); Source_2 : Source_Id; Src_TS : Time_Stamp_Type; begin Source_2 := Source_Paths_Htable.Get (Src_Data.Tree.Source_Paths_HT, Get_Path_Name_Id (Unescaped)); Src_TS := File_Stamp (Unescaped); if Src_TS = Empty_Time_Stamp then -- File from dependency list does not exist Put ('"'); Put (Get_Name_String (Src_Data.Id.Path.Display_Name)); Put_Line (""""); Put (ASCII.HT & "depends on non-existent """); Put (Unescaped); Put_Line (""""); Put (ASCII.HT & "noted in the """); Put (Dep_Path); Put_Line (""""); Keep_Dep_File := True; Compilation_OK := False; end if; if Source_2 /= No_Source then -- It is a source of a project if not Project_Extends (Src_Data.Id.Project, Source_2.Project) and then not Project_Extends (Source_2.Project, Src_Data.Id.Project) then -- It is not a source of the same project -- as the source just compiled. Check if -- it can be imported. if not Indirect_Imports then if Directly_Imports (Src_Data.Id.Project, Source_2.Project) then -- It is a source of a directly -- imported project. Record its -- project, for later processing. Imports.Set (Source_2.Project, True); else -- It is a source of a project that -- is not directly imported. Record -- the source for later processing. Included_Sources.Append (Source_2); end if; end if; if not Source_2.In_Interfaces and then not Source_2.Locally_Removed then -- It is not a source in the interfaces -- of its project. Report an error and -- invalidate the compilation. Put ('"'); Put (Get_Name_String (Src_Data.Id.Path.Display_Name)); Put (""" cannot import """); Put (Unescaped); Put_Line (""":"); Put (" it is not part of the " & "interfaces of its project """); Put (Get_Name_String (Source_2.Project.Display_Name)); Put_Line (""""); Compilation_OK := False; end if; end if; end if; Srcs.Append (Src_Record' (F_Len => Src_Name'Length, File => Src_Name, TS => Src_TS)); end; exit Line_Loop when Finish = Last; -- Go get the next source on the line Start := Finish + 1; end loop Name_Loop; end; -- If we are here, we had a continuation character -- \ at the end of the line, so we continue with -- the next line. Get_Line (Dep_File, Name_Buffer, Name_Len); Start := 1; Finish := 1; end loop Line_Loop; end loop Big_Loop; Close (Dep_File); if not Included_Sources.Is_Empty then -- Sources in project that are not directly imported -- have been found. Check if they may be imported by -- other allowed imported sources. declare L : Project_List := Src_Data.Id.Project.Imported_Projects; begin -- Put in hash table Imports the project trees -- rooted at the projects that are already in -- Imports. while L /= null loop if Imports.Get (L.Project) then Recursive_Import (L.Project); end if; L := L.Next; end loop; -- For all the imported sources from project not -- directly imported, check if their projects are -- in table imports. for Included of Included_Sources loop if not Imports.Get (Included.Project) then -- This source is either directly imported or -- imported from another source that should not be -- imported. Report an error and invalidate the -- compilation. Put ('"'); Put (Get_Name_String (Src_Data.Id.Path.Display_Name)); Put (""" cannot import """); Put (Get_Name_String (Included.Path.Display_Name)); Put_Line (""":"); Put (" """); Put (Get_Name_String (Src_Data.Id.Project.Display_Name)); Put (""" does not directly import project """); Put (Get_Name_String (Included.Project.Display_Name)); Put_Line (""""); Compilation_OK := False; end if; end loop; end; end if; end if; if Compilation_OK and Dep_File_OK then Create (Dep_File, Dep_Path); Put (Dep_File, Object_Path.all); Put (Dep_File, ": "); for Src of Srcs loop if Was then Put_Line (Dep_File, " \"); else Was := True; end if; Put (Dep_File, Src.File); Put (Dep_File, " "); Put (Dep_File, String (Src.TS)); end loop; Put_Line (Dep_File, ""); Close (Dep_File); end if; Free (Object_Path); return Compilation_OK; end Phase_2_Makefile; ----------------- -- Phase_2_ALI -- ----------------- function Phase_2_ALI (Src_Data : Queue.Source_Info) return Boolean is Compilation_OK : Boolean := True; Text : Text_Buffer_Ptr := Read_Library_Info_From_Full (File_Name_Type (Src_Data.Id.Dep_Path), Src_Data.Id.Dep_TS'Access); The_ALI : ALI.ALI_Id := ALI.No_ALI_Id; procedure Check_Source (Sfile : File_Name_Type); -- Check if source Sfile is in the same project file as the Src_Data -- source file. Invalidate the compilation if it is not. ------------------ -- Check_Source -- ------------------ procedure Check_Source (Sfile : File_Name_Type) is Source_3 : constant Source_Id := Find_Source (Src_Data.Tree, No_Project, Base_Name => Sfile); begin if Source_3 = No_Source then Put ("source "); Put (Get_Name_String (Sfile)); Put_Line (" is not a source of a project"); Compilation_OK := False; elsif Ultimate_Extending_Project_Of (Source_3.Project) /= Ultimate_Extending_Project_Of (Src_Data.Id.Project) then Put ("sources "); Put (Get_Name_String (Source_3.File)); Put (" and "); Put (Get_Name_String (Src_Data.Id.File)); Put (" belong to different projects: "); Put (Get_Name_String (Source_3.Project.Display_Name)); Put (" and "); Put_Line (Get_Name_String (Src_Data.Id.Project.Display_Name)); Compilation_OK := False; end if; end Check_Source; begin if Text /= null then -- Read the ALI file but read only the necessary lines The_ALI := ALI.Scan_ALI (File_Name_Type (Src_Data.Id.Dep_Path), Text, Ignore_ED => False, Err => True, Read_Lines => "DW"); if The_ALI /= ALI.No_ALI_Id then Check_Interface_And_Indirect_Imports (The_ALI => The_ALI, Src_Data => Src_Data, Success => Compilation_OK); if Opt.No_Split_Units then -- Initialized the list of subunits with the unit name Subunits.Clear; Subunits.Append (Get_Name_String (Src_Data.Id.Unit.Name)); -- First check that the spec and the body are in the same -- project. for J in ALI.ALIs.Table (The_ALI).First_Unit .. ALI.ALIs.Table (The_ALI).Last_Unit loop Check_Source (ALI.Units.Table (J).Sfile); end loop; -- Next, check the subunits, if any declare Subunit_Found : Boolean; Already_Found : Boolean; Last : Positive; begin -- Loop until we don't find new subunits loop Subunit_Found := False; for D in ALI.ALIs.Table (The_ALI).First_Sdep .. ALI.ALIs.Table (The_ALI).Last_Sdep loop if ALI.Sdep.Table (D).Subunit_Name /= No_Name then Get_Name_String (ALI.Sdep.Table (D).Subunit_Name); -- First check if we already found this subunit Already_Found := Subunits.Contains (Name_Buffer (1 .. Name_Len)); if not Already_Found then -- Find the name of the parent Last := Name_Len - 1; while Last > 1 and then Name_Buffer (Last + 1) /= '.' loop Last := Last - 1; end loop; if Subunits.Contains (Name_Buffer (1 .. Last)) then -- It is a new subunit, add it o the -- list and check if it is in the right -- project. Subunits.Append (Name_Buffer (1 .. Name_Len)); Subunit_Found := True; Check_Source (ALI.Sdep.Table (D).Sfile); end if; end if; end if; end loop; exit when not Subunit_Found; end loop; end; end if; if Compilation_OK and then (Builder_Data (Src_Data.Tree).Closure_Needed or else Src_Data.Closure) then Record_ALI_For (Src_Data, The_ALI); end if; end if; Free (Text); end if; return Compilation_OK; end Phase_2_ALI; -------------------------- -- Set_Options_For_File -- -------------------------- procedure Set_Options_For_File (Id : Source_Id) is Config : Language_Config renames Id.Language.Config; Builder_Options_Instance : constant String_Vector_Access := Builder_Compiling_Options_HTable.Get (Id.Language.Name); Comp_Opt : constant String_Vector_Access := Compiling_Options_HTable.Get (Id.Language.Name); List : Name_List_Index; Nam_Nod : Name_Node; First : Boolean; Index : Natural := 0; begin Compilation_Options.Clear; -- 1a) The leading required switches List := Config.Compiler_Leading_Required_Switches; First := True; while List /= No_Name_List loop Nam_Nod := Project_Tree.Shared.Name_Lists.Table (List); if Nam_Nod.Name /= Empty_String then Add_Option_Internal_Codepeer (Value => Get_Name_String (Nam_Nod.Name), To => Compilation_Options, Display => First or Opt.Verbose_Mode); First := False; end if; List := Nam_Nod.Next; end loop; -- 1b) The switches in CodePeer mode if Opt.CodePeer_Mode then -- Replace -x ada with -x adascil for J in 1 .. Compilation_Options.Last_Index loop if Compilation_Options (J).Name = "-x" then Compilation_Options.Replace_Element (J + 1, Option_Type' (Name_Len => 7, Name => "adascil", Displayed => True, Simple_Name => False)); Index := J; exit; end if; end loop; if Index = 0 then Add_Option (Value => "-x", To => Compilation_Options, Display => True, Simple_Name => False); Add_Option (Value => "adascil", To => Compilation_Options, Display => True, Simple_Name => False); end if; Add_Option (Value => "-gnatcC", To => Compilation_Options, Display => True); end if; -- 2) The compilation switches specified in package Builder -- for all compilers, following "-cargs", if any. for Option of All_Language_Builder_Compiling_Options loop Add_Option_Internal_Codepeer (Value => Option, To => Compilation_Options, Display => True); end loop; -- 3) The compilation switches specified in package Builder -- for the compiler of the language, following -- -cargs:. if Builder_Options_Instance /= null then for Option of Builder_Options_Instance.all loop Add_Option_Internal_Codepeer (Value => Option, To => Compilation_Options, Display => True); end loop; end if; -- 4) Compiler'Switches(), if it is -- defined, otherwise Compiler'Switches (), -- if defined. Add_Compilation_Switches (Id); -- 5) The switches specified on the gprbuild command line -- for all compilers, following "-cargs", if any. for Option of All_Language_Compiling_Options loop Add_Option_Internal_Codepeer (Value => Option, To => Compilation_Options, Display => True); end loop; -- 6) The switches specified on the gprbuild command line -- for the compiler of the language, following -- -cargs:. if Comp_Opt /= null then for Opt of Comp_Opt.all loop Add_Option_Internal_Codepeer (Value => Opt, To => Compilation_Options, Display => True); end loop; end if; -- 7) The PIC option if it exists, for shared and "static-pic" -- libraries. if Id.Project.Library and then Id.Project.Library_Kind /= Static then List := Config.Compilation_PIC_Option; while List /= No_Name_List loop Nam_Nod := Project_Tree.Shared.Name_Lists.Table (List); Add_Option_Internal_Codepeer (Value => Get_Name_String (Nam_Nod.Name), To => Compilation_Options, Display => True); List := Nam_Nod.Next; end loop; end if; end Set_Options_For_File; ------------------------- -- Check_Switches_File -- ------------------------- function Check_Switches_File (Id : Source_Id) return Boolean is File : Text_IO.File_Type; File_Content : String_Vectors.Vector; Expected_Content : String_Vectors.Vector; function Assert_Line (Current : String) return Boolean; -- Return False if Current is not the next line in the switches file ----------------- -- Assert_Line -- ----------------- function Assert_Line (Current : String) return Boolean is Line : String (1 .. 1_000); Last : Natural; begin if End_Of_File (File) then if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> switches file has fewer switches"); end if; Close (File); return False; end if; Get_Line (File, Line, Last); if Line (1 .. Last) /= Current then if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> switches file '" & Get_Name_String_Safe (Id.Switches_Path) & "' has different line"); Put_Line (" " & Line (1 .. Last)); Put_Line (" " & Current); end if; Close (File); return False; end if; return True; end Assert_Line; List : Name_List_Index; Nam_Nod : Name_Node; use GPR.Debug; begin if Opt.Verbosity_Level > Opt.Low and then Debug.Debug_Flag_S then Expected_Content.Append (String (Id.Object_TS)); for Opt of Compilation_Options loop Expected_Content.Append (Opt.Name); end loop; List := Id.Language.Config.Compiler_Trailing_Required_Switches; while List /= No_Name_List loop Nam_Nod := Project_Tree.Shared.Name_Lists.Table (List); Expected_Content.Append (Get_Name_String (Nam_Nod.Name)); List := Nam_Nod.Next; end loop; end if; Open (File, In_File, Get_Name_String (Id.Switches_Path)); if Opt.Verbosity_Level > Opt.Low and then Debug.Debug_Flag_S then declare Line : String (1 .. 1_000); Last : Natural; begin while not End_Of_File (File) loop Get_Line (File, Line, Last); File_Content.Append (Line (1 .. Last)); end loop; end; Reset (File); Put_Line (" expected .cswi file content:"); for S of Expected_Content loop Put_Line (" " & S); end loop; Put_Line (" actual .cswi file content:"); for S of File_Content loop Put_Line (" " & S); end loop; end if; if not Assert_Line (String (Id.Object_TS)) then return True; end if; for Opt of Compilation_Options loop if not Assert_Line (Opt.Name) then return True; end if; end loop; List := Id.Language.Config.Compiler_Trailing_Required_Switches; while List /= No_Name_List loop Nam_Nod := Project_Tree.Shared.Name_Lists.Table (List); if not Assert_Line (Get_Name_String (Nam_Nod.Name)) then return True; end if; List := Nam_Nod.Next; end loop; if not End_Of_File (File) then if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> switches file has more switches"); end if; Close (File); return True; end if; Close (File); return False; exception when others => if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> no switches file"); end if; return True; end Check_Switches_File; ------------------------ -- Update_Object_Path -- ------------------------ procedure Update_Object_Path (Id : Source_Id; Source_Project : Project_Id) is begin Id.Object_Project := Source_Project; if Id.Object_Project /= Id.Project then if Id.Object /= No_File then Get_Name_String (Id.Object_Project.Object_Directory.Display_Name); Get_Name_String_And_Append (Id.Object); Id.Object_Path := Name_Find; end if; if Id.Dep_Name /= No_File then Get_Name_String (Id.Object_Project.Object_Directory.Display_Name); Get_Name_String_And_Append (Id.Dep_Name); Id.Dep_Path := Name_Find; end if; if Id.Switches /= No_File then Get_Name_String (Id.Object_Project.Object_Directory.Display_Name); Get_Name_String_And_Append (Id.Switches); Id.Switches_Path := Name_Find; end if; end if; end Update_Object_Path; ---------------------------- -- Add_Dependency_Options -- ---------------------------- procedure Add_Dependency_Options (Id : Source_Id) is List : Name_List_Index := Id.Language.Config.Dependency_Option; Node : Name_Node; begin if Id.Language.Config.Dependency_Kind /= None then while List /= No_Name_List loop Node := Project_Tree.Shared.Name_Lists.Table (List); List := Node.Next; if List = No_Name_List then Add_Option (Value => Get_Name_String (Node.Name) & Get_Name_String (Id.Dep_Name), To => Compilation_Options, Display => Opt.Verbose_Mode); else Add_Option (Value => Node.Name, To => Compilation_Options, Display => Opt.Verbose_Mode); end if; end loop; end if; end Add_Dependency_Options; ------------------------------ -- Add_Object_File_Switches -- ------------------------------ procedure Add_Object_File_Switches (Id : Source_Id) is List : Name_List_Index := Id.Language.Config.Object_File_Switches; Node : Name_Node; begin if List /= No_Name_List then loop Node := Project_Tree.Shared.Name_Lists.Table (List); exit when Node.Next = No_Name_List; Add_Option (Node.Name, To => Compilation_Options, Display => Opt.Verbose_Mode or else Id.Index /= 0); List := Node.Next; end loop; Get_Name_String (Node.Name); Get_Name_String_And_Append (Id.Object); Add_Option (Name_Buffer (1 .. Name_Len), To => Compilation_Options, Display => Opt.Verbose_Mode or else Id.Index /= 0); -- Always specify object-file for a multi-unit source file elsif Id.Index /= 0 then Add_Option ("-o", To => Compilation_Options, Display => True); Add_Option (Get_Name_String (Id.Object), To => Compilation_Options, Display => True); end if; end Add_Object_File_Switches; ------------------------------ -- Add_Object_Path_Switches -- ------------------------------ procedure Add_Object_Path_Switches (Id : Source_Id) is List : Name_List_Index := Id.Language.Config.Object_Path_Switches; Node : Name_Node; begin if List /= No_Name_List then if Id.Project.Object_Path_File = No_Path then Create_Object_Path_File (Id.Project, Project_Tree.Shared); end if; while List /= No_Name_List loop Node := Project_Tree.Shared.Name_Lists.Table (List); exit when Node.Next = No_Name_List; Add_Option (Node.Name, To => Compilation_Options, Display => Opt.Verbose_Mode); List := Node.Next; end loop; Get_Name_String (Node.Name); Get_Name_String_And_Append (Id.Project.Object_Path_File); Add_Option (Name_Buffer (1 .. Name_Len), To => Compilation_Options, Display => Opt.Verbose_Mode); end if; end Add_Object_Path_Switches; ---------------------- -- Get_Config_Paths -- ---------------------- procedure Get_Config_Paths (Id : Source_Id; Source_Project : Project_Id) is Config : constant Language_Config := Id.Language.Config; procedure Add_Config_File (Project : Project_Id; Pkg, Attr : Name_Id); procedure Add_Config_File (Project : Project_Id; Pkg, Attr : Name_Id) is Config_File_Path : constant Path_Information := Config_File_For (Project => Project, Package_Name => Pkg, Attribute_Name => Attr, Language => Id.Language.Name); begin if Config_File_Path /= No_Path_Information and then not Cmd_Line_Adc_Files.Contains (Name_Id (Config_File_Path.Name)) then Last_Config_Path := Last_Config_Path + 1; The_Config_Paths (Last_Config_Path) := Config_File_Path; end if; end Add_Config_File; begin Last_Config_Path := 0; if Config.Config_File_Switches /= No_Name_List and then (Config.Config_Body /= No_Name or else Config.Config_Body_Index /= No_Name or else Config.Config_Body_Pattern /= No_Name or else Config.Config_Spec /= No_Name or else Config.Config_Spec_Index /= No_Name or else Config.Config_Spec_Pattern /= No_Name) and then not Config.Config_File_Unique then Add_Config_File (Main_Project, Name_Builder, Name_Global_Config_File); Add_Config_File (Source_Project, Name_Compiler, Name_Local_Config_File); end if; for CF in Cmd_Line_Adc_Files.Iterate loop Last_Config_Path := Last_Config_Path + 1; The_Config_Paths (Last_Config_Path) := (Name => Path_Name_Type (Name_Id_Maps.Key (CF)), Display_Name => Path_Name_Type (Name_Id_Maps.Element (CF))); end loop; end Get_Config_Paths; --------------------------------- -- Get_Target_Dependency_Paths -- --------------------------------- procedure Get_Target_Dependency_Paths is begin Last_Target_Dependency_Path := 0; for CF in Cmd_Line_Target_Dep_Info_Files.Iterate loop Last_Target_Dependency_Path := Last_Target_Dependency_Path + 1; Target_Dep_Paths (Last_Target_Dependency_Path) := (Name => Path_Name_Type (Name_Id_Maps.Key (CF)), Display_Name => Path_Name_Type (Name_Id_Maps.Element (CF))); end loop; end Get_Target_Dependency_Paths; ------------------------------ -- Add_Config_File_Switches -- ------------------------------ procedure Add_Config_File_Switches (Id : Source_Id; Source_Project : Project_Id) is Config : constant Language_Config := Id.Language.Config; -- Config_File_Path : Path_Name_Type; begin if Config.Config_File_Switches /= No_Name_List and then (Config.Config_Body /= No_Name or else Config.Config_Body_Index /= No_Name or else Config.Config_Body_Pattern /= No_Name or else Config.Config_Spec /= No_Name or else Config.Config_Spec_Index /= No_Name or else Config.Config_Spec_Pattern /= No_Name) then Create_Config_File (For_Project => Source_Project, Config => Config, Language => Id.Language.Name); if Source_Project.Config_File_Name /= No_Path then Add_Config_File_Switch (Config => Config, Path_Name => Source_Project.Config_File_Name); end if; for J in 1 .. Last_Config_Path loop Add_Config_File_Switch (Config => Config, Path_Name => The_Config_Paths (J).Display_Name); end loop; end if; end Add_Config_File_Switches; ------------------------------- -- Add_Mapping_File_Switches -- ------------------------------- function Add_Mapping_File_Switches (Source : Queue.Source_Info; Source_Project : Project_Id) return Path_Name_Type is List : Name_List_Index := Source.Id.Language.Config.Mapping_File_Switches; Node : Name_Node; Mapping_File_Path : Path_Name_Type; begin if List /= No_Name_List then -- Check if there is a temporary mapping file we can use Mapping_File_Path := Mapping_Files_Htable.Get_First (Source.Id.Language.Mapping_Files); if Mapping_File_Path /= No_Path then -- Reuse this temporary mapping file and remove its -- name from the HTable so that it is not reused -- before the compilation terminates. Mapping_Files_Htable.Remove (Source.Id.Language.Mapping_Files, Mapping_File_Path); else -- Create a new temporary mapping file, as there are -- none that can be reused. GPR.Env.Create_Mapping_File (Project => Source_Project, Language => Source.Id.Language.Name, In_Tree => Source.Tree, Name => Mapping_File_Path); end if; while List /= No_Name_List loop Node := Source.Tree.Shared.Name_Lists.Table (List); List := Node.Next; if List /= No_Name_List then Add_Option (Value => Node.Name, To => Compilation_Options, Display => Opt.Verbose_Mode); else Get_Name_String (Node.Name); Get_Name_String_And_Append (Mapping_File_Path); Add_Option (Name_Buffer (1 .. Name_Len), To => Compilation_Options, Display => Opt.Verbose_Mode); end if; end loop; return Mapping_File_Path; else return No_Path; end if; end Add_Mapping_File_Switches; ----------------------------- -- Add_Multi_Unit_Switches -- ----------------------------- procedure Add_Multi_Unit_Switches (Id : Source_Id) is List : Name_List_Index := Id.Language.Config.Multi_Unit_Switches; begin if Id.Index /= 0 and then List /= No_Name_List then declare Index_Img : constant String := Id.Index'Img; Node : Name_Node; begin loop Node := Project_Tree.Shared.Name_Lists.Table (List); exit when Node.Next = No_Name_List; Add_Option (Node.Name, To => Compilation_Options, Display => True); List := Node.Next; end loop; Get_Name_String (Node.Name); Add_Str_To_Name_Buffer (Index_Img (2 .. Index_Img'Last)); Add_Option (Name_Buffer (1 .. Name_Len), To => Compilation_Options, Display => True); end; end if; end Add_Multi_Unit_Switches; --------------------------- -- Add_Trailing_Switches -- --------------------------- procedure Add_Trailing_Switches (Id : Source_Id) is List : Name_List_Index := Id.Language.Config.Compiler_Trailing_Required_Switches; Node : Name_Node; begin while List /= No_Name_List loop Node := Project_Tree.Shared.Name_Lists.Table (List); Add_Option (Node.Name, To => Compilation_Options, Display => Opt.Verbose_Mode); List := Node.Next; end loop; end Add_Trailing_Switches; --------------------------------- -- Add_Name_Of_Source_Switches -- --------------------------------- procedure Add_Name_Of_Source_Switches (Id : Source_Id) is List : Name_List_Index := Id.Language.Config.Source_File_Switches; Node : Name_Node; begin -- Add any source file prefix if List /= No_Name_List then loop Node := Project_Tree.Shared.Name_Lists.Table (List); exit when Node.Next = No_Name_List; Add_Option (Node.Name, To => Compilation_Options, Display => Opt.Verbose_Mode or else Id.Index /= 0); List := Node.Next; end loop; end if; -- Then handle the source file Add_Option (Get_Name_String_Or_Null (Node.Name) & Get_Name_String (Id.Path.Display_Name), To => Compilation_Options, Display => True, Simple_Name => not Opt.Verbose_Mode); end Add_Name_Of_Source_Switches; --------------------------------- -- Spawn_Compiler_And_Register -- --------------------------------- procedure Spawn_Compiler_And_Register (Source : Queue.Source_Info; Source_Project : Project_Id; Compiler_Path : String; Mapping_File_Path : Path_Name_Type; Last_Switches_For_File : Integer) is procedure Add_Process (Process : GPR.Compilation.Id; Source : Queue.Source_Info; Source_Project : Project_Id; Mapping_File : Path_Name_Type; Purpose : Process_Purpose; Options : String_Vectors.Vector); -- Add compilation process and indicate that the object directory is -- busy. procedure Escape_Options (Options : in out Options_Data); -- On all platforms, escapes the characters '\', ' ' and '"' with -- character '\' before them. ----------------- -- Add_Process -- ----------------- procedure Add_Process (Process : GPR.Compilation.Id; Source : Queue.Source_Info; Source_Project : Project_Id; Mapping_File : Path_Name_Type; Purpose : Process_Purpose; Options : String_Vectors.Vector) is begin Compilation_Htable.Set (Process, (Process, Source, Source_Project, Mapping_File, Purpose, Options)); Outstanding_Compiles := Outstanding_Compiles + 1; Queue.Set_Obj_Dir_Busy (Source.Id.Project.Object_Directory.Name); end Add_Process; -------------------- -- Escape_Options -- -------------------- procedure Escape_Options (Options : in out Options_Data) is Last : constant Natural := Options.Last_Index; begin for J in 1 .. Last loop declare Opt : constant String := Options (J).Name; Nopt : constant String := Escape_Path (Opt); begin if Nopt'Length > Opt'Length then Options.Replace_Element (J, Option_Type' (Name_Len => Nopt'Length, Name => Nopt, Displayed => Options.Element (J).Displayed, Simple_Name => Options.Element (J).Simple_Name)); end if; end; end loop; end Escape_Options; ------------------ -- Get_Language -- ------------------ function Get_Language return String is (if Source.Id.Language /= null then Get_Name_String (Source.Id.Language.Name) else ""); Process : GPR.Compilation.Id; Response_File : Path_Name_Type := No_Path; -- Start of processing of Spawn_Compiler_And_Register begin if Opt.Use_GNU_Make_Jobserver then Jobserver.Preorder_Token; end if; if Opt.Use_GNU_Make_Jobserver and then Jobserver.Awaiting_Job_Slot then -- Save the previously created Mapping_File for ulterior uses Mapping_Files_Htable.Set (T => Source.Id.Language.Mapping_Files, K => Mapping_File_Path, E => Mapping_File_Path); return; else if not Opt.Quiet_Output then Name_Len := 0; if Opt.Verbose_Mode then Add_Str_To_Name_Buffer (Compiler_Path); for Opt of Compilation_Options loop Add_Str_To_Name_Buffer (" "); if Opt.Simple_Name then Add_Str_To_Name_Buffer (Base_Name (Opt.Name)); else Add_Str_To_Name_Buffer (Opt.Name); end if; end loop; Put_Line (Name_Buffer (1 .. Name_Len)); else Display (Section => GPR.Compile, Command => Get_Name_String (Source.Id.Language.Display_Name), Argument => Get_Name_String (Source.Id.File)); end if; end if; if Source_Project.Config.Max_Command_Line_Length > 0 and then Source.Id.Language.Config.Resp_File_Format = GCC_GNU then declare Arg_Length : Natural := 0; begin for Opt of Compilation_Options loop Arg_Length := Arg_Length + 1 + Opt.Name'Length; end loop; if Arg_Length > Source_Project.Config.Max_Command_Line_Length then declare use GPR.Tempdir; FD : File_Descriptor; Status : Integer; Closing_Status : Boolean; begin -- Escape the following characters in the options: -- '\', ' ' and '"'. Escape_Options (Compilation_Options); Create_Temp_File (FD, Response_File); Record_Temp_File (Shared => Source.Tree.Shared, Path => Response_File); Option_Loop : for Opt of Compilation_Options loop Status := Write (FD, Opt.Name (1)'Address, Opt.Name'Length); if Status /= Opt.Name'Length then Put_Line ("Could not write option """ & Opt.Name & """ in response file """ & Get_Name_String (Response_File) & """"); Response_File := No_Path; exit Option_Loop; end if; Status := Write (FD, ASCII.LF'Address, 1); end loop Option_Loop; Close (FD, Closing_Status); if not Closing_Status and then Response_File /= No_Path then Put_Line ("Could not close response file """ & Get_Name_String (Response_File) & """"); Response_File := No_Path; end if; end; if Opt.Verbosity_Level > Opt.Low and then Response_File /= No_Path then Put_Line ("using a response file"); end if; end if; end; end if; Process := Run (Compiler_Path, Options_List (Compilation_Options), Source_Project, Source => Get_Name_String (Source.Id.File), Language => Get_Language, Dep_Name => (if Source.Id.Dep_Name = No_File then "" else Get_Name_String (Source.Id.Dep_Name)), Obj_Name => (if Source.Id.Object = No_File then "" else Get_Name_String (Source.Id.Object)), Response_File => Response_File); if Last_Switches_For_File >= 0 then while Compilation_Options.Last_Index > Last_Switches_For_File loop Compilation_Options.Delete_Last; end loop; Add_Trailing_Switches (Source.Id); end if; Add_Process (Process => Process, Source => Source, Source_Project => Source_Project, Mapping_File => Mapping_File_Path, Purpose => Compilation, Options => Options_List (Compilation_Options)); if Opt.Use_GNU_Make_Jobserver then Register_Token_Id (Id => Process); end if; end if; end Spawn_Compiler_And_Register; ------------------------------ -- Get_Compatible_Languages -- ------------------------------ function Get_Compatible_Languages (Lang : Language_Ptr) return Name_Ids is NL : Name_List_Index := Lang.Config.Include_Compatible_Languages; Languages : Name_Ids (1 .. 1 + Length (Project_Tree.Shared.Name_Lists, NL)); Index : Positive := 1; begin Languages (Index) := Lang.Name; while NL /= No_Name_List loop Index := Index + 1; Languages (Index) := Project_Tree.Shared.Name_Lists.Table (NL).Name; NL := Project_Tree.Shared.Name_Lists.Table (NL).Next; end loop; return Languages; end Get_Compatible_Languages; ------------------------------- -- Prepare_Include_Path_File -- ------------------------------- procedure Prepare_Include_Path_File (Data : out Local_Project_Data; Project : Project_Id; Lang : Language_Ptr) is FD : File_Descriptor; Status : Boolean; begin Get_Directories (Project_Tree => Project_Tree, For_Project => Project, Activity => Compilation, Languages => Get_Compatible_Languages (Lang)); GPR.Env.Create_New_Path_File (Shared => Project_Tree.Shared, Path_FD => FD, Path_Name => Data.Include_Path_File); if FD = Invalid_FD then Fail_Program (Project_Tree, "could not create temporary path file"); end if; for Index in 1 .. Directories.Last loop Get_Name_String (Directories.Table (Index)); Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := ASCII.LF; if Write (FD, Name_Buffer (1)'Address, Name_Len) /= Name_Len then Fail_Program (Project_Tree, "disk full when writing include path file"); end if; end loop; Close (FD, Status); if not Status then Fail_Program (Project_Tree, "disk full when writing include path file"); end if; end Prepare_Include_Path_File; ------------------------------------ -- Prepare_Imported_Dirs_Switches -- ------------------------------------ procedure Prepare_Imported_Dirs_Switches (Data : out Local_Project_Data; Project : Project_Id; Lang : Language_Ptr) is Len : constant Natural := Length (Project_Tree.Shared.Name_Lists, Lang.Config.Include_Option); -- Host_Path : OS_Lib.String_Access; Last : Natural := 0; List : Name_List_Index; Nam : Name_Node; begin Get_Directories (Project_Tree => Project_Tree, For_Project => Project, Activity => Compilation, Languages => Get_Compatible_Languages (Lang)); Free (Data.Imported_Dirs_Switches); Data.Imported_Dirs_Switches := new String_List (1 .. Directories.Last * Len); for Index in 1 .. Directories.Last loop List := Lang.Config.Include_Option; while List /= No_Name_List loop Nam := Project_Tree.Shared.Name_Lists.Table (List); exit when Nam.Next = No_Name_List; Last := Last + 1; Data.Imported_Dirs_Switches (Last) := new String'(Get_Name_String (Nam.Name)); List := Nam.Next; end loop; Get_Name_String (Directories.Table (Index)); while Name_Len > 1 and then (Name_Buffer (Name_Len) = Directory_Separator or else Name_Buffer (Name_Len) = '/') loop Name_Len := Name_Len - 1; end loop; Last := Last + 1; -- Concatenate the last switch and the path in a single option Data.Imported_Dirs_Switches (Last) := new String' (Get_Name_String (Nam.Name) & Name_Buffer (1 .. Name_Len)); end loop; end Prepare_Imported_Dirs_Switches; ------------------------------ -- Set_Env_For_Include_Dirs -- ------------------------------ procedure Set_Env_For_Include_Dirs (Id : Source_Id; Source_Project : Project_Id) is Current_Project : Project_Id := No_Project; Current_Language_Ind : Language_Ptr := No_Language_Index; -- The project for which the include path environment has been set -- last, to avoid computing it several times. Data : Local_Project_Data := Local_Projects_HT.Get (Local_Projects, Id.Object_Project); begin -- Prepare (if not already done) the data for Project/Lang. -- All files for a given language are processed sequentially, before -- we switch to the next language, so we are only preparing once per -- language here. if Data.Include_Language /= Id.Language then Free (Data.Include_Path); Free (Data.Imported_Dirs_Switches); Data := No_Local_Project_Data; if Id.Language.Config.Include_Option /= No_Name_List then Prepare_Imported_Dirs_Switches (Data, Id.Object_Project, Id.Language); elsif Id.Language.Config.Include_Switches_Via_Spec /= No_Name_List then declare Include_Switches_Spec : File_Descriptor := Invalid_FD; Switches_File_Name : Path_Name_Type; Switches_File : File_Descriptor := Invalid_FD; Status : Boolean := False; Compiler : OS_Lib.String_Access; Switch : OS_Lib.String_Access; List : Name_List_Index := Id.Language.Config.Include_Switches_Via_Spec; Elem : Name_Node; begin Elem := Project_Tree.Shared.Name_Lists.Table (List); Compiler := new String'(Get_Name_String (Elem.Name)); List := Elem.Next; Elem := Project_Tree.Shared.Name_Lists.Table (List); Switch := new String'(Get_Name_String (Elem.Name)); Get_Directories (Project_Tree => Project_Tree, For_Project => Id.Object_Project, Activity => Compilation, Languages => Get_Compatible_Languages (Id.Language)); GPR.Env.Create_Temp_File (Project_Tree.Shared, Switches_File, Switches_File_Name, "include switches"); for Index in 1 .. Directories.Last loop Set_Name_Buffer (Switch.all); Add_Str_To_Name_Buffer (Escape_Path (Get_Name_String (Directories.Table (Index)))); Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := ASCII.LF; if Write (Switches_File, Name_Buffer (1)'Address, Name_Len) /= Name_Len then Fail_Program (Project_Tree, "disk full when writing include switches file"); end if; end loop; Close (Switches_File, Status); if not Status then Fail_Program (Project_Tree, "disk full when writing include switches file"); end if; GPR.Env.Create_Temp_File (Project_Tree.Shared, Include_Switches_Spec, Data.Include_Switches_Spec_File, "include switches spec"); Name_Len := 1; Name_Buffer (1) := '*'; Add_Str_To_Name_Buffer (Compiler.all); Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := ':'; Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := ASCII.LF; if Write (Include_Switches_Spec, Name_Buffer (1)'Address, Name_Len) /= Name_Len then Fail_Program (Project_Tree, "disk full when writing include switches spec file"); end if; Set_Name_Buffer ("+ @"); Add_Str_To_Name_Buffer (Escape_Path (Get_Name_String (Switches_File_Name))); Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := ASCII.LF; if Write (Include_Switches_Spec, Name_Buffer (1)'Address, Name_Len) /= Name_Len then Fail_Program (Project_Tree, "disk full when writing include switches spec file"); end if; Close (Include_Switches_Spec, Status); if not Status then Fail_Program (Project_Tree, "disk full when writing include switches spec file"); end if; Free (Compiler); Free (Switch); declare Path : constant String := Get_Name_String (Data.Include_Switches_Spec_File); begin Data.Imported_Dirs_Switches := new String_List' (1 => new String'("-specs=" & Path)); end; end; elsif Id.Language.Config.Include_Path_File /= No_Name then if Id.Language.Config.Mapping_File_Switches = No_Name_List or else Opt.Use_Include_Path_File then Prepare_Include_Path_File (Data, Id.Object_Project, Id.Language); end if; elsif Id.Language.Config.Include_Path /= No_Name then Get_Directories (Project_Tree => Project_Tree, For_Project => Id.Object_Project, Activity => Compilation, Languages => Get_Compatible_Languages (Id.Language)); Data.Include_Path := Create_Path_From_Dirs; end if; Data.Include_Language := Id.Language; Local_Projects_HT.Set (Local_Projects, Id.Object_Project, Data); end if; -- Reset environment variables if they have changed if Id.Object_Project /= Current_Project or else Id.Language /= Current_Language_Ind then Current_Project := Id.Object_Project; Current_Language_Ind := Id.Language; if Data.Include_Path_File /= No_Path then Setenv (Get_Name_String (Id.Language.Config.Include_Path_File), Get_Name_String (Data.Include_Path_File)); elsif Data.Include_Path /= null then GPR.Compilation.Process.Record_Environment (Source_Project, Id.Language.Name, Get_Name_String (Id.Language.Config.Include_Path), Data.Include_Path.all); if Opt.Verbosity_Level > Opt.Low then Put (Get_Name_String (Id.Language.Config.Include_Path)); Put (" = "); Put_Line (Data.Include_Path.all); end if; end if; end if; -- But always set the switches if Data.Imported_Dirs_Switches /= null then for J in Data.Imported_Dirs_Switches'Range loop if Data.Imported_Dirs_Switches (J)'Length > 0 then Add_Option (Value => Data.Imported_Dirs_Switches (J).all, To => Compilation_Options, Display => Opt.Verbose_Mode); end if; end loop; end if; end Set_Env_For_Include_Dirs; ----------------------------- -- Process_Project_Phase_1 -- ----------------------------- procedure Process_Project_Phase_1 (Source : Queue.Source_Info) is Id : constant Source_Id := Source.Id; Project_Tree : constant Project_Tree_Ref := Source.Tree; Source_Project : constant Project_Id := Ultimate_Extending_Project_Of (Id.Project); Dummy : Boolean; Compilation_Needed : Boolean := True; Last_Switches_For_File : Integer; Mapping_File : Path_Name_Type; The_ALI : ALI.ALI_Id; Compiler : OS_Lib.String_Access; begin Get_Config_Paths (Id, Source_Project); Get_Target_Dependency_Paths; if Always_Compile or else not Source_Project.Externally_Built then Need_To_Compile (Source => Id, Tree => Source.Tree, In_Project => Source_Project, Conf_Paths => The_Config_Paths (1 .. Last_Config_Path), Target_Dep_Paths => Target_Dep_Paths, Must_Compile => Compilation_Needed, The_ALI => The_ALI, Object_Check => Object_Checked, Always_Compile => Always_Compile); if Total_Errors_Detected > 0 then Compilation_Phase_Failed (Source.Tree, No_Message => Opt.No_Exit_Message); end if; if The_ALI /= ALI.No_ALI_Id then declare Success : Boolean := True; begin Check_Interface_And_Indirect_Imports (The_ALI => The_ALI, Src_Data => Source, Success => Success); if not Success then Compilation_Phase_Failed (Source.Tree, (if Exit_Code = E_Success then E_Fatal else Exit_Code), No_Message => Opt.No_Exit_Message); end if; end; end if; if Compilation_Needed and then Opt.Keep_Going then -- When in Keep_Going mode first check that we did not already -- tried to compile this source as part of another import of -- the corresponding project file. if Bad_Compilations.Contains (Id) then Compilation_Needed := False; end if; end if; if Compilation_Needed or else Opt.Check_Switches then Set_Options_For_File (Id); if Opt.Check_Switches and then not Compilation_Needed then Compilation_Needed := Check_Switches_File (Id); end if; end if; if Compilation_Needed then -- If Distributed_Mode activated, parse Remote package to -- register and initialize the slaves. if Distributed_Mode and then not Slave_Initialized then begin GPR.Compilation.Slave.Register_Remote_Slaves (Project_Tree, Main_Project); Slave_Initialized := True; exception when E : Constraint_Error => Fail_Program (Project_Tree, Exception_Information (E)); end; end if; Update_Object_Path (Id, Source_Project); Change_To_Object_Directory (Source_Project, Must_Be_Writable => True); -- Record the last recorded option index, to be able to -- write the switches file later. if Id.Language.Config.Object_Generated then Last_Switches_For_File := Compilation_Options.Last_Index; else Last_Switches_For_File := -1; end if; Add_Dependency_Options (Id); Set_Env_For_Include_Dirs (Id, Source_Project); Add_Config_File_Switches (Id, Source_Project); Mapping_File := Add_Mapping_File_Switches (Source, Source_Project); Add_Trailing_Switches (Id); Add_Name_Of_Source_Switches (Id); Add_Object_File_Switches (Id); Add_Multi_Unit_Switches (Id); Add_Object_Path_Switches (Id); Compiler := Get_Compiler_Driver_Path (Source_Project, Id.Language); if Compiler /= null then if Id.Switches_Path /= No_Path then -- Need to remove .cswi file so that it doesn't get -- reused in case of compilation failure. OS_Lib.Delete_File (Get_Name_String (Id.Switches_Path), Dummy); end if; Spawn_Compiler_And_Register (Source => Source, Source_Project => Source_Project, Compiler_Path => Compiler.all, Mapping_File_Path => Mapping_File, Last_Switches_For_File => Last_Switches_For_File); end if; else Print_Compilation_Outputs (Id); if Source.Closure or else (Builder_Data (Source.Tree).Closure_Needed and then Id.Language.Config.Dependency_Kind in ALI_Dependency) then Record_ALI_For (Source, The_ALI); else ALI.Initialize_ALI; end if; end if; end if; end Process_Project_Phase_1; -------------------------------- -- Must_Exit_Because_Of_Error -- -------------------------------- function Must_Exit_Because_Of_Error return Boolean is Source_Identity : Queue.Source_Info; Compilation_OK : Boolean; Slave : Unbounded_String; Cur : Bad_Compilations_Set.Cursor; OK : Boolean; begin if not Bad_Compilations.Is_Empty and then not Opt.Keep_Going then while Outstanding_Compiles > 0 loop Await_Compile (Source_Identity, Compilation_OK, Slave); if not Compilation_OK then Bad_Compilations.Insert (Source_Identity.Id, To_String (Slave), Cur, OK); end if; end loop; return True; end if; return False; end Must_Exit_Because_Of_Error; ------------------------------- -- Start_Compile_If_Possible -- ------------------------------- procedure Start_Compile_If_Possible is Found : Boolean; Source : Queue.Source_Info; begin if not Queue.Is_Empty and then (Opt.Use_GNU_Make_Jobserver or else Outstanding_Compiles < Get_Maximum_Processes) then Queue.Get (Found, Source); if Opt.Use_GNU_Make_Jobserver then Jobserver.Monitor; end if; if Found then Initialize_Source_Record (Source.Id); Process_Project_Phase_1 (Source); end if; if Opt.Use_GNU_Make_Jobserver and then Jobserver.Pending_Process then null; elsif Found then Queue.Next; end if; end if; end Start_Compile_If_Possible; ----------------------------- -- Wait_For_Available_Slot -- ----------------------------- procedure Wait_For_Available_Slot is Source_Identity : Queue.Source_Info; Compilation_OK : Boolean; No_Check : Boolean; Slave : Unbounded_String; use Queue; Cur : Bad_Compilations_Set.Cursor; OK : Boolean; function No_Slot_Available return Boolean; ----------------------- -- No_Slot_Available -- ----------------------- function No_Slot_Available return Boolean is begin if Opt.Use_GNU_Make_Jobserver then declare Condition : constant Boolean := (Unavailable_Job_Slot and then Registered_Processes); begin if GPR.Debug.Debug_Flag_J then Ada.Text_IO.Put_Line ("[ Jobserver ] No_Slot_Available -> " & Boolean'Image (Condition)); end if; return Condition; end; else return (Outstanding_Compiles = Get_Maximum_Processes); end if; end No_Slot_Available; begin if No_Slot_Available or else (Queue.Is_Virtually_Empty and then Outstanding_Compiles > 0) then Await_Compile (Source_Identity, Compilation_OK, Slave); if Compilation_OK and then Source_Identity /= Queue.No_Source_Info then -- Check if dependencies are on sources in Interfaces and, -- when --direct-import-only is used, the imported sources -- come from directly withed projects. Imports.Reset; Included_Sources.Clear; case Source_Identity.Id.Language.Config.Dependency_Kind is when None => null; when Makefile => Compilation_OK := Phase_2_Makefile (Source_Identity); when ALI_Dependency => Compilation_OK := Phase_2_ALI (Source_Identity); end case; -- If the compilation was invalidated, delete the compilation -- artifacts. if not Compilation_OK then if Source_Identity.Id.Dep_Path /= No_Path and then not Keep_Dep_File then Delete_File (Get_Name_String (Source_Identity.Id.Dep_Path), No_Check); end if; if Source_Identity.Id.Object_Path /= No_Path then Delete_File (Get_Name_String (Source_Identity.Id.Object_Path), No_Check); end if; if Source_Identity.Id.Switches_Path /= No_Path then Delete_File (Get_Name_String (Source_Identity.Id.Switches_Path), No_Check); end if; end if; end if; if not Compilation_OK then Bad_Compilations.Insert (Source_Identity.Id, To_String (Slave), Cur, OK); end if; end if; end Wait_For_Available_Slot; -- Start of processing for Compilation_Phase begin Outstanding_Compiles := 0; -- Then process each files in the queue (new files might be added to -- the queue as a result). Compilation_Loop : while not Queue.Is_Empty or else Outstanding_Compiles > 0 loop exit Compilation_Loop when Must_Exit_Because_Of_Error; Start_Compile_If_Possible; Wait_For_Available_Slot; if Opt.Display_Compilation_Progress then Put_Line ("completed" & Queue.Processed'Img & " out of" & Queue.Size'Img & " (" & Trim (Source => Int (((Queue.Processed) * 100) / Queue.Size)'Img, Side => Ada.Strings.Left) & "%)..."); end if; end loop Compilation_Loop; -- Release local memory declare Data : Local_Project_Data := Local_Projects_HT.Get_First (Local_Projects); begin while Data /= No_Local_Project_Data loop Free (Data.Include_Path); Free (Data.Imported_Dirs_Switches); Data := Local_Projects_HT.Get_Next (Local_Projects); end loop; Local_Projects_HT.Reset (Local_Projects); end; end Compilation_Phase; --------------------- -- Project_Extends -- --------------------- function Project_Extends (Extending : Project_Id; Extended : Project_Id) return Boolean is Current : Project_Id := Extending; begin loop if Current = No_Project then return False; elsif Current = Extended then return True; end if; Current := Current.Extends; end loop; end Project_Extends; end Gprbuild.Compile; gprbuild-25.0.0/src/gprbuild-compile.ads000066400000000000000000000031641470075373400201420ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2011-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ package Gprbuild.Compile is procedure Run; -- The first version compilations for a specific project tree. This needs -- to be called one for each aggregated projects, too. -- The second version will process all the main root project and all -- aggregated projects. end Gprbuild.Compile; gprbuild-25.0.0/src/gprbuild-link.adb000066400000000000000000004076011470075373400174320ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2011-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ with Ada.Calendar; use Ada.Calendar; with Ada.Containers.Indefinite_Hashed_Maps; with Ada.Containers.Vectors; with Ada.Strings.Fixed; use Ada.Strings.Fixed; with Ada.Strings.Hash; with Ada.Text_IO; use Ada.Text_IO; with Ada.Unchecked_Deallocation; use Ada; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.Expect; with GNAT.Strings; with Gpr_Build_Util; use Gpr_Build_Util; with Gprexch; use Gprexch; with GPR.Err; use GPR.Err; with GPR.Erroutc; use GPR.Erroutc; with GPR.Debug; use GPR.Debug; with GPR.Names; use GPR.Names; with GPR.Script; use GPR.Script; with GPR.Snames; use GPR.Snames; with GPR.Util.Aux; use GPR.Util; with GPR.Tempdir; package body Gprbuild.Link is type Archive_Data is record Checked : Boolean := False; Has_Been_Built : Boolean := False; Exists : Boolean := False; end record; type Source_Index_Rec is record Project : Project_Id; Id : Source_Id; Found : Boolean := False; end record; -- Used as Source_Indexes component to check if archive needs to be rebuilt type Source_Index_Array is array (Positive range <>) of Source_Index_Rec; type Source_Indexes_Ref is access Source_Index_Array; procedure Free is new Unchecked_Deallocation (Source_Index_Array, Source_Indexes_Ref); Initial_Source_Index_Count : constant Positive := 20; Source_Indexes : Source_Indexes_Ref := new Source_Index_Array (1 .. Initial_Source_Index_Count); -- A list of the Source_Ids, with an indication that they have been found -- in the archive dependency file. type Linker_Options_Data is record Project : Project_Id; Options : String_List_Id; end record; package Linker_Options_Vector is new Ada.Containers.Vectors (Positive, Linker_Options_Data); procedure Build_Global_Archive (For_Project : Project_Id; Project_Tree : Project_Tree_Ref; Has_Been_Built : out Boolean; Exists : out Boolean; Command : out String_Vectors.Vector; OK : out Boolean); -- Build, if necessary, the global archive for a main project. -- Out parameter Has_Been_Built is True iff the global archive has been -- built/rebuilt. Exists is False if there is no need for a global archive. -- OK is False when there is a problem building the global archive. procedure Link_Main (Main_File : in out Main_Info); -- Link a specific main unit procedure Add_Linker_Options (Arguments : in out Options_Data; For_Project : Project_Id); -- Get the Linker_Options from a project procedure Add_Rpath (Rpath : in out String_Vectors.Vector; Path : String); -- Add a path name to Rpath procedure Add_Rpath_From_Arguments (Rpath : in out String_Vectors.Vector; Arguments : Options_Data; Project : Project_Id); -- Add all explicit -L directives as an rpath procedure Rpaths_Relative_To (Rpaths : in out String_Vectors.Vector; Exec_Dir : Path_Name_Type; Origin : Name_Id); -- Change all paths in table Rpaths to paths relative to Exec_Dir, if they -- have at least one non root directory in common. function Is_In_Library_Project (Object_Path : String) return Boolean; -- Return True if Object_Path is the path of an object file in a library -- project. function Is_Object (Filename : String) return Boolean is (Filename'Length > Object_Suffix'Length and then Filename (Filename'Last - Object_Suffix'Length + 1 .. Filename'Last) = Object_Suffix); -- Returns True if filename ended with Object_Suffix procedure Display_Command (Arguments : Options_Data; Path : String_Access; Ellipse : Boolean := False); -- Display the command for a spawned process, if in Verbose_Mode or not in -- Quiet_Output. In non verbose mode, when Ellipse is True, display "..." -- in place of the first argument that has Display set to False. procedure Add_Argument (Arguments : in out Options_Data; Arg : String; Display : Boolean; Simple_Name : Boolean := False); -- Add an argument to Arguments. Reallocate if necessary procedure Add_Arguments (Arguments : in out Options_Data; Args : String_Vectors.Vector; Display : Boolean; Simple_Name : Boolean := False); -- Add a list of arguments to Arguments. Reallocate if necessary No_Archive_Data : constant Archive_Data := (Checked => False, Has_Been_Built => False, Exists => False); package Global_Archives_Built is new GNAT.HTable.Simple_HTable (Header_Num => GPR.Header_Num, Element => Archive_Data, No_Element => No_Archive_Data, Key => Name_Id, Hash => GPR.Hash, Equal => "="); -- A hash table to record what global archives have been already built Path_Options : String_Vectors.Vector; -- Directories coming from the binder exchange file package Library_Dirs is new GNAT.HTable.Simple_HTable (Header_Num => GPR.Header_Num, Element => Boolean, No_Element => False, Key => Path_Name_Type, Hash => Hash, Equal => "="); -- A hash table to store the library dirs, to avoid repeating uselessly -- the same switch when linking executables. Last_Source : Natural := 0; -- The index of the last valid component of Source_Indexes ------------------ -- Add_Argument -- ------------------ procedure Add_Argument (Arguments : in out Options_Data; Arg : String; Display : Boolean; Simple_Name : Boolean := False) is begin -- Nothing to do if no argument is specified or if argument is empty if Arg'Length /= 0 then -- Add the argument and its display indication Arguments.Append (Option_Type' (Name_Len => Arg'Length, Name => Arg, Displayed => Display, Simple_Name => Simple_Name)); end if; end Add_Argument; ------------------- -- Add_Arguments -- ------------------- procedure Add_Arguments (Arguments : in out Options_Data; Args : String_Vectors.Vector; Display : Boolean; Simple_Name : Boolean := False) is begin -- Add the new arguments and the display indications for Arg of Args loop Add_Argument (Arguments, Arg, Display, Simple_Name); end loop; end Add_Arguments; --------------- -- Add_Rpath -- --------------- procedure Add_Rpath (Rpath : in out String_Vectors.Vector; Path : String) is -- Rpaths are always considered case sensitive, as it's a runtime -- property of dynamic objects, so in case of cross compilation is -- independent of the host's way of handling case sensitivity Normalized : constant String := Normalize_Pathname (Path, Resolve_Links => Opt.Follow_Links_For_Dirs, Case_Sensitive => True); begin -- Nothing to do if Path is empty if Path'Length = 0 then return; end if; -- Nothing to do if the directory is already in the Rpaths table for Path of Rpath loop if Path = Normalized then return; end if; end loop; Rpath.Append (Normalized); end Add_Rpath; ------------------------------ -- Add_Rpath_From_Arguments -- ------------------------------ procedure Add_Rpath_From_Arguments (Rpath : in out String_Vectors.Vector; Arguments : Options_Data; Project : Project_Id) is LSwitch : constant String := (if Project.Config.Linker_Lib_Dir_Option = No_Name then "-L" else Get_Name_String (Project.Config.Linker_Lib_Dir_Option)); begin for Arg of Arguments loop if Arg.Name_Len > LSwitch'Length and then Arg.Name (Arg.Name'First .. Arg.Name'First + LSwitch'Length - 1) = LSwitch then Add_Rpath (Rpath, Arg.Name (Arg.Name'First + LSwitch'Length .. Arg.Name'Last)); end if; end loop; end Add_Rpath_From_Arguments; -------------------------- -- Build_Global_Archive -- -------------------------- procedure Build_Global_Archive (For_Project : Project_Id; Project_Tree : Project_Tree_Ref; Has_Been_Built : out Boolean; Exists : out Boolean; Command : out String_Vectors.Vector; OK : out Boolean) is Archive_Name : constant String := "lib" & Get_Name_String (For_Project.Name) & Archive_Suffix (For_Project); -- The name of the archive file for this project Archive_Dep_Name : constant String := "lib" & Get_Name_String (For_Project.Name) & ".deps"; -- The name of the archive dependency file for this project File : GPR.Util.Text_File; Object_Path : Path_Name_Type; Time_Stamp : Time_Stamp_Type; First_Object : Natural; Current_Object : Positive; Discard : Boolean; Proj_List : Project_List; Src_Id : Source_Id; S_Id : Source_Id; Success : Boolean; Size : Natural; Global_Archive_Data : Archive_Data; Need_To_Build : Boolean; Arguments : Options_Data; Objects : String_Vectors.Vector; procedure Add_Sources (Proj : Project_Id); -- Add all the sources of project Proj to Sources_Index function Get_Objects (Proj : Project_Id) return String_Vectors.Vector; -- Add all the object paths of project Proj to Arguments procedure Handle_Failure; procedure Report_Status (Archive_Built : Boolean; Archive_Exists : Boolean); ----------------- -- Add_Sources -- ----------------- procedure Add_Sources (Proj : Project_Id) is Project : Project_Id := Proj; Id : Source_Id; Iter : Source_Iterator; procedure Add_Source_Id (Project : Project_Id; Id : Source_Id); -- Add a source id to Source_Indexes, with Found set to False ------------------- -- Add_Source_Id -- ------------------- procedure Add_Source_Id (Project : Project_Id; Id : Source_Id) is begin -- Reallocate the array, if necessary if Last_Source = Source_Indexes'Last then declare New_Indexes : constant Source_Indexes_Ref := new Source_Index_Array (1 .. Source_Indexes'Last + Initial_Source_Index_Count); begin New_Indexes (Source_Indexes'Range) := Source_Indexes.all; Free (Source_Indexes); Source_Indexes := New_Indexes; end; end if; Last_Source := Last_Source + 1; Source_Indexes (Last_Source) := (Project, Id, False); end Add_Source_Id; begin while Project /= No_Project loop Iter := For_Each_Source (Project_Tree, Project); loop Id := GPR.Element (Iter); exit when Id = No_Source; if Is_Compilable (Id) and then Id.Kind = Impl and then Id.Unit = No_Unit_Index then Add_Source_Id (Proj, Id); end if; Next (Iter); end loop; Project := Project.Extends; end loop; end Add_Sources; ----------------- -- Add_Objects -- ----------------- function Get_Objects (Proj : Project_Id) return String_Vectors.Vector is Project : Project_Id := Proj; Id : Source_Id; Iter : Source_Iterator; Ret : String_Vectors.Vector; package Sort is new String_Vectors.Generic_Sorting; begin loop if Project.Object_Directory /= No_Path_Information then if Project.Externally_Built then -- If project is externally built, include all object files -- in the object directory in the global archive. declare Obj_Dir : constant String := Get_Name_String (Project.Object_Directory.Display_Name); Dir_Obj : Dir_Type; begin if Is_Regular_File (Obj_Dir) then Open (Dir_Obj, Obj_Dir); loop Read (Dir_Obj, Name_Buffer, Name_Len); exit when Name_Len = 0; Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); if Is_Object (Name_Buffer (1 .. Name_Len)) then Ret.Append (Obj_Dir & Directory_Separator & Name_Buffer (1 .. Name_Len)); end if; end loop; Close (Dir_Obj); end if; end; else Iter := For_Each_Source (Project_Tree, Project); loop Id := GPR.Element (Iter); exit when Id = No_Source; if Object_To_Global_Archive (Id) then -- The source record may not be initialized if -- gprbuild was called with the switch -l. Initialize_Source_Record (Id); Ret.Append (Get_Name_String (Id.Object_Path)); end if; Next (Iter); end loop; end if; end if; Project := Project.Extends; exit when Project = No_Project; end loop; -- Make sure the objects are sorted alphabetically Sort.Sort (Ret); return Ret; end Get_Objects; -------------------- -- Handle_Failure -- -------------------- procedure Handle_Failure is begin -- Building the archive failed, delete dependency file if -- one exists. if Is_Regular_File (Archive_Dep_Name) then Delete_File (Archive_Dep_Name, Success); end if; Put ("global archive for project "); Put (Get_Name_String (For_Project.Display_Name)); Put_Line (" could not be built"); OK := False; end Handle_Failure; ------------------- -- Report_Status -- ------------------- procedure Report_Status (Archive_Built : Boolean; Archive_Exists : Boolean) is begin Has_Been_Built := Archive_Built; Exists := Archive_Exists; Global_Archives_Built.Set (Name_Id (For_Project.Path.Name), (Checked => True, Has_Been_Built => Archive_Built, Exists => Archive_Exists)); end Report_Status; begin Exists := False; Has_Been_Built := False; OK := True; if For_Project.Object_Directory = No_Path_Information then return; end if; -- No need to build the global archive, if it has already been done Global_Archive_Data := Global_Archives_Built.Get (Name_Id (For_Project.Path.Name)); if Global_Archive_Data.Checked then Has_Been_Built := Global_Archive_Data.Has_Been_Built; Exists := Global_Archive_Data.Exists; -- No processing needed: already processed. Let's return return; end if; Change_To_Object_Directory (For_Project); -- Put all non Ada sources in the project tree in Source_Indexes Last_Source := 0; Add_Sources (For_Project); Proj_List := For_Project.All_Imported_Projects; while Proj_List /= null loop if not Proj_List.Project.Library then Add_Sources (Proj_List.Project); end if; Proj_List := Proj_List.Next; end loop; Need_To_Build := Opt.Force_Compilations; if not Need_To_Build then if Opt.Verbosity_Level > Opt.Low then Put (" Checking "); Put (Archive_Name); Put_Line (" ..."); end if; -- If the archive does not exist, of course it needs to be -- built. if not Is_Regular_File (Archive_Name) then Need_To_Build := True; if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> archive does not exist"); end if; else -- Archive does exist -- Check the archive dependency file Open (File, Archive_Dep_Name); -- If the archive dependency file does not exist, we need to -- to rebuild the archive and to create its dependency file. if not Is_Valid (File) then Need_To_Build := True; if Opt.Verbosity_Level > Opt.Low then Put (" -> archive dependency file "); Put (Archive_Dep_Name); Put_Line (" does not exist"); end if; else -- Read the dependency file, line by line while not End_Of_File (File) loop Get_Line (File, Name_Buffer, Name_Len); -- First line is the path of the object file Object_Path := Name_Find; Src_Id := No_Source; -- Check if this object file is for a source of this -- project. for S in 1 .. Last_Source loop S_Id := Source_Indexes (S).Id; if not Source_Indexes (S).Found and then S_Id.Object_Path = Object_Path then -- We have found the object file: get the -- source data, and mark it as found. Src_Id := S_Id; Source_Indexes (S).Found := True; exit; end if; end loop; -- If it is not for a source of this project, then the -- archive needs to be rebuilt. if Src_Id = No_Source then Need_To_Build := True; if Opt.Verbosity_Level > Opt.Low then Put (" -> "); Put (Get_Name_String (Object_Path)); Put_Line (" is not an object of any project"); end if; exit; end if; -- The second line is the time stamp of the object -- file. If there is no next line, then the dependency -- file is truncated, and the archive need to be -- rebuilt. if End_Of_File (File) then Need_To_Build := True; if Opt.Verbosity_Level > Opt.Low then Put (" -> archive dependency file "); Put_Line (" is truncated"); end if; exit; end if; Get_Line (File, Name_Buffer, Name_Len); -- If the line has the wrong number of characters, -- then the dependency file is incorrectly formatted, -- and the archive needs to be rebuilt. if Name_Len /= Time_Stamp_Length then Need_To_Build := True; if Opt.Verbosity_Level > Opt.Low then Put (" -> archive dependency file "); Put_Line (" is incorrectly formatted (time stamp)"); end if; exit; end if; Time_Stamp := Time_Stamp_Type (Name_Buffer (1 .. Name_Len)); -- If the time stamp in the dependency file is -- different from the time stamp of the object file, -- then the archive needs to be rebuilt. The -- comparaison is done with String type values, -- because two values of type Time_Stamp_Type are -- equal if they differ by 2 seconds or less; here the -- check is for an exact match. if String (Time_Stamp) /= String (Src_Id.Object_TS) then Need_To_Build := True; if Opt.Verbosity_Level > Opt.Low then Put (" -> time stamp of "); Put (Get_Name_String (Object_Path)); Put (" is incorrect in the archive"); Put_Line (" dependency file"); Put (" recorded time stamp: "); Put_Line (String (Time_Stamp)); Put (" actual time stamp: "); Put_Line (String (Src_Id.Object_TS)); end if; exit; elsif Debug_Flag_T then Put (" -> time stamp of "); Put (Get_Name_String (Object_Path)); Put (" is correct in the archive"); Put_Line (" dependency file"); Put (" recorded time stamp: "); Put_Line (String (Time_Stamp)); Put (" actual time stamp: "); Put_Line (String (Src_Id.Object_TS)); end if; end loop; Close (File); end if; end if; end if; if not Need_To_Build then for S in 1 .. Last_Source loop if not Source_Indexes (S).Found and then Object_To_Global_Archive (Source_Indexes (S).Id) then Need_To_Build := True; if Opt.Verbosity_Level > Opt.Low then Put (" -> object file "); Put (Get_Name_String (Source_Indexes (S).Id.Object_Path)); Put_Line (" is not in the dependency file"); end if; exit; end if; end loop; end if; if not Need_To_Build then if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> up to date"); end if; Report_Status (Archive_Built => False, Archive_Exists => True); -- No processing needed: up-to-date. Let's return return; end if; -- If archive already exists, first delete it, but if this is -- not possible, continue: if archive cannot be built, we will -- fail later on. if Is_Regular_File (Archive_Name) then Delete_File (Archive_Name, Discard); end if; -- Get all the object files of the non library projects Objects := Get_Objects (For_Project); Proj_List := For_Project.All_Imported_Projects; while Proj_List /= null loop if not Proj_List.Project.Library then Objects.Append_Vector (Get_Objects (Proj_List.Project)); end if; Proj_List := Proj_List.Next; end loop; -- No global archive, if there is no object file to put into if Objects.Is_Empty then if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> there is no global archive"); end if; Report_Status (Archive_Built => False, Archive_Exists => False); return; end if; First_Object := Objects.First_Index; -- If there is an Archive_Builder_Append_Option, we may have -- to build the archive in chunks. loop Arguments.Clear; Command.Clear; -- Start with the minimal options if First_Object = Objects.First_Index then -- Creation of a new archive Arguments.Append_Vector (Archive_Builder_Opts); else -- Append objects to an existing archive Arguments.Append_Vector (Archive_Builder_Append_Opts); end if; -- Followed by the archive name Add_Argument (Arguments, Archive_Name, Display => True, Simple_Name => not Opt.Verbose_Mode); if Archive_Builder_Append_Opts.Is_Empty then Current_Object := Objects.Last_Index; else Size := 0; for Arg of Arguments loop Size := Size + Arg.Name_Len + 1; end loop; for J in First_Object .. Objects.Last_Index loop Size := Size + Objects.Element (J)'Length + 1; exit when Size > Maximum_Size; Current_Object := J; end loop; end if; for J in First_Object .. Current_Object loop Add_Argument (Arguments, Objects (J), Display => Opt.Verbose_Mode, Simple_Name => not Opt.Verbose_Mode); end loop; First_Object := Current_Object + 1; if not Opt.Quiet_Output then if Opt.Verbose_Mode then Display_Command (Arguments, Archive_Builder_Path, Ellipse => True); else Display (Section => GPR.Link, Command => "archive", Argument => Archive_Name); end if; end if; declare Options : String_Vectors.Vector; begin Command.Append (Archive_Builder_Path.all); for Arg of Arguments loop Options.Append (Arg.Name); Command.Append (Arg.Name); end loop; Spawn_And_Script_Write (Archive_Builder_Path.all, Options, Success); end; if not Success then Handle_Failure; return; end if; -- Continue until all objects are in the archive exit when First_Object > Objects.Last_Index; end loop; -- The archive was built, run the archive indexer -- (ranlib) if there is one. if Archive_Indexer_Path /= null then Arguments.Clear; Command.Clear; Arguments.Append_Vector (Archive_Indexer_Opts); Add_Argument (Arguments, Archive_Name, True, Simple_Name => not Opt.Verbose_Mode); if not Opt.Quiet_Output then if Opt.Verbose_Mode then Display_Command (Arguments, Archive_Indexer_Path); else Display (Section => GPR.Link, Command => "index", Argument => Archive_Name); end if; end if; declare Options : String_Vectors.Vector; begin Command.Append (Archive_Indexer_Path.all); for Arg of Arguments loop Options.Append (Arg.Name); Command.Append (Arg.Name); end loop; Spawn_And_Script_Write (Archive_Indexer_Path.all, Options, Success); end; if not Success then -- Running the archive indexer failed, delete the -- dependency file, if it exists. if Is_Regular_File (Archive_Dep_Name) then Delete_File (Archive_Dep_Name, Success); end if; Handle_Failure; return; end if; end if; -- The archive was correctly built, create its dependency -- file. declare Dep_File : Text_IO.File_Type; begin -- Create the file in Append mode, to avoid automatic -- insertion of an end of line if file is empty. Create (Dep_File, Append_File, Archive_Dep_Name); for S in 1 .. Last_Source loop Src_Id := Source_Indexes (S).Id; if Object_To_Global_Archive (Src_Id) then Put_Line (Dep_File, Get_Name_String (Src_Id.Object_Path)); Put_Line (Dep_File, String (Src_Id.Object_TS)); end if; end loop; Close (Dep_File); exception when others => if Is_Open (Dep_File) then Close (Dep_File); end if; end; Report_Status (Archive_Built => True, Archive_Exists => True); end Build_Global_Archive; --------------------- -- Display_Command -- --------------------- procedure Display_Command (Arguments : Options_Data; Path : String_Access; Ellipse : Boolean := False) is Display_Ellipse : Boolean := Ellipse; begin -- Only display the command in Verbose Mode (-v) or when -- not in Quiet Output (no -q). if not Opt.Quiet_Output then Name_Len := 0; if Opt.Verbose_Mode then Add_Str_To_Name_Buffer (Path.all); for Arg of Arguments loop if Arg.Displayed then Add_Str_To_Name_Buffer (" "); if Arg.Simple_Name then Add_Str_To_Name_Buffer (Base_Name (Arg.Name)); else Add_Str_To_Name_Buffer (Arg.Name); end if; elsif Display_Ellipse then Add_Str_To_Name_Buffer (" ..."); Display_Ellipse := False; end if; end loop; Put_Line (Name_Buffer (1 .. Name_Len)); end if; end if; end Display_Command; ------------------------ -- Add_Linker_Options -- ------------------------ procedure Add_Linker_Options (Arguments : in out Options_Data; For_Project : Project_Id) is Linker_Lib_Dir_Option : String_Access; Linker_Opts : Linker_Options_Vector.Vector; -- Table to store the Linker'Linker_Options in the project files procedure Recursive_Add (Proj : Project_Id; Tree : Project_Tree_Ref; Dummy : in out Boolean); -- The recursive routine used to add linker options ------------------- -- Recursive_Add -- ------------------- procedure Recursive_Add (Proj : Project_Id; Tree : Project_Tree_Ref; Dummy : in out Boolean) is pragma Unreferenced (Dummy); Linker_Package : Package_Id; Options : Variable_Value; begin if Proj /= For_Project then Linker_Package := GPR.Util.Value_Of (Name => Name_Linker, In_Packages => Proj.Decl.Packages, Shared => Tree.Shared); Options := GPR.Util.Value_Of (Name => Name_Ada, Index => 0, Attribute_Or_Array_Name => Name_Linker_Options, In_Package => Linker_Package, Shared => Tree.Shared); -- If attribute is present, add the project with -- the attribute to table Linker_Opts. if Options /= Nil_Variable_Value then Linker_Opts.Append (Linker_Options_Data' (Project => Proj, Options => Options.Values)); end if; end if; end Recursive_Add; procedure For_All_Projects is new For_Every_Project_Imported (Boolean, Recursive_Add); Dummy : Boolean := False; -- Start of processing for Get_Linker_Options begin if For_Project.Config.Linker_Lib_Dir_Option = No_Name then Linker_Lib_Dir_Option := new String'("-L"); else Linker_Lib_Dir_Option := new String' (Get_Name_String (For_Project.Config.Linker_Lib_Dir_Option)); end if; Linker_Opts.Clear; For_All_Projects (For_Project, Project_Tree, Dummy, Imported_First => True); for Index in reverse 1 .. Linker_Opts.Last_Index loop declare Options : String_List_Id := Linker_Opts (Index).Options; Proj : constant Project_Id := Linker_Opts (Index).Project; Option : Name_Id; Dir_Path : constant String := Get_Name_String (Proj.Directory.Display_Name); begin while Options /= Nil_String loop Option := Project_Tree.Shared.String_Elements.Table (Options).Value; Get_Name_String (Option); -- Do not consider empty linker options if Name_Len /= 0 then -- Object files and -L switches specified with relative -- paths must be converted to absolute paths. if Name_Len > Linker_Lib_Dir_Option'Length and then Name_Buffer (1 .. Linker_Lib_Dir_Option'Length) = Linker_Lib_Dir_Option.all then if Is_Absolute_Path (Name_Buffer (Linker_Lib_Dir_Option'Length + 1 .. Name_Len)) then Add_Argument (Arguments, Name_Buffer (1 .. Name_Len), True); else declare Dir : constant String := Dir_Path & Directory_Separator & Name_Buffer (Linker_Lib_Dir_Option'Length + 1 .. Name_Len); begin if Is_Directory (Dir) then Add_Argument (Arguments, Linker_Lib_Dir_Option.all & Dir, True); else -- ??? Really ignore the -L switch given by the -- project? Add_Argument (Arguments, Name_Buffer (1 .. Name_Len), True); end if; end; end if; elsif Name_Buffer (1) = '-' or else Is_Absolute_Path (Name_Buffer (1 .. Name_Len)) then Add_Argument (Arguments, Name_Buffer (1 .. Name_Len), True); else declare File : constant String := Dir_Path & Directory_Separator & Name_Buffer (1 .. Name_Len); begin if Is_Regular_File (File) then Add_Argument (Arguments, File, True, Simple_Name => True); else Add_Argument (Arguments, Name_Buffer (1 .. Name_Len), True); end if; end; end if; end if; Options := Project_Tree.Shared.String_Elements.Table (Options).Next; end loop; end; end loop; end Add_Linker_Options; --------------------------- -- Is_In_Library_Project -- --------------------------- function Is_In_Library_Project (Object_Path : String) return Boolean is Path_Id : constant Path_Name_Type := Create_Name (Object_Path); Src : Source_Id; Iter : Source_Iterator; begin Iter := For_Each_Source (Project_Tree); loop Src := GPR.Element (Iter); exit when Src = No_Source; if Src.Object_Path = Path_Id then return Src.Project.Library; end if; Next (Iter); end loop; return False; end Is_In_Library_Project; ------------------------ -- Rpaths_Relative_To -- ------------------------ procedure Rpaths_Relative_To (Rpaths : in out String_Vectors.Vector; Exec_Dir : Path_Name_Type; Origin : Name_Id) is Origin_Name : constant String := Get_Name_String (Origin); Exec : constant String := Get_Name_String (Exec_Dir); Ret : String_Vectors.Vector; begin for Path of Rpaths loop Ret.Append (Relative_RPath (Path, Exec, Origin_Name)); end loop; Rpaths := Ret; end Rpaths_Relative_To; --------------- -- Link_Main -- --------------- procedure Link_Main (Main_File : in out Main_Info) is function Global_Archive_Name (For_Project : Project_Id) return String; -- Returns the name of the global archive for a project procedure Add_Run_Path_Options; -- Add the run path option switch. if there is one procedure Remove_Duplicated_Specs (Arguments : in out Options_Data); -- Remove duplicated --specs=... options from Arguments, -- keep right-most. procedure Remove_Duplicated_T (Arguments : in out Options_Data); -- Remove duplicated -T[ ] options from Arguments, -- keep left-most. procedure Load_Bindfile_Option_Substitution; -- Load all Bindfile_Option_Substitution attributes into -- Bindfile_Option_Substitution container. function Apply_Bindfile_Option_Substitution (Option : String) return Boolean; -- Append string list from Bindfile_Option_Substitution (Option) into -- Binding_Options. procedure Add_To_Other_Arguments (A : String) with Inline; -- Add argument to Other_Arguments procedure Fill_Options_Data_From_Arg_List_Access (ALA : Argument_List_Access; OD : out Options_Data); -- Fill an Options_Data structure (used by -- Display_Command) from an Argument_List_Access -- structure (used by the various spawning utilities). -- The Options_Data object is cleared first. function Rust_Linker_Helper_Switches (Lib_Name : Path_Name_Type) return String_Access; -- Locate gprbuild-rust-linker-helper tool on the PATH and execute the -- tool in order to retrieve the correct switches to link the Ada -- executable to the Rust static libraries. package String_Values is new Ada.Containers.Indefinite_Hashed_Maps (String, String_List_Id, Ada.Strings.Hash, "="); Bindfile_Option_Substitution : String_Values.Map; Were_Options : String_Sets.Set; -- Keep options already included Linker_Name : String_Access := null; Linker_Path : String_Access; Min_Linker_Opts : Name_List_Index; Exchange_File : Text_IO.File_Type; Line : String (1 .. 1_000); Last : Natural; Section : Binding_Section := No_Binding_Section; Linker_Needs_To_Be_Called : Boolean; Executable_TS : Time; Main_Object_TS : Time; Binder_Exchange_TS : Time; Binder_Object_TS : Time := Time_Of (2000, 1, 1); Global_Archive_TS : Time; function File_Stamp (File : Path_Name_Type) return Time is (File_Time_Stamp (Get_Name_String (File))); -- Returns file modification time Global_Archive_Has_Been_Built : Boolean; Global_Archive_Exists : Boolean; OK : Boolean; Disregard : Boolean; B_Data : Binding_Data; -- Main already has the right canonical casing Main : constant String := Get_Name_String (Main_File.File); Main_Source : constant Source_Id := Main_File.Source; Main_Id : File_Name_Type; Exec_Name : File_Name_Type; Exec_Path_Name : Path_Name_Type; Main_Proj : Project_Id; Main_Base_Name_Index : File_Name_Type; Index_Separator : Character; Response_File_Name : Path_Name_Type := No_Path; Response_2 : Path_Name_Type := No_Path; Rpaths : String_Vectors.Vector; Binding_Options : String_Vectors.Vector; -- Table to store the linking options coming from the binder Arguments : Options_Data; Objects : String_Vectors.Vector; Other_Arguments : Options_Data; Linking_With_Static_SALs : Boolean := False; -------------------------- -- Add_Run_Path_Options -- -------------------------- procedure Add_Run_Path_Options is Nam_Nod : Name_Node; Length : Natural := 0; Arg : String_Access := null; begin for Path of Path_Options loop Add_Rpath (Rpaths, Path); Add_Rpath (Rpaths, Shared_Libgcc_Dir (Path)); end loop; if Rpaths.Is_Empty then return; end if; if Main_Proj.Config.Run_Path_Origin /= No_Name and then Get_Name_String (Main_Proj.Config.Run_Path_Origin) /= "" then Rpaths_Relative_To (Rpaths, Main_Proj.Exec_Directory.Display_Name, Main_Proj.Config.Run_Path_Origin); end if; if Main_Proj.Config.Separate_Run_Path_Options then for Path of Rpaths loop Nam_Nod := Main_File.Tree.Shared.Name_Lists.Table (Main_Proj.Config.Run_Path_Option); while Nam_Nod.Next /= No_Name_List loop Add_To_Other_Arguments (Get_Name_String (Nam_Nod.Name)); Nam_Nod := Main_File.Tree.Shared.Name_Lists.Table (Nam_Nod.Next); end loop; Get_Name_String (Nam_Nod.Name); Add_Str_To_Name_Buffer (Path); Add_To_Other_Arguments (Name_Buffer (1 .. Name_Len)); end loop; else Nam_Nod := Main_File.Tree.Shared.Name_Lists.Table (Main_Proj.Config.Run_Path_Option); while Nam_Nod.Next /= No_Name_List loop Add_To_Other_Arguments (Get_Name_String (Nam_Nod.Name)); Nam_Nod := Main_File.Tree.Shared.Name_Lists.Table (Nam_Nod.Next); end loop; -- Compute the length of the argument Get_Name_String (Nam_Nod.Name); Length := Name_Len; for Path of Rpaths loop Length := Length + Path'Length + 1; end loop; -- Create the argument Arg := new String (1 .. Length); Length := Name_Len; Arg (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); for Path of Rpaths loop Arg (Length + 1 .. Length + Path'Length) := Path; Length := Length + Path'Length + 1; Arg (Length) := ':'; end loop; Add_To_Other_Arguments (Arg (1 .. Arg'Last - 1)); end if; end Add_Run_Path_Options; ---------------------------- -- Add_To_Other_Arguments -- ---------------------------- procedure Add_To_Other_Arguments (A : String) is begin Add_Argument (Other_Arguments, A, Opt.Verbose_Mode); end Add_To_Other_Arguments; ------------------------- -- Global_Archive_Name -- ------------------------- function Global_Archive_Name (For_Project : Project_Id) return String is begin return "lib" & Get_Name_String (For_Project.Name) & Archive_Suffix (For_Project); end Global_Archive_Name; --------------------------------------- -- Load_Bindfile_Option_Substitution -- --------------------------------------- procedure Load_Bindfile_Option_Substitution is The_Array : Array_Element_Id; Element : Array_Element; Shared : Shared_Project_Tree_Data_Access renames Project_Tree.Shared; Binder : constant Package_Id := Value_Of (Name_Binder, Main_File.Project.Decl.Packages, Shared); begin The_Array := Value_Of (Name => Name_Bindfile_Option_Substitution, In_Arrays => Shared.Packages.Table (Binder).Decl.Arrays, Shared => Shared); while The_Array /= No_Array_Element loop Element := Shared.Array_Elements.Table (The_Array); Bindfile_Option_Substitution.Include (Get_Name_String (Element.Index), Element.Value.Values); The_Array := Element.Next; end loop; end Load_Bindfile_Option_Substitution; ---------------------------------------- -- Apply_Bindfile_Option_Substitution -- ---------------------------------------- function Apply_Bindfile_Option_Substitution (Option : String) return Boolean is CV : constant String_Values.Cursor := Bindfile_Option_Substitution.Find (Option); Values : String_List_Id; Pointer : access String_Element; begin if not String_Values.Has_Element (CV) then return False; end if; Values := String_Values.Element (CV); while Values /= Nil_String loop Pointer := Project_Tree.Shared.String_Elements.Table (Values)'Unrestricted_Access; Binding_Options.Append (Get_Name_String (Pointer.Value)); Values := Pointer.Next; end loop; return True; end Apply_Bindfile_Option_Substitution; ----------------------------- -- Remove_Duplicated_Specs -- ----------------------------- procedure Remove_Duplicated_Specs (Arguments : in out Options_Data) is Position : String_Sets.Cursor; Inserted : Boolean; begin for Index in reverse 1 .. Arguments.Last_Index loop declare Arg : constant String := Arguments (Index).Name; begin if Arg'Length >= 8 and then Arg (1 .. 8) = "--specs=" then Were_Options.Insert (Arg, Position, Inserted); if not Inserted then Arguments.Delete (Index); end if; end if; end; end loop; end Remove_Duplicated_Specs; ------------------------- -- Remove_Duplicated_T -- ------------------------- procedure Remove_Duplicated_T (Arguments : in out Options_Data) is Position : String_Sets.Cursor; Inserted : Boolean; Arg_Index : Positive := Arguments.First_Index; begin while Arg_Index <= Arguments.Last_Index loop declare Arg1 : constant String := Arguments (Arg_Index).Name; begin if Arg1'Length >= 2 and then Arg1 (1 .. 2) = "-T" then -- Case of -T and as separate arguments -- (from .cgpr file) if Arg1'Length = 2 then if Arg_Index < Arguments.Last_Index then declare Arg2 : constant String := Arguments (Arg_Index + 1).Name; begin Were_Options.Insert (Arg1 & Arg2, Position, Inserted); if Inserted then Arg_Index := Arg_Index + 2; else Arguments.Delete (Arg_Index, 2); end if; end; else -- We get here if the link command somehow ends -- with "-T" which would indicate a bug. -- Just ignore it now and let the linker fail. Arg_Index := Arg_Index + 1; end if; -- Case of "-T" (from SAL linker options) else Were_Options.Insert (Arg1, Position, Inserted); if Inserted then Arg_Index := Arg_Index + 1; else Arguments.Delete (Arg_Index); end if; end if; else Arg_Index := Arg_Index + 1; end if; end; end loop; end Remove_Duplicated_T; -------------------------------------------- -- Fill_Options_Data_From_Arg_List_Access -- -------------------------------------------- procedure Fill_Options_Data_From_Arg_List_Access (ALA : Argument_List_Access; OD : out Options_Data) is begin OD.Clear; for A of ALA.all loop Add_Argument (OD, A.all, Opt.Verbose_Mode); end loop; end Fill_Options_Data_From_Arg_List_Access; ---------------------------- -- Linker_Helper_Switches -- ---------------------------- function Rust_Linker_Helper_Switches (Lib_Name : Path_Name_Type) return String_Access is Rust_Linker_Helper_Name : String_Access := null; Arg_List : Argument_List_Access; Arg_Disp : Options_Data; Status : aliased Integer; Output : String_Access; begin Rust_Linker_Helper_Name := new String'("gprbuild-rust-linker-helper"); -- Locate the gprbuild-rust_linker-helper on the PATH if Rust_Linker_Helper_Path = null then Rust_Linker_Helper_Path := Locate_Exec_On_Path (Rust_Linker_Helper_Name.all); if Rust_Linker_Helper_Path = null then Fail_Program (Project_Tree, "unable to locate """ & Rust_Linker_Helper_Name.all & '"'); end if; end if; Arg_List := new GNAT.Strings.String_List' (1 => new String'("--target"), 2 => new String'( Get_Name_String (Main_File.Project.Config.Target) ), 3 => new String'(Get_Name_String (Lib_Name)) ); Fill_Options_Data_From_Arg_List_Access (Arg_List, Arg_Disp); Display_Command (Arg_Disp, Rust_Linker_Helper_Path); Output := new String' (GNAT.Expect.Get_Command_Output (Command => Rust_Linker_Helper_Path.all, Arguments => Arg_List.all, Input => "", Status => Status'Access, Err_To_Out => True)); if Status /= 0 then Fail_Program (Project_Tree, "failed to execute """ & Rust_Linker_Helper_Name.all & """: " & Output.all); end if; Free (Rust_Linker_Helper_Name); return Output; end Rust_Linker_Helper_Switches; begin -- Make sure that the table Rpaths is emptied after each main, so -- that the same rpaths are not duplicated. Path_Options.Clear; Linker_Needs_To_Be_Called := Opt.Force_Compilations; Main_Id := Create_Name (Base_Name (Main)); Main_Proj := Ultimate_Extending_Project_Of (Main_Source.Project); Change_To_Object_Directory (Main_Proj); -- Build the global archive for this project, if needed -- Archive needs to be rebuilt if not Empty_Archive_Builder then Check_Archive_Builder; end if; if not Empty_Archive_Builder then Build_Global_Archive (Main_Proj, Main_File.Tree, Global_Archive_Has_Been_Built, Global_Archive_Exists, Main_File.Command, OK); if not OK then Stop_Spawning := True; Bad_Processes.Append (Main_File); return; end if; else return; end if; Main_File.Command.Clear; -- Get the main base name Index_Separator := Main_Source.Language.Config.Multi_Unit_Object_Separator; Main_Base_Name_Index := Base_Name_Index_For (Main, Main_File.Index, Index_Separator); if not Linker_Needs_To_Be_Called and then Opt.Verbosity_Level > Opt.Low then Put (" Checking executable for "); Put (Get_Name_String (Main_Source.File)); Put_Line (" ..."); end if; if Output_File_Name /= null then Set_Name_Buffer (Output_File_Name.all); -- If an executable name was specified without an extension and -- there is a non empty executable suffix, add the suffix to the -- executable name. if Main_Proj.Config.Executable_Suffix not in No_Name | Empty_String then declare Suffix : String := Get_Name_String (Main_Proj.Config.Executable_Suffix); File_Name : String := Output_File_Name.all; begin if Index (File_Name, ".") = 0 then Canonical_Case_File_Name (Suffix); Canonical_Case_File_Name (File_Name); if Name_Len <= Suffix'Length or else File_Name (File_Name'Last - Suffix'Length + 1 .. File_Name'Last) /= Suffix then Add_Str_To_Name_Buffer (Suffix); end if; end if; end; end if; Exec_Name := Name_Find; else Exec_Name := Executable_Of (Project => Main_Proj, Shared => Main_File.Tree.Shared, Main => Main_Id, Index => Main_Source.Index, Language => Get_Name_String (Main_Source.Language.Name)); end if; if Main_Proj.Exec_Directory = Main_Proj.Object_Directory or else Is_Absolute_Path (Get_Name_String (Exec_Name)) then Exec_Path_Name := Path_Name_Type (Exec_Name); else Get_Name_String (Main_Proj.Exec_Directory.Display_Name); Add_Char_To_Name_Buffer (Directory_Separator); Get_Name_String_And_Append (Exec_Name); Exec_Path_Name := Name_Find; end if; Executable_TS := File_Stamp (Exec_Path_Name); if not Linker_Needs_To_Be_Called and then Executable_TS = Osint.Invalid_Time then Linker_Needs_To_Be_Called := True; if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> executable does not exist"); end if; end if; if not Linker_Needs_To_Be_Called and then Is_File_Empty (Name => Exec_Path_Name) then Linker_Needs_To_Be_Called := True; if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> empty executable"); end if; end if; -- Get the path of the linker driver if Main_Proj.Config.Linker /= No_Path then Linker_Name := new String'(Get_Name_String (Main_Proj.Config.Linker)); Linker_Path := Locate_Exec_On_Path (Linker_Name.all); if Linker_Path = null then Fail_Program (Main_File.Tree, "unable to find linker " & Linker_Name.all); end if; else Fail_Program (Main_File.Tree, "no linker specified and no default linker in the configuration", Exit_Code => E_General); end if; Initialize_Source_Record (Main_Source); Main_Object_TS := File_Stamp (Main_Source.Object_Path); if not Linker_Needs_To_Be_Called then if Main_Object_TS = Osint.Invalid_Time then if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> main object does not exist"); end if; Linker_Needs_To_Be_Called := True; elsif Main_Object_TS > Executable_TS then if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> main object more recent than executable"); end if; Linker_Needs_To_Be_Called := True; end if; end if; if Main_Object_TS = Osint.Invalid_Time then Put ("main object for "); Put (Get_Name_String (Main_Source.File)); Put_Line (" does not exist"); Record_Failure (Main_File); return; end if; -- Add the Leading_Switches if there are any in package Linker declare The_Packages : constant Package_Id := Main_Proj.Decl.Packages; Linker_Package : constant GPR.Package_Id := GPR.Util.Value_Of (Name => Name_Linker, In_Packages => The_Packages, Shared => Main_File.Tree.Shared); Switches : Variable_Value; Switch_List : String_List_Id; Element : String_Element; begin if Linker_Package /= No_Package then declare Switches_Array : constant Array_Element_Id := GPR.Util.Value_Of (Name => Name_Leading_Switches, In_Arrays => Main_File.Tree.Shared.Packages.Table (Linker_Package).Decl.Arrays, Shared => Main_File.Tree.Shared); begin Switches := GPR.Util.Value_Of (Index => Name_Id (Main_Id), Src_Index => 0, In_Array => Switches_Array, Shared => Main_File.Tree.Shared); if Switches = Nil_Variable_Value then Switches := GPR.Util.Value_Of (Index => Main_Source.Language.Name, Src_Index => 0, In_Array => Switches_Array, Shared => Main_File.Tree.Shared, Force_Lower_Case_Index => True); end if; if Switches = Nil_Variable_Value then Switches := GPR.Util.Value_Of (Index => All_Other_Names, Src_Index => 0, In_Array => Switches_Array, Shared => Main_File.Tree.Shared, Force_Lower_Case_Index => True); end if; case Switches.Kind is when Undefined | Single => null; when GPR.List => Switch_List := Switches.Values; while Switch_List /= Nil_String loop Element := Main_File.Tree.Shared.String_Elements.Table (Switch_List); Get_Name_String (Element.Value); if Name_Len > 0 then Add_Argument (Arguments, Name_Buffer (1 .. Name_Len), True); end if; Switch_List := Element.Next; end loop; end case; end; end if; end; Add_Argument (Arguments, Get_Name_String (if Main_Proj = Main_Source.Object_Project then Name_Id (Main_Source.Object) else Name_Id (Main_Source.Object_Path)), True); Find_Binding_Languages (Main_File.Tree, Main_File.Project); -- Build the objects list if Builder_Data (Main_File.Tree).There_Are_Binder_Drivers then Binding_Options.Clear; B_Data := Builder_Data (Main_File.Tree).Binding; Binding_Loop : while B_Data /= null loop declare Exchange_File_Name : constant String := Binder_Exchange_File_Name (Main_Base_Name_Index, B_Data.Binder_Prefix).all; Binding_Not_Necessary : Boolean; begin if Is_Regular_File (Exchange_File_Name) then Binder_Exchange_TS := File_Stamp (Path_Name_Type'(Create_Name (Exchange_File_Name))); Open (Exchange_File, In_File, Exchange_File_Name); Get_Line (Exchange_File, Line, Last); Binding_Not_Necessary := Line (1 .. Last) = Binding_Label (Nothing_To_Bind); Close (Exchange_File); if Binding_Not_Necessary then goto No_Binding; end if; if not Linker_Needs_To_Be_Called and then Binder_Exchange_TS > Executable_TS then Linker_Needs_To_Be_Called := True; if Opt.Verbosity_Level > Opt.Low then Put (" -> binder exchange file """); Put (Exchange_File_Name); Put_Line (""" is more recent than executable"); end if; end if; Load_Bindfile_Option_Substitution; Open (Exchange_File, In_File, Exchange_File_Name); while not End_Of_File (Exchange_File) loop Get_Line (Exchange_File, Line, Last); if Last > 0 then if Line (1) = '[' then Section := Get_Binding_Section (Line (1 .. Last)); else case Section is when Generated_Object_File => Binder_Object_TS := File_Stamp (Path_Name_Type' (Create_Name (Line (1 .. Last)))); Objects.Append (Line (1 .. Last)); when Bound_Object_Files => if Normalize_Pathname (Line (1 .. Last), Resolve_Links => Opt.Follow_Links_For_Files, Case_Sensitive => False) /= Normalize_Pathname (Get_Name_String (Main_Source.Object_Path), Resolve_Links => Opt.Follow_Links_For_Files, Case_Sensitive => False) and then not Is_In_Library_Project (Line (1 .. Last)) then Objects.Append (Line (1 .. Last)); end if; when Resulting_Options => if not Apply_Bindfile_Option_Substitution (Line (1 .. Last)) then Binding_Options.Append (Line (1 .. Last)); end if; when Gprexch.Run_Path_Option => if Opt.Run_Path_Option and then Main_Proj.Config.Run_Path_Option /= No_Name_List then Path_Options.Append (Line (1 .. Last)); end if; when others => null; end case; end if; end if; end loop; Close (Exchange_File); if Binder_Object_TS = Osint.Invalid_Time then if not Linker_Needs_To_Be_Called and then Opt.Verbosity_Level > Opt.Low then Put_Line (" -> no binder generated object file"); end if; Put ("no binder generated object file for "); Put_Line (Get_Name_String (Main_File.File)); Record_Failure (Main_File); return; elsif not Linker_Needs_To_Be_Called and then Binder_Object_TS > Executable_TS then Linker_Needs_To_Be_Called := True; if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> binder generated object is more " & "recent than executable"); end if; end if; else Put ("binder exchange file "); Put (Exchange_File_Name); Put_Line (" does not exist"); Record_Failure (Main_File); return; end if; end; <> B_Data := B_Data.Next; end loop Binding_Loop; end if; -- Add object files for unconditionally linked languages declare Lang : Language_Ptr := Main_Proj.Languages; Src : Source_Id; begin while Lang /= No_Language_Index loop if Lang.Unconditional_Linking then Src := Lang.First_Source; while Src /= No_Source loop Objects.Append (Get_Name_String (Src.Object_Path)); Src := Src.Next_In_Lang; end loop; end if; Lang := Lang.Next; end loop; end; -- Add the global archive, if there is one if Global_Archive_Exists then Global_Archive_TS := File_Stamp (Path_Name_Type' (Create_Name (Global_Archive_Name (Main_Proj)))); if Global_Archive_TS = Osint.Invalid_Time then if not Linker_Needs_To_Be_Called and then Opt.Verbosity_Level > Opt.Low then Put_Line (" -> global archive does not exist"); end if; Put ("global archive for project file "); Put (Get_Name_String (Main_Proj.Name)); Put_Line (" does not exist"); end if; end if; if not Linker_Needs_To_Be_Called and then Global_Archive_Has_Been_Built then Linker_Needs_To_Be_Called := True; if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> global archive has just been built"); end if; end if; if not Linker_Needs_To_Be_Called and then Global_Archive_Exists and then Global_Archive_TS > Executable_TS then Linker_Needs_To_Be_Called := True; if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> global archive is more recent than executable"); end if; end if; -- Check if there are library files that are more recent than -- executable. declare List : Project_List := Main_Proj.All_Imported_Projects; Proj : Project_Id; begin while List /= null loop Proj := List.Project; List := List.Next; if Proj.Extended_By = No_Project and then Proj.Library and then Proj.Object_Directory /= No_Path_Information and then (Is_Static (Proj) or else Proj.Standalone_Library = No) then -- If the library project has Rust as a language we want to -- do a specific processing in order to correctly check if -- the executable needs to be re-linked. if Has_Language_From_Name (Proj, "Rust") then declare S : constant String_Access := Rust_Linker_Helper_Switches (Proj.Library_Dir.Name); Lib_Path : String_Access; Lib_Name : String_Access; begin -- Add the returned switches to the map of known rust -- project switches. Rust_Linker_Helper_Switch_Map.Insert (Proj.Name, S); -- Do some post-processing on the switches to extract -- the correct library directory and library name. for Switch of Split (S.all, " ") loop if Starts_With (Get_Name_String (Switch), "-L") then declare Tmp : constant String := Get_Name_String (Switch); begin Lib_Path := new String' (Tmp (Tmp'First + 2 .. Tmp'Last)); end; elsif Starts_With (Get_Name_String (Switch), "-l") then declare Tmp : constant String := Get_Name_String (Switch); begin Lib_Name := new String' (Tmp (Tmp'First + 2 .. Tmp'Last)); end; end if; end loop; Name_Len := 0; -- Build the correct path to the rust static library Add_Str_To_Name_Buffer (Lib_Path.all); Add_Char_To_Name_Buffer (Directory_Separator); Add_Str_To_Name_Buffer ("lib"); Add_Str_To_Name_Buffer (Lib_Name.all); if Proj.Config.Archive_Suffix = No_File then Add_Str_To_Name_Buffer (".a"); else Get_Name_String_And_Append (Proj.Config.Archive_Suffix); end if; Free (Lib_Name); Free (Lib_Path); end; else -- Put the full path name of the library file in Name_Buffer Get_Name_String (Proj.Library_Dir.Display_Name); if Is_Static (Proj) then Add_Str_To_Name_Buffer ("lib"); Get_Name_String_And_Append (Proj.Library_Name); if Proj.Config.Archive_Suffix = No_File then Add_Str_To_Name_Buffer (".a"); else Get_Name_String_And_Append (Proj.Config.Archive_Suffix); end if; else -- Shared libraries if Proj.Config.Shared_Lib_Prefix = No_File then Add_Str_To_Name_Buffer ("lib"); else Get_Name_String_And_Append (Proj.Config.Shared_Lib_Prefix); end if; Get_Name_String_And_Append (Proj.Library_Name); if Proj.Config.Shared_Lib_Suffix = No_File then Add_Str_To_Name_Buffer (".so"); else Get_Name_String_And_Append (Proj.Config.Shared_Lib_Suffix); end if; end if; end if; -- Check that library file exists and that it is not more -- recent than the executable. declare Lib_TS : constant Time := File_Time_Stamp (Name_Buffer (1 .. Name_Len)); begin if Lib_TS = Osint.Invalid_Time then Linker_Needs_To_Be_Called := True; if Opt.Verbosity_Level > Opt.Low then Put (" -> library file """); Put (Name_Buffer (1 .. Name_Len)); Put_Line (""" not found"); end if; exit; elsif Lib_TS > Executable_TS then Linker_Needs_To_Be_Called := True; if Opt.Verbosity_Level > Opt.Low then Put (" -> library file """); Put (Name_Buffer (1 .. Name_Len)); Put_Line (""" is more recent than executable"); end if; exit; end if; end; end if; end loop; end; if not Linker_Needs_To_Be_Called then if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> up to date"); elsif not Opt.Quiet_Output then Inform (Exec_Name, "up to date"); end if; else if Global_Archive_Exists then Add_To_Other_Arguments (Global_Archive_Name (Main_Proj)); end if; -- Add the library switches, if there are libraries Process_Imported_Libraries (Main_Proj, There_Are_SALs => Disregard); Library_Dirs.Reset; for J in reverse 1 .. Library_Projs.Last_Index loop if not Library_Projs (J).Is_Aggregated then if Is_Static (Library_Projs (J).Proj) then declare Proj : constant Project_Id := Library_Projs (J).Proj; Lib_Name : constant String := Get_Name_String (Proj.Library_Name); Lib_Path : constant String := Get_Name_String (Proj.Library_Dir.Display_Name) & "lib" & Lib_Name & Archive_Suffix (Proj); Arg_List : Argument_List_Access; Arg_Disp : Options_Data; begin -- If the library project has Rust as a language we want -- to do a specific processing in order to correctly link -- those libraries. if Has_Language_From_Name (Proj, "Rust") then declare S : constant String_Access := (if Rust_Linker_Helper_Switch_Map.Contains (Proj.Name) then Rust_Linker_Helper_Switch_Map.Element (Proj.Name) else Rust_Linker_Helper_Switches (Proj.Library_Dir.Name) ); -- This project either already retrieved its -- switches from the gprbuild-rust-linker-helper -- tool, or we launch the tool to retrieve the -- switches now. begin if S /= null then -- Add each switch individually to the argument -- list. for Switch of Split (S.all, " ") loop Add_To_Other_Arguments (Get_Name_String (Switch)); end loop; end if; end; else Add_To_Other_Arguments (Lib_Path); end if; -- Extract linker switches in the case of a static SAL if Proj.Standalone_Library /= No then Linking_With_Static_SALs := True; if Archive_Builder_Path = null then Check_Archive_Builder; end if; declare Status : aliased Integer; Output : String_Access; EOL : constant String := "" & ASCII.LF; Obj : String_Access; Obj_Path_Name : Path_Name_Type; Objdump_Exec : String_Access; AB_Path : constant String := Archive_Builder_Path.all; AB_Path_Last : Natural := 0; File : Text_File; Lib_Dir_Name : Path_Name_Type; FD : File_Descriptor; Tmp_File : Path_Name_Type; Success : Boolean := True; procedure Set_Tmp_File_Line; -- Set Tmp_File first line to Error procedure Decode_Line; -- Decode line from File to Name_Buffer ----------------------- -- Set_Tmp_File_Line -- ----------------------- procedure Set_Tmp_File_Line is File : File_Type; begin Open (File, In_File, Get_Name_String (Tmp_File)); declare Line : constant String := Get_Line (File); begin Error_Msg_Strlen := Line'Length; Error_Msg_String (1 .. Line'Length) := Line; end; Close (File); end Set_Tmp_File_Line; Line : String (1 .. 128); First : Positive := 42; Last : Natural := 1; ----------------- -- Decode_Line -- ----------------- procedure Decode_Line is function Is_Hex (Str : String) return Boolean is (for all Char of Str => Char in '0' .. '9' | 'a' .. 'f'); begin Name_Len := 0; Decoding : loop if First > 41 then loop exit Decoding when End_Of_File (File); Get_Line (File, Line, Last); exit when Last > 43 and then Is_Hex (Line (2 .. 4)) and then Is_Hex (Line (7 .. 8)) and then (for all J in 9 .. 41 => Line (J) in ' ' | '0' .. '9' | 'a' .. 'f') and then Line (1) = ' ' and then Line (5 .. 6) = "0 " and then Line (15) = ' ' and then Line (24) = ' ' and then Line (33) = ' ' and then Line (42 .. 43) = " "; end loop; First := 7; end if; while First < 42 loop Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := Character'Val (Integer'Value ("16#" & Line (First .. First + 1) & '#')); First := First + 2; if Line (First) = ' ' then First := First + 1; if Line (First) = ' ' and then First < 42 then pragma Assert (End_Of_File (File), "not at end of file " & Line (1 .. Last) & First'Img); First := 42; end if; end if; if Name_Buffer (Name_Len) = ASCII.LF then Name_Len := Name_Len - 1; if not (Name_Len = 0) then if Name_Buffer (Name_Len) = ASCII.CR then Name_Len := Name_Len - 1; end if; end if; exit Decoding; end if; end loop; end loop Decoding; end Decode_Line; begin -- Create the temporary file to receive (and -- discard) the output from spawned processes. Tempdir.Create_Temp_File (FD, Tmp_File); if FD = Invalid_FD then Fail_Program (Main_File.Tree, "could not create temporary file"); else Record_Temp_File (Main_File.Tree.Shared, Tmp_File); end if; -- Use the archive builder path to compute the -- path to objdump. if AB_Path'Length > 2 and then AB_Path (AB_Path'Last - 1 .. AB_Path'Last) = "ar" then AB_Path_Last := AB_Path'Last - 2; elsif AB_Path'Length > 6 and then AB_Path (AB_Path'Last - 5 .. AB_Path'Last) = "ar.exe" then AB_Path_Last := AB_Path'Last - 6; end if; Objdump_Exec := Locate_Exec_On_Path (AB_Path (1 .. AB_Path_Last) & "objdump"); -- If objdump is not found this way, try with -- the one from the system. if Objdump_Exec = null then Objdump_Exec := Locate_Exec_On_Path ("objdump"); end if; -- If still not found, warn and jump away if Objdump_Exec = null then Error_Msg ("?unable to locate objdump", GPR.No_Location); goto Linker_Options_Incomplete; end if; -- List the archive content Arg_List := new GNAT.Strings.String_List' (1 => new String'("-t"), 2 => new String'(Lib_Path)); Fill_Options_Data_From_Arg_List_Access (Arg_List, Arg_Disp); Display_Command (Arg_Disp, Archive_Builder_Path); Output := new String' (GNAT.Expect.Get_Command_Output (Command => Archive_Builder_Path.all, Arguments => Arg_List.all, Input => "", Status => Status'Access, Err_To_Out => True)); Free (Arg_List); if Status /= 0 then -- Warning if the archive builder failed Error_Msg_Strlen := Output'Length; Error_Msg_String (1 .. Output'Length) := Output.all; Error_Msg ("?list of archive content failed: ~", Proj.Location); Free (Output); goto Linker_Options_Incomplete; end if; -- Search through the object files list for the -- expected binder-generated ones. declare Lines : constant Name_Array_Type := Split (Output.all, EOL); Lib_Fn : constant String := Canonical_Case_File_Name (Lib_Name); PP : constant String := Partial_Prefix & Lib_Fn & "_"; begin Free (Output); for L of Lines loop Get_Name_String (L); if On_Windows and then Name_Buffer (Name_Len) = ASCII.CR then -- Skip the final CR Name_Len := Name_Len - 1; end if; Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len)); if Name_Buffer (1 .. Name_Len) = "b__" & Lib_Fn & Object_Suffix or else (Starts_With (Name_Buffer (1 .. Name_Len), PP) and then Is_Object (Name_Buffer (1 .. Name_Len)) and then (for all C of Name_Buffer (PP'Length + 1 .. Name_Len - Object_Suffix'Length) => C in '0' .. '9')) then Obj := new String' (Name_Buffer (1 .. Name_Len)); Obj_Path_Name := Name_Find; end if; end loop; end; if Obj = null then -- Warning if no such object file is found Error_Msg ("?linker options section not found in lib" & Lib_Name & ".a, using defaults.", Proj.Location); goto Linker_Options_Incomplete; end if; -- Extract the object file Arg_List := new GNAT.Strings.String_List' (1 => new String'("-x"), 2 => new String'(Lib_Path), 3 => new String'(Obj.all)); Fill_Options_Data_From_Arg_List_Access (Arg_List, Arg_Disp); Display_Command (Arg_Disp, Archive_Builder_Path); Spawn (Archive_Builder_Path.all, Arg_List.all, FD, Status); Free (Arg_List); if Status /= 0 then -- Warning if the archive builder failed Set_Tmp_File_Line; Error_Msg ("?extract of object file failed: ~", Proj.Location); goto Linker_Options_Incomplete; end if; -- Record the extracted object file as temporary Record_Temp_File (Shared => Main_File.Tree.Shared, Path => Obj_Path_Name); -- Extract the linker options section Arg_List := new GNAT.Strings.String_List' (new String'("-s"), new String'("--section=.GPR.linker_options"), Obj); -- Obj going to be Free together with Arg_List Fill_Options_Data_From_Arg_List_Access (Arg_List, Arg_Disp); Display_Command (Arg_Disp, Objdump_Exec); Spawn (Objdump_Exec.all, Arg_List.all, FD, Status); Free (Arg_List); Obj := null; if Status /= 0 then -- Warning if objcopy failed Set_Tmp_File_Line; Error_Msg ("?extract of linker options failed: ~", Proj.Location); goto Linker_Options_Incomplete; end if; -- Read the objdump output file Open (File, Get_Name_String (Tmp_File)); -- Read the linker options while not End_Of_File (File) or else First < 42 loop Decode_Line; if Name_Len > 0 and then Name_Buffer (1) = ASCII.NUL then -- We are reading a NUL character padding at -- the end of the section: stop here. exit; end if; -- Add the linker option. -- Avoid duplicates for -L. Lib_Dir_Name := Name_Find; if Name_Len > 2 and then Name_Buffer (1 .. 2) = "-L" then if not Library_Dirs.Get (Lib_Dir_Name) then Binding_Options.Append (Name_Buffer (1 .. Name_Len)); Library_Dirs.Set (Lib_Dir_Name, True); end if; elsif Name_Len > 0 then Binding_Options.Append (Name_Buffer (1 .. Name_Len)); end if; end loop; Close (File); Success := True; <> -- We get here if anything went wrong if not Success and then Opt.Verbose_Mode then Put_Line ("Linker options may be incomplete."); end if; if FD /= Invalid_FD then Close (FD); end if; end; end if; end; else -- Do not issue several time the same -L switch if -- several library projects share the same library -- directory. if not Library_Dirs.Get (Library_Projs (J).Proj.Library_Dir.Name) then Library_Dirs.Set (Library_Projs (J).Proj.Library_Dir.Name, True); if Main_Proj.Config.Linker_Lib_Dir_Option = No_Name then Add_To_Other_Arguments ("-L" & Get_Name_String (Library_Projs (J).Proj.Library_Dir.Display_Name)); else Add_To_Other_Arguments (Get_Name_String (Main_Proj.Config.Linker_Lib_Dir_Option) & Get_Name_String (Library_Projs (J).Proj.Library_Dir.Display_Name)); end if; if Opt.Run_Path_Option and then Main_Proj.Config.Run_Path_Option /= No_Name_List then Add_Rpath (Rpaths, Get_Name_String (Library_Projs (J).Proj.Library_Dir.Display_Name)); end if; end if; if Main_Proj.Config.Linker_Lib_Name_Option = No_Name then Add_To_Other_Arguments ("-l" & Get_Name_String (Library_Projs (J).Proj.Library_Name)); else Add_To_Other_Arguments (Get_Name_String (Main_Proj.Config.Linker_Lib_Name_Option) & Get_Name_String (Library_Projs (J).Proj.Library_Name)); end if; end if; end if; end loop; -- Put the options in the project file, if any declare The_Packages : constant Package_Id := Main_Proj.Decl.Packages; Linker_Package : constant GPR.Package_Id := GPR.Util.Value_Of (Name => Name_Linker, In_Packages => The_Packages, Shared => Main_File.Tree.Shared); Switches : Variable_Value; Switch_List : String_List_Id; Element : String_Element; begin if Linker_Package /= No_Package then declare Defaults : constant Array_Element_Id := GPR.Util.Value_Of (Name => Name_Default_Switches, In_Arrays => Main_File.Tree.Shared.Packages.Table (Linker_Package).Decl.Arrays, Shared => Main_File.Tree.Shared); Switches_Array : constant Array_Element_Id := GPR.Util.Value_Of (Name => Name_Switches, In_Arrays => Main_File.Tree.Shared.Packages.Table (Linker_Package).Decl.Arrays, Shared => Main_File.Tree.Shared); Option : String_Access; begin Switches := GPR.Util.Value_Of (Index => Name_Id (Main_Id), Src_Index => 0, In_Array => Switches_Array, Shared => Main_File.Tree.Shared, Allow_Wildcards => True); if Switches = Nil_Variable_Value then Switches := GPR.Util.Value_Of (Index => Main_Source.Language.Name, Src_Index => 0, In_Array => Switches_Array, Shared => Main_File.Tree.Shared, Force_Lower_Case_Index => True); end if; if Switches = Nil_Variable_Value then Switches := GPR.Util.Value_Of (Index => All_Other_Names, Src_Index => 0, In_Array => Switches_Array, Shared => Main_File.Tree.Shared, Force_Lower_Case_Index => True); end if; if Switches = Nil_Variable_Value then Switches := GPR.Util.Value_Of (Index => Main_Source.Language.Name, Src_Index => 0, In_Array => Defaults, Shared => Main_File.Tree.Shared); end if; case Switches.Kind is when Undefined | Single => null; when GPR.List => Switch_List := Switches.Values; while Switch_List /= Nil_String loop Element := Main_File.Tree.Shared.String_Elements.Table (Switch_List); Get_Name_String (Element.Value); if Name_Len > 0 then Option := new String'(Name_Buffer (1 .. Name_Len)); Test_If_Relative_Path (Option, Get_Name_String (Main_Proj.Directory.Name), Dash_L); Add_Argument (Other_Arguments, Option.all, True); Free (Option); end if; Switch_List := Element.Next; end loop; end case; end; end if; end; -- Get the Linker_Options, if any Add_Linker_Options (Other_Arguments, For_Project => Main_Proj); -- Add the linker switches specified on the command line Add_Arguments (Other_Arguments, Command_Line_Linker_Options, Opt.Verbose_Mode); -- Then the binding options -- If we are linking with static SALs, process the linker options -- coming from those SALs the same way as in gprbind (refactoring -- needed!!) and add them to the command line. -- The parts of the original code related to object files have been -- removed since options from static SALs only include flags. if Linking_With_Static_SALs then declare All_Binding_Options : Boolean := False; Get_Option : Boolean; Xlinker_Seen : Boolean := False; Stack_Equal_Seen : Boolean := False; Static_Libs : Boolean := True; Adalib_Dir : String_Access; Prefix_Path : String_Access; Lib_Path : String_Access; begin for Option of Binding_Options loop declare Line : String renames Option; Last : constant Natural := Line'Last; procedure Add_Lib_Path_Or_Line (Lib_Name : String); -- Add full library pathname to the Other_Arguments if -- found in Prefix_Path, add Line to Other_Arguments -- otherwise. -------------------------- -- Add_Lib_Path_Or_Line -- -------------------------- procedure Add_Lib_Path_Or_Line (Lib_Name : String) is begin Lib_Path := Locate_Regular_File (Lib_Name, Prefix_Path.all); if Lib_Path /= null then Add_To_Other_Arguments (Lib_Path.all); Free (Lib_Path); else Add_To_Other_Arguments (Line); end if; end Add_Lib_Path_Or_Line; begin if Line (1) = '-' then All_Binding_Options := True; end if; Get_Option := All_Binding_Options; if Get_Option then if Line = "-Xlinker" then Xlinker_Seen := True; elsif Xlinker_Seen then Xlinker_Seen := False; if Last > 8 and then Line (1 .. 8) = "--stack=" then if not Stack_Equal_Seen then Stack_Equal_Seen := True; Add_To_Other_Arguments ("-Xlinker"); Add_To_Other_Arguments (Line); end if; else Add_To_Other_Arguments ("-Xlinker"); Add_To_Other_Arguments (Line); end if; elsif Last > 12 and then Line (1 .. 12) = "-Wl,--stack=" then if not Stack_Equal_Seen then Stack_Equal_Seen := True; Add_To_Other_Arguments (Line); end if; elsif Last >= 3 and then Line (1 .. 2) = "-L" then if Is_Regular_File (Line (3 .. Last) & Directory_Separator & "libgnat.a") then Adalib_Dir := new String'(Line (3 .. Last)); declare Dir_Last : Positive; Prev_Dir_Last : Positive; First : Positive; Prev_Dir_First : Positive; Nmb : Natural; begin Set_Name_Buffer (Line (3 .. Last)); while Is_Directory_Separator (Name_Buffer (Name_Len)) loop Name_Len := Name_Len - 1; end loop; while not Is_Directory_Separator (Name_Buffer (Name_Len)) loop Name_Len := Name_Len - 1; end loop; while Is_Directory_Separator (Name_Buffer (Name_Len)) loop Name_Len := Name_Len - 1; end loop; Dir_Last := Name_Len; Nmb := 0; Dir_Loop : loop Prev_Dir_Last := Dir_Last; First := Dir_Last - 1; while First > 3 and then not Is_Directory_Separator (Name_Buffer (First)) loop First := First - 1; end loop; Prev_Dir_First := First + 1; exit Dir_Loop when First <= 3; Dir_Last := First - 1; while Is_Directory_Separator (Name_Buffer (Dir_Last)) loop Dir_Last := Dir_Last - 1; end loop; Nmb := Nmb + 1; if Nmb <= 1 then Add_Char_To_Name_Buffer (Path_Separator); Add_Str_To_Name_Buffer (Name_Buffer (1 .. Dir_Last)); elsif Name_Buffer (Prev_Dir_First .. Prev_Dir_Last) = "lib" then Add_Char_To_Name_Buffer (Path_Separator); Add_Str_To_Name_Buffer (Name_Buffer (1 .. Prev_Dir_Last)); exit Dir_Loop; end if; end loop Dir_Loop; Prefix_Path := new String'(Name_Buffer (1 .. Name_Len)); end; end if; Add_To_Other_Arguments (Line); elsif Option in Static_Libgcc | Shared_Libgcc then Add_To_Other_Arguments (Option); Static_Libs := Option = Static_Libgcc; elsif Line = Dash_Lgnat then Add_To_Other_Arguments (if Adalib_Dir = null or else not Static_Libs then Dash_Lgnat else Adalib_Dir.all & "libgnat.a"); elsif Line = Dash_Lgnarl and then Static_Libs and then Adalib_Dir /= null then Add_To_Other_Arguments (Adalib_Dir.all & "libgnarl.a"); elsif Line = "-laddr2line" and then Prefix_Path /= null then Add_Lib_Path_Or_Line ("libaddr2line.a"); elsif Line = "-lbfd" and then Prefix_Path /= null then Add_Lib_Path_Or_Line ("libbfd.a"); elsif Line = "-lgnalasup" and then Prefix_Path /= null then Add_Lib_Path_Or_Line ("libgnalasup.a"); elsif Line = "-lgnatmon" and then Prefix_Path /= null then Add_Lib_Path_Or_Line ("libgnatmon.a"); elsif Line = "-liberty" and then Prefix_Path /= null then Add_Lib_Path_Or_Line ("libiberty.a"); else Add_To_Other_Arguments (Line); end if; end if; end; end loop; end; else for Option of Binding_Options loop Add_To_Other_Arguments (Option); end loop; end if; -- Then the required switches, if any. These are put here because, -- if they include -L switches for example, the link may fail because -- the wrong objects or libraries are linked in. Min_Linker_Opts := Main_Proj.Config.Trailing_Linker_Required_Switches; while Min_Linker_Opts /= No_Name_List loop Add_To_Other_Arguments (Get_Name_String (Main_File.Tree.Shared.Name_Lists.Table (Min_Linker_Opts).Name)); Min_Linker_Opts := Main_File.Tree.Shared.Name_Lists.Table (Min_Linker_Opts).Next; end loop; -- Finally the Trailing_Switches if there are any in package Linker. -- They are put here so that it is possible to override the required -- switches from the configuration project file. declare The_Packages : constant Package_Id := Main_Proj.Decl.Packages; Linker_Package : constant GPR.Package_Id := GPR.Util.Value_Of (Name => Name_Linker, In_Packages => The_Packages, Shared => Main_File.Tree.Shared); Switches : Variable_Value; Switch_List : String_List_Id; Element : String_Element; begin if Linker_Package /= No_Package then declare Switches_Array : constant Array_Element_Id := GPR.Util.Value_Of (Name => Name_Trailing_Switches, In_Arrays => Main_File.Tree.Shared.Packages.Table (Linker_Package).Decl.Arrays, Shared => Main_File.Tree.Shared); begin Switches := GPR.Util.Value_Of (Index => Name_Id (Main_Id), Src_Index => 0, In_Array => Switches_Array, Shared => Main_File.Tree.Shared); if Switches = Nil_Variable_Value then Switches := GPR.Util.Value_Of (Index => Main_Source.Language.Name, Src_Index => 0, In_Array => Switches_Array, Shared => Main_File.Tree.Shared, Force_Lower_Case_Index => True); end if; if Switches = Nil_Variable_Value then Switches := GPR.Util.Value_Of (Index => All_Other_Names, Src_Index => 0, In_Array => Switches_Array, Shared => Main_File.Tree.Shared, Force_Lower_Case_Index => True); end if; case Switches.Kind is when Undefined | Single => null; when GPR.List => Switch_List := Switches.Values; while Switch_List /= Nil_String loop Element := Main_File.Tree.Shared.String_Elements.Table (Switch_List); Get_Name_String (Element.Value); Add_Argument (Other_Arguments, Name_Buffer (1 .. Name_Len), True); Switch_List := Element.Next; end loop; end case; end; end if; end; -- Remove duplicate stack size setting coming from pragmas -- Linker_Options or Link_With and linker switches ("-Xlinker -- --stack=R,C" or "-Wl,--stack=R"). Only the first stack size -- setting option should be taken into account, because the one in -- the project file or on the command line will always be the first -- one. And any subsequent stack setting option will overwrite the -- previous one. -- Also, if Opt.Maximum_Processes is greater than one, check for -- switches --lto or -flto and add =nn to the switch. Clean_Link_Option_Set : declare J : Natural := Other_Arguments.First_Index; Stack_Op : Boolean := False; Inc : Boolean; begin while J <= Other_Arguments.Last_Index loop -- Incriment J by default Inc := True; -- Check for two switches "-Xlinker" followed by "--stack=..." if J /= Other_Arguments.Last_Index and then Other_Arguments (J).Name = "-Xlinker" and then Other_Arguments (J + 1).Name'Length > 8 and then Other_Arguments (J + 1).Name (1 .. 8) = "--stack=" then if Stack_Op then Other_Arguments.Delete (J + 1); Other_Arguments.Delete (J); Inc := False; else Stack_Op := True; end if; -- Check for single switch elsif (Other_Arguments (J).Name'Length > 17 and then Other_Arguments (J).Name (1 .. 17) = "-Xlinker --stack=") or else (Other_Arguments (J).Name'Length > 12 and then Other_Arguments (J).Name (1 .. 12) = "-Wl,--stack=") then if Stack_Op then Other_Arguments.Delete (J); Inc := False; else Stack_Op := True; end if; elsif Opt.Maximum_Linkers > 1 then if Other_Arguments (J).Name in "--lto" | "-flto" then declare Img : String := Opt.Maximum_Linkers'Img; Arg : Option_Type renames Other_Arguments.Element (J); begin Img (1) := '='; Other_Arguments.Replace_Element (J, Option_Type' (Name_Len => Arg.Name_Len + Img'Length, Name => Arg.Name & Img, Displayed => Arg.Displayed, Simple_Name => Arg.Simple_Name)); end; end if; end if; if Inc then J := J + 1; end if; end loop; end Clean_Link_Option_Set; -- Look for the last switch -shared-libgcc or -static-libgcc and -- remove all the others. declare Dash_Libgcc : Boolean := False; begin for Arg in reverse Other_Arguments.First_Index .. Other_Arguments.Last_Index loop if Other_Arguments (Arg).Name in Shared_Libgcc | Static_Libgcc then if Dash_Libgcc then Other_Arguments.Delete (Arg); else Dash_Libgcc := True; end if; end if; end loop; end; -- Add the run path option, if necessary if Opt.Run_Path_Option and then Main_Proj.Config.Run_Path_Option /= No_Name_List then Add_Rpath_From_Arguments (Rpaths, Arguments, Main_Proj); Add_Rpath_From_Arguments (Rpaths, Other_Arguments, Main_Proj); Add_Run_Path_Options; end if; -- Add the map file option, if supported and requested if Map_File /= null and then Main_Proj.Config.Map_File_Option /= No_Name then Get_Name_String (Main_Proj.Config.Map_File_Option); if Map_File'Length > 0 then Add_Str_To_Name_Buffer (Map_File.all); else Get_Name_String_And_Append (Main_Base_Name_Index); Add_Str_To_Name_Buffer (".map"); end if; Add_To_Other_Arguments (Name_Buffer (1 .. Name_Len)); end if; -- Add the switch(es) to specify the name of the executable declare List : Name_List_Index := Main_Proj.Config.Linker_Executable_Option; Nam : Name_Node; procedure Add_Executable_Name; -- Add the name of the executable to current name buffer, -- then the content of the name buffer as the next argument. ------------------------- -- Add_Executable_Name -- ------------------------- procedure Add_Executable_Name is begin Get_Name_String_And_Append (Exec_Path_Name); Add_Argument (Other_Arguments, Name_Buffer (1 .. Name_Len), True, Simple_Name => not Opt.Verbose_Mode); end Add_Executable_Name; begin if List /= No_Name_List then loop Nam := Main_File.Tree.Shared.Name_Lists.Table (List); Get_Name_String (Nam.Name); if Nam.Next = No_Name_List then Add_Executable_Name; exit; else Add_Argument (Other_Arguments, Name_Buffer (1 .. Name_Len), True); end if; List := Nam.Next; end loop; else Add_Argument (Other_Arguments, "-o", True); Name_Len := 0; Add_Executable_Name; end if; end; if Linking_With_Static_SALs then -- Filter out duplicate linker options from static SALs: -- -T[ ] (keep left-most) -- --specs=... (keep right-most) Remove_Duplicated_T (Arguments); Remove_Duplicated_T (Other_Arguments); Remove_Duplicated_Specs (Other_Arguments); Remove_Duplicated_Specs (Arguments); end if; -- If response files are supported, check the length of the -- command line and the number of object files, then create -- a response file if needed. if Main_Proj.Config.Max_Command_Line_Length > 0 and then Main_Proj.Config.Resp_File_Format /= GPR.None then declare Arg_Length : Natural := 0; Min_Number_Of_Objects : Natural := 0; begin for Arg of Arguments loop Arg_Length := Arg_Length + Arg.Name'Length + 1; end loop; for Arg of Objects loop Arg_Length := Arg_Length + Arg'Length + 1; end loop; for Arg of Other_Arguments loop Arg_Length := Arg_Length + Arg.Name'Length + 1; end loop; if Arg_Length > Main_Proj.Config.Max_Command_Line_Length then if Main_Proj.Config.Resp_File_Options = No_Name_List then Min_Number_Of_Objects := 0; else Min_Number_Of_Objects := 1; end if; -- Don't create a response file if there would not be -- a smaller number of arguments. if Natural (Objects.Length) > Min_Number_Of_Objects then declare Resp_File_Options : String_Vectors.Vector; List : Name_List_Index := Main_Proj.Config. Resp_File_Options; Nam_Nod : Name_Node; Other_Args : String_Vectors.Vector; begin while List /= No_Name_List loop Nam_Nod := Main_File.Tree.Shared.Name_Lists.Table (List); Resp_File_Options.Append (Get_Name_String (Nam_Nod.Name)); List := Nam_Nod.Next; end loop; for Arg of Other_Arguments loop Other_Args.Append (Arg.Name); end loop; Aux.Create_Response_File (Format => Main_Proj.Config.Resp_File_Format, Objects => Objects, Other_Arguments => Other_Args, Resp_File_Options => Resp_File_Options, Name_1 => Response_File_Name, Name_2 => Response_2); Record_Temp_File (Shared => Main_File.Tree.Shared, Path => Response_File_Name); if Response_2 /= No_Path then Record_Temp_File (Shared => Main_File.Tree.Shared, Path => Response_2); end if; if Main_Proj.Config.Resp_File_Format = GCC or else Main_Proj.Config.Resp_File_Format = GCC_GNU or else Main_Proj.Config.Resp_File_Format = GCC_Object_List or else Main_Proj.Config.Resp_File_Format = GCC_Option_List then Add_Argument (Arguments, "@" & Get_Name_String (Response_File_Name), Opt.Verbose_Mode); Objects.Clear; Other_Arguments.Clear; else -- Replace the first object file arguments -- with the argument(s) specifying the -- response file. No need to update -- Arguments_Displayed, as the values are -- already correct (= Verbose_Mode). if Resp_File_Options.Is_Empty then Add_Argument (Arguments, Get_Name_String (Response_File_Name), Opt.Verbose_Mode); Objects.Clear; else Resp_File_Options.Replace_Element (Resp_File_Options.Last_Index, Resp_File_Options.Last_Element & Get_Name_String (Response_File_Name)); Add_Arguments (Arguments, Resp_File_Options, Opt.Verbose_Mode); Objects.Clear; end if; -- And put the arguments following the object -- files immediately after the response file -- argument(s). Update Arguments_Displayed -- too. Arguments.Append_Vector (Other_Arguments); Other_Arguments.Clear; end if; end; end if; end if; end; end if; -- Complete the command line if needed for Obj of Objects loop Add_Argument (Arguments, Obj, Opt.Verbose_Mode, not Opt.Verbose_Mode); end loop; Arguments.Append_Vector (Other_Arguments); Objects.Clear; Other_Arguments.Clear; -- Delete an eventual executable, in case it is a symbolic -- link as we don't want to modify the target of the link. declare Dummy : Boolean; begin Delete_File (Get_Name_String (Exec_Path_Name), Dummy); end; if not Opt.Quiet_Output then if Opt.Verbose_Mode then Display_Command (Arguments, Linker_Path); else Display (Section => GPR.Link, Command => "link", Argument => Main); end if; end if; declare Pid : Process_Id; Args_Vector : String_Vectors.Vector; Args_List : String_List_Access; begin Main_File.Command.Append (Linker_Path.all); for Arg of Arguments loop Args_Vector.Append (Arg.Name); Main_File.Command.Append (Arg.Name); end loop; Args_List := new String_List'(To_Argument_List (Args_Vector)); Script_Write (Linker_Path.all, Args_Vector); Pid := Non_Blocking_Spawn (Linker_Path.all, Args_List.all); Free (Args_List); if Pid = Invalid_Pid then Put ("Can't start linker "); Put_Line (Linker_Path.all); Record_Failure (Main_File); else Add_Process (Pid, (Linking, Main_File)); Display_Processes ("link"); end if; end; end if; end Link_Main; --------- -- Run -- --------- procedure Run is Main : Main_Info; procedure Do_Link (Project : Project_Id; Tree : Project_Tree_Ref); procedure Await_Link; procedure Wait_For_Available_Slot; ---------------- -- Await_Link -- ---------------- procedure Await_Link is Data : Process_Data; OK : Boolean; begin loop Await_Process (Data, OK); if Data /= No_Process_Data then if not OK then Exit_Code := E_Subtool; Record_Failure (Data.Main); end if; Display_Processes ("link"); return; end if; end loop; end Await_Link; ------------- -- Do_Link -- ------------- procedure Do_Link (Project : Project_Id; Tree : Project_Tree_Ref) is pragma Unreferenced (Project); Main_File : Main_Info; begin if Builder_Data (Tree).Need_Linking and then not Stop_Spawning then Mains.Reset; loop Main_File := Mains.Next_Main; exit when Main_File = No_Main_Info; if Main_File.Tree = Tree and then not Project_Compilation_Failed (Main_File.Project) and then Main_File.Source.Language.Config.Compiler_Driver /= Empty_File then Wait_For_Available_Slot; exit when Stop_Spawning; Link_Main (Main_File); exit when Stop_Spawning; end if; end loop; end if; end Do_Link; procedure Link_All is new For_Project_And_Aggregated (Do_Link); ----------------------------- -- Wait_For_Available_Slot -- ----------------------------- procedure Wait_For_Available_Slot is begin while Outstanding_Processes >= Opt.Maximum_Linkers loop Await_Link; end loop; end Wait_For_Available_Slot; begin Outstanding_Processes := 0; Stop_Spawning := False; Link_All (Main_Project, Project_Tree); while Outstanding_Processes > 0 loop Await_Link; end loop; if Bad_Processes.Length = 1 then Main := Bad_Processes.First_Element; Fail_Program (Main.Tree, "link of " & Get_Name_String_Safe (Main.File) & " failed", Command => (if Main.Command.Is_Empty or else Opt.Verbosity_Level /= Opt.None then "" else "failed command was: " & String_Vector_To_String (Main.Command)), Exit_Code => E_Subtool); elsif not Bad_Processes.Is_Empty then for Main of Bad_Processes loop Put (" link of "); Put (Get_Name_String (Main.File)); Put_Line (" failed"); if not Main.Command.Is_Empty and then Opt.Verbosity_Level = Opt.None then Put_Line (" failed command was: " & String_Vector_To_String (Main.Command)); end if; end loop; Fail_Program (Bad_Processes.Last_Element.Tree, "*** link phase failed", Exit_Code => E_Subtool); end if; end Run; end Gprbuild.Link; gprbuild-25.0.0/src/gprbuild-link.ads000066400000000000000000000027551470075373400174540ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2011-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ package Gprbuild.Link is procedure Run; -- Perform linking, if necessary, for all registered mains: main project, -- aggregated projects,... end Gprbuild.Link; gprbuild-25.0.0/src/gprbuild-main.adb000066400000000000000000002622151470075373400174210ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2011-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ with Ada.Assertions; use Ada.Assertions; with Ada.Command_Line; use Ada.Command_Line; with Ada.Directories; with Ada.Exceptions; use Ada.Exceptions; with Ada.Text_IO; use Ada.Text_IO; pragma Warnings (Off); with System; with GNAT.Case_Util; use GNAT.Case_Util; with System.Multiprocessors; use System.Multiprocessors; pragma Warnings (On); with GNAT.Command_Line; use GNAT.Command_Line; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.OS_Lib; with Gpr_Build_Util; use Gpr_Build_Util; with Gprbuild.Compile; with Gprbuild.Link; with Gprbuild.Post_Compile; with GPR.Compilation.Process.Waiter; with GPR.Compilation.Slave; with GPR; use GPR; with GPR.Debug; use GPR.Debug; with GPR.Conf; use GPR.Conf; with GPR.Names; use GPR.Names; with GPR.Osint; use GPR.Osint; with GPR.Output; use GPR.Output; with GPR.Proc; use GPR.Proc; with GPR.Env; with GPR.Err; with GPR.Jobserver; with GPR.Opt; use GPR.Opt; with GPR.Script; use GPR.Script; with GPR.Snames; use GPR.Snames; with GPR.Tree; use GPR.Tree; with GPR.Util.Aux; use GPR.Util; procedure Gprbuild.Main is CodePeer_String : constant String := "codepeer"; -- Used in CopePeer mode for the target and the subdirs Dumpmachine : constant String := "--dumpmachine"; -- Switch to display the normalized hostname Dash_A_Warning : constant String := "warning: switch -a is ignored and no additional source is compiled"; -- Warning issued when gprbuild is invoked with switch -a Dash_A_Warning_Issued : Boolean := False; -- Flag used to avoid issuing the several times the warning for switch -a Subst_Switch_Present : Boolean := False; -- True if --compiler-subst=... or --compiler-pkg-subst=... appears on the -- command line. Used to detect switches that are incompatible with these. -- Also used to prevent passing builder args to the "compiler". These -- switches are used by ASIS-based tools such as gnatpp when the -- --incremental switch is given. Main_On_Command_Line : Boolean := False; -- True if there is at least one main specified on the command line Is_Unix : constant Boolean := GNAT.OS_Lib.Path_Separator = ':'; procedure Initialize; -- Do the necessary package intialization and process the command line -- arguments. procedure Usage; -- Display the usage function Add_Global_Switches (Switch : String; For_Lang : Name_Id; For_Builder : Boolean; Has_Global_Compilation_Switches : Boolean) return Boolean; -- Take into account a global switch (builder or global compilation switch) -- read from the project file. procedure Add_Mains_To_Queue; -- Check that each main is a single file name and that it is a source -- of a project from the tree. procedure Scan_Arg (Arg : String; Command_Line : Boolean; Language : Name_Id; Success : out Boolean); -- Process one gprbuild argument Arg. Command_Line is True if the argument -- is specified on the command line. procedure Add_Option (Arg : String; Command_Line : Boolean); -- Add a switch for a compiler or all compilers, or for the binder or for -- the linker. The table where this option is stored depends on the value -- of Current_Processor and other global variables. procedure Copyright; -- Output the Copyright notice type Sigint_Handler is access procedure; pragma Convention (C, Sigint_Handler); procedure Install_Int_Handler (Handler : Sigint_Handler); pragma Import (C, Install_Int_Handler, "__gnat_install_int_handler"); -- Called by Gnatmake to install the SIGINT handler below No_Object_Check_Switch : constant String := "--no-object-check"; Direct_Import_Only_Switch : constant String := "--direct-import-only"; Indirect_Imports_Switch : constant String := "--indirect-imports"; No_Indirect_Imports_Switch : constant String := "--no-indirect-imports"; Current_Working_Dir : constant String := Get_Current_Dir; -- The current working directory type Processor is (None, Linker, Binder, Compiler, Gprconfig); Current_Processor : Processor := None; -- This variable changes when switches -*args are used Current_Builder_Comp_Option_Table : String_Vector_Access := No_Builder_Comp_Option_Table; ------------------------------------------- -- Options specified on the command line -- ------------------------------------------- package Options is type Option_Type is (Force_Compilations_Option, Keep_Going_Option, Maximum_Compilers_Option, Maximum_Binders_Option, Maximum_Linkers_Option, Quiet_Output_Option, Check_Switches_Option, Verbose_Mode_Option, Verbose_Low_Mode_Option, Verbose_Medium_Mode_Option, Verbose_High_Mode_Option, Warnings_Treat_As_Error, Warnings_Normal, Warnings_Suppress, Indirect_Imports); subtype Maximum_Processes_Range is Option_Type range Maximum_Compilers_Option .. Maximum_Linkers_Option; procedure Register_Command_Line_Option (Option : Option_Type; Value : Natural := 0); -- Record a command line option procedure Process_Command_Line_Options; -- Reprocess the recorded command line options that have priority over -- the options in package Builder of the main project. end Options; use Options; ------------------------ -- Add_Mains_To_Queue -- ------------------------ procedure Add_Mains_To_Queue is Main_Id : Main_Info; begin Mains.Reset; loop Main_Id := Mains.Next_Main; exit when Main_Id = No_Main_Info; if Main_Id.Source /= No_Source then -- Fail if any main is declared as an excluded source file if Main_Id.Source.Locally_Removed then Fail_Program (Project_Tree, "main """ & Get_Name_String_Safe (Main_Id.Source.File) & """ cannot also be an excluded file", Exit_Code => E_General); end if; if Is_Allowed_Language (Main_Id.Source.Language.Name) then Queue.Insert (Source => (Tree => Main_Id.Tree, Id => Main_Id.Source, Closure => False), With_Roots => Builder_Data (Main_Id.Tree).Closure_Needed); -- If a non Ada main has no roots, then all sources need to be -- compiled, so no need to check for closure. if Main_Id.Source.Language.Config.Kind /= Unit_Based and then Main_Id.Source.Roots = null then Builder_Data (Main_Id.Tree).Closure_Needed := False; end if; end if; end if; end loop; if Total_Errors_Detected /= 0 then Fail_Program (Project_Tree, "cannot continue"); end if; -- If the main project is an aggregated project and there is at least -- one main on the command line, do not add the sources of the projects -- without mains to the queue. if Main_Project.Qualifier = Aggregate and then Main_On_Command_Line then Mains.Reset; loop Main_Id := Mains.Next_Main; exit when Main_Id = No_Main_Info; Queue.Insert_Project_Sources (Project => Main_Id.Project, Project_Tree => Main_Id.Tree, Unique_Compile => Unique_Compile, All_Projects => not Unique_Compile or else (Unique_Compile_All_Projects or Recursive)); end loop; else Queue.Insert_Project_Sources (Project => Main_Project, Project_Tree => Project_Tree, Unique_Compile => Unique_Compile, All_Projects => not Unique_Compile or else (Unique_Compile_All_Projects or Recursive)); end if; end Add_Mains_To_Queue; ------------------------- -- Add_Global_Switches -- ------------------------- function Add_Global_Switches (Switch : String; For_Lang : Name_Id; For_Builder : Boolean; Has_Global_Compilation_Switches : Boolean) return Boolean is Success : Boolean; begin if For_Builder then if Has_Global_Compilation_Switches then Builder_Switches_Lang := No_Name; else Builder_Switches_Lang := For_Lang; end if; Scan_Arg (Switch, Command_Line => False, Language => For_Lang, Success => Success); return Success; else Current_Processor := Compiler; Current_Builder_Comp_Option_Table := Builder_Compiling_Options_HTable.Get (For_Lang); if Current_Builder_Comp_Option_Table = No_Builder_Comp_Option_Table then Current_Builder_Comp_Option_Table := new String_Vectors.Vector' (String_Vectors.Empty_Vector); Builder_Compiling_Options_HTable.Set (For_Lang, Current_Builder_Comp_Option_Table); end if; Add_Option (Switch, Command_Line => False); Current_Processor := None; return True; end if; end Add_Global_Switches; ---------------- -- Add_Option -- ---------------- procedure Add_Option (Arg : String; Command_Line : Boolean) is Option : String_Access := new String'(Arg); begin case Current_Processor is when None => null; when Linker => -- Add option to the linker table if Command_Line then Test_If_Relative_Path (Switch => Option, Parent => Current_Working_Dir, Including_Switch => Dash_L); else Test_If_Relative_Path (Switch => Option, Parent => Main_Project_Dir.all, Including_Switch => Dash_L); end if; Command_Line_Linker_Options.Append (Option.all); when Binder => if Command_Line then Test_If_Relative_Path (Switch => Option, Parent => Current_Working_Dir, Including_Switch => No_Name); else Test_If_Relative_Path (Switch => Option, Parent => Main_Project_Dir.all, Including_Switch => No_Name); end if; if Current_Bind_Option_Table = No_Bind_Option_Table then -- Option for all binder All_Language_Binder_Options.Append (Option.all); else -- Option for a single binder Current_Bind_Option_Table.Append (Option.all); end if; when Compiler => if Command_Line then if Starts_With (Arg, "-gnatec=") then declare Key : String := GNAT.OS_Lib.Normalize_Pathname (Arg (Arg'First + 8 .. Arg'Last)); Value : constant Name_Id := Get_Name_Id (Key); begin Canonical_Case_File_Name (Key); Cmd_Line_Adc_Files.Include (Get_Name_Id (Key), Value); if Current_Comp_Option_Table = No_Comp_Option_Table then -- Normalize option for all compilers All_Language_Compiling_Options.Append (Arg (Arg'First .. Arg'First + 7) & Key); else -- Normalize option for a single compiler Current_Comp_Option_Table.Append (Arg (Arg'First .. Arg'First + 7) & Key); end if; end; else if Starts_With (Arg, "-gnateT=") then declare Key : String := GNAT.OS_Lib.Normalize_Pathname (Arg (Arg'First + 8 .. Arg'Last)); Value : constant Name_Id := Get_Name_Id (Key); begin Canonical_Case_File_Name (Key); Cmd_Line_Target_Dep_Info_Files.Include (Get_Name_Id (Key), Value); end; end if; if Current_Comp_Option_Table = No_Comp_Option_Table then -- Option for all compilers All_Language_Compiling_Options.Append (Arg); else -- Option for a single compiler Current_Comp_Option_Table.Append (Arg); end if; end if; else if Current_Builder_Comp_Option_Table = No_Builder_Comp_Option_Table then -- Option for all compilers All_Language_Builder_Compiling_Options.Append (Arg); else -- Option for a single compiler Current_Builder_Comp_Option_Table.Append (Arg); end if; end if; when Gprconfig => Command_Line_Gprconfig_Options.Append (Option.all); end case; end Add_Option; --------------- -- Copyright -- --------------- procedure Copyright is begin -- Only output the Copyright notice once if not Copyright_Output then Copyright_Output := True; Display_Version ("GPRBUILD", "2004"); end if; end Copyright; ------------- -- Options -- ------------- package body Options is type Option_Data is record Option : Option_Type; Value : Natural := 0; end record; package Option_Data_Vectors is new Ada.Containers.Vectors (Positive, Option_Data); Command_Line_Options : Option_Data_Vectors.Vector; -- Table to store the command line options ---------------------------------- -- Process_Command_Line_Options -- ---------------------------------- procedure Process_Command_Line_Options is begin for Item of Command_Line_Options loop case Item.Option is when Force_Compilations_Option => Opt.Force_Compilations := True; when Keep_Going_Option => Opt.Keep_Going := True; when Maximum_Compilers_Option => Opt.Maximum_Compilers := Item.Value; when Maximum_Binders_Option => Opt.Maximum_Binders := Item.Value; when Maximum_Linkers_Option => Opt.Maximum_Linkers := Item.Value; when Quiet_Output_Option => Opt.Quiet_Output := True; Opt.Verbose_Mode := False; Opt.Verbosity_Level := Opt.None; when Check_Switches_Option => Opt.Check_Switches := True; when Verbose_Mode_Option => Opt.Verbose_Mode := True; Opt.Verbosity_Level := Opt.Low; Opt.Quiet_Output := False; when Verbose_Low_Mode_Option => Opt.Verbose_Mode := True; Opt.Verbosity_Level := Opt.Low; Opt.Quiet_Output := False; when Verbose_Medium_Mode_Option => Opt.Verbose_Mode := True; Opt.Verbosity_Level := Opt.Medium; Opt.Quiet_Output := False; when Verbose_High_Mode_Option => Opt.Verbose_Mode := True; Opt.Verbosity_Level := Opt.High; Opt.Quiet_Output := False; when Warnings_Treat_As_Error => Opt.Warning_Mode := Opt.Treat_As_Error; when Warnings_Normal => Opt.Warning_Mode := Opt.Normal; when Warnings_Suppress => Opt.Warning_Mode := Opt.Suppress; when Indirect_Imports => Gprbuild.Indirect_Imports := Item.Value /= 0; end case; end loop; end Process_Command_Line_Options; ---------------------------------- -- Register_Command_Line_Option -- ---------------------------------- procedure Register_Command_Line_Option (Option : Option_Type; Value : Natural := 0) is begin Command_Line_Options.Append (Option_Data'(Option => Option, Value => Value)); end Register_Command_Line_Option; end Options; -------------- -- Scan_Arg -- -------------- procedure Scan_Arg (Arg : String; Command_Line : Boolean; Language : Name_Id; Success : out Boolean) is Processed : Boolean := True; procedure Forbidden_In_Package_Builder; -- Fail if switch Arg is found in package Builder ---------------------------------- -- Forbidden_In_Package_Builder -- ---------------------------------- procedure Forbidden_In_Package_Builder is begin if not Command_Line then Fail_Program (Project_Tree, Arg & " can only be used on the command line", Exit_Code => E_General); end if; end Forbidden_In_Package_Builder; begin pragma Assert (Arg'First = 1); Success := True; if Arg'Length = 0 then return; end if; -- If preceding switch was -P, a project file name need to be -- specified, not a switch. if Project_File_Name_Expected then if Arg (1) = '-' then Fail_Program (Project_Tree, "project file name missing after -P", Exit_Code => E_General); else Project_File_Name_Expected := False; Project_File_Name := new String'(Arg); end if; -- If preceding switch was -o, an executable name need to be -- specified, not a switch. elsif Output_File_Name_Expected then if Arg (1) = '-' then Fail_Program (Project_Tree, "output file name missing after -o", Exit_Code => E_General); else Output_File_Name_Expected := False; Output_File_Name := new String'(Arg); end if; elsif Search_Project_Dir_Expected then if Arg (1) = '-' then Fail_Program (Project_Tree, "directory name missing after -aP", Exit_Code => E_General); else Search_Project_Dir_Expected := False; GPR.Env.Add_Directories (Root_Environment.Project_Path, Arg); end if; elsif Db_Directory_Expected then Db_Directory_Expected := False; Knowledge.Parse_Knowledge_Base (Project_Tree, Arg); Add_Db_Switch_Arg (Get_Name_Id (Arg)); -- Set the processor/language for the following switches -- -cargs all compiler arguments elsif Arg = "-cargs" then Current_Processor := Compiler; if Command_Line then Current_Comp_Option_Table := No_Comp_Option_Table; else Current_Builder_Comp_Option_Table := No_Builder_Comp_Option_Table; end if; -- -cargs:lang arguments for compiler of language lang elsif Arg'Length > 7 and then Arg (1 .. 7) = "-cargs:" then Current_Processor := Compiler; declare Lang : constant Name_Id := Get_Lower_Name_Id (Arg (8 .. Arg'Last)); begin if Command_Line then Current_Comp_Option_Table := Compiling_Options_HTable.Get (Lang); if Current_Comp_Option_Table = No_Comp_Option_Table then Current_Comp_Option_Table := new String_Vectors.Vector' (String_Vectors.Empty_Vector); Compiling_Options_HTable.Set (Lang, Current_Comp_Option_Table); end if; else Current_Builder_Comp_Option_Table := Builder_Compiling_Options_HTable.Get (Lang); if Current_Builder_Comp_Option_Table = No_Builder_Comp_Option_Table then Current_Builder_Comp_Option_Table := new String_Vectors.Vector'(String_Vectors.Empty_Vector); Builder_Compiling_Options_HTable.Set (Lang, Current_Builder_Comp_Option_Table); end if; end if; end; -- -bargs all binder arguments elsif Arg = "-bargs" then if Subst_Switch_Present then return; -- ignore switch incompatible with --compiler-subst end if; Current_Processor := Binder; Current_Bind_Option_Table := No_Bind_Option_Table; -- -bargs:lang arguments for binder of language lang elsif Arg'Length > 7 and then Arg (1 .. 7) = "-bargs:" then if Subst_Switch_Present then return; -- ignore switch incompatible with --compiler-subst end if; Current_Processor := Binder; declare Lang : constant Name_Id := Get_Lower_Name_Id (Arg (8 .. Arg'Last)); begin Current_Bind_Option_Table := Binder_Options_HTable.Get (Lang); if Current_Bind_Option_Table = No_Bind_Option_Table then Current_Bind_Option_Table := new String_Vectors.Vector'(String_Vectors.Empty_Vector); Binder_Options_HTable.Set (Lang, Current_Bind_Option_Table); end if; end; -- -largs linker arguments elsif Arg = "-largs" then if Subst_Switch_Present then return; -- ignore switch incompatible with --compiler-subst end if; Current_Processor := Linker; -- -gargs/margs options directly for gprbuild -- support -margs for compatibility with gnatmake elsif Arg = "-kargs" then Current_Processor := Gprconfig; elsif Arg = "-gargs" or else Arg = "-margs" then Current_Processor := None; -- A special test is needed for the -o switch within a -largs since -- that is another way to specify the name of the final executable. elsif Command_Line and then Current_Processor = Linker and then Arg = "-o" then Fail_Program (Project_Tree, "switch -o not allowed within a -largs. Use -o directly.", Exit_Code => E_General); -- If current processor is not gprbuild directly, store the option -- in the appropriate table. elsif Current_Processor /= None then Add_Option (Arg, Command_Line); -- Switches start with '-' elsif Arg (1) = '-' then if Arg = Keep_Temp_Files_Option then -- This is equivalent to switch -dn: Keep temporary files Set_Debug_Flag ('n'); Opt.Keep_Temporary_Files := True; elsif Arg = Complete_Output_Option then Forbidden_In_Package_Builder; if Distributed_Mode then Fail_Program (Project_Tree, "options " & Complete_Output_Option & Distributed_Option & " are not compatible", Exit_Code => E_General); end if; Complete_Output := True; No_Complete_Output := False; elsif Arg = No_Complete_Output_Option or else Arg = "-n" then Forbidden_In_Package_Builder; No_Complete_Output := True; Complete_Output := False; elsif Arg = No_Project_Option then Forbidden_In_Package_Builder; No_Project_File := True; if Project_File_Name /= null then Fail_Program (Project_Tree, "cannot specified --no-project with a project file", Exit_Code => E_General); end if; elsif Arg'Length >= Distributed_Option'Length and then Arg (1 .. Distributed_Option'Length) = Distributed_Option then if Subst_Switch_Present then return; -- ignore switch incompatible with --compiler-subst end if; if Complete_Output then Fail_Program (Project_Tree, "options " & Complete_Output_Option & Distributed_Option & " are not compatible", Exit_Code => E_General); end if; if Build_Script_Name /= null then Fail_Program (Project_Tree, "options " & Build_Script_Option & Distributed_Option & " are not compatible"); end if; Distributed_Mode := True; declare Hosts : constant String := Aux.Get_Slaves_Hosts (Project_Tree, Arg); begin if Hosts = "" then Fail_Program (Project_Tree, "missing hosts for distributed mode compilation", Exit_Code => E_General); else GPR.Compilation.Slave.Record_Slaves (Hosts); end if; end; elsif Arg'Length >= Hash_Option'Length and then Arg (1 .. Hash_Option'Length) = Hash_Option then if Subst_Switch_Present then return; -- ignore switch incompatible with --compiler-subst end if; Hash_Value := new String'(Arg (Hash_Option'Length + 2 .. Arg'Last)); elsif Arg'Length >= Slave_Env_Option'Length and then Arg (1 .. Slave_Env_Option'Length) = Slave_Env_Option then if Subst_Switch_Present then return; -- ignore switch incompatible with --compiler-subst end if; if Arg = Slave_Env_Option then -- Just --slave-env, it is up to gprbuild to build a sensible -- slave environment value. Slave_Env_Auto := True; else Slave_Env := new String'(Arg (Slave_Env_Option'Length + 2 .. Arg'Last)); end if; elsif Arg'Length >= Compiler_Subst_Option'Length and then Arg (1 .. Compiler_Subst_Option'Length) = Compiler_Subst_Option then Forbidden_In_Package_Builder; -- We should have Arg set to something like: -- "compiler-subst=ada,gnatpp". -- We need to pick out the "ada" and "gnatpp". declare function Scan_To_Comma (Start : Positive) return Positive; -- Scan forward from Start until we find a comma or end of -- string. Return the index just before the ",", or Arg'Last. function Scan_To_Comma (Start : Positive) return Positive is begin if Start >= Arg'Last then return Arg'Last; end if; return Result : Positive := Start do while Result < Arg'Last and then Arg (Result + 1) /= ',' loop Result := Result + 1; end loop; end return; end Scan_To_Comma; Lang_Start : constant Positive := Compiler_Subst_Option'Length + 1; Lang_End : constant Positive := Scan_To_Comma (Lang_Start); Comp_Start : constant Positive := Lang_End + 2; Comp_End : constant Positive := Scan_To_Comma (Comp_Start); Lang : String renames Arg (Lang_Start .. Lang_End); Comp : String renames Arg (Comp_Start .. Comp_End); begin if Lang = "" or else Comp = "" then Fail_Program (Project_Tree, "invalid switch " & Arg, Exit_Code => E_General); -- This switch is intended for internal use by ASIS tools, -- so a friendlier error message isn't needed here. end if; Compiler_Subst_HTable.Include (Get_Lower_Name_Id (Lang), Get_Name_Id (Comp)); end; elsif Arg'Length >= Compiler_Pkg_Subst_Option'Length and then Arg (1 .. Compiler_Pkg_Subst_Option'Length) = Compiler_Pkg_Subst_Option then Forbidden_In_Package_Builder; declare Package_Name : String renames Arg (Compiler_Pkg_Subst_Option'Length + 1 .. Arg'Last); begin if Package_Name = "" then Fail_Program (Project_Tree, "invalid switch " & Arg); -- This switch is intended for internal use by ASIS tools, -- so a friendly error message isn't needed here. -- No error if the package doesn't exist; gnatpp might pass -- --compiler-pkg-subst=pretty_printer even when there is no -- package Pretty_Printer in the project file. end if; Compiler_Pkg_Subst := Get_Lower_Name_Id (Package_Name); end; elsif Arg'Length > Build_Script_Option'Length and then Arg (1 .. Build_Script_Option'Length) = Build_Script_Option then Forbidden_In_Package_Builder; if Distributed_Mode then Fail_Program (Project_Tree, "options " & Build_Script_Option & Distributed_Option & " are not compatible", Exit_Code => E_General); end if; declare Script_Name : constant String := Arg (Build_Script_Option'Length + 1 .. Arg'Last); begin if Is_Absolute_Path (Script_Name) then Build_Script_Name := new String'(Script_Name); else Build_Script_Name := new String'(Get_Current_Dir & Script_Name); end if; end; elsif Arg = "--db-" then Forbidden_In_Package_Builder; Load_Standard_Base := False; elsif Arg = "--db" then Forbidden_In_Package_Builder; Db_Directory_Expected := True; elsif Arg = "--display-paths" then Forbidden_In_Package_Builder; Display_Paths := True; elsif Arg = "--no-split-units" then Opt.No_Split_Units := True; elsif Arg = Single_Compile_Per_Obj_Dir_Switch then Opt.One_Compilation_Per_Obj_Dir := True; elsif Arg'Length > Source_Info_Option'Length and then Arg (1 .. Source_Info_Option'Length) = Source_Info_Option then Forbidden_In_Package_Builder; Project_Tree.Source_Info_File_Name := new String'(Arg (Source_Info_Option'Length + 1 .. Arg'Last)); elsif Arg'Length > Config_Project_Option'Length and then Arg (1 .. Config_Project_Option'Length) = Config_Project_Option then if Config_Project_File_Name /= null and then Command_Line and then (Autoconf_Specified or else Config_Project_File_Name.all /= Arg (Config_Project_Option'Length + 1 .. Arg'Last)) then Fail_Program (Project_Tree, "several different configuration switches cannot be" & " specified", Exit_Code => E_General); else Autoconfiguration := False; Autoconf_Specified := False; Config_Project_File_Name := new String' (Arg (Config_Project_Option'Length + 1 .. Arg'Last)); end if; elsif Arg'Length > Autoconf_Project_Option'Length and then Arg (1 .. Autoconf_Project_Option'Length) = Autoconf_Project_Option then Forbidden_In_Package_Builder; if Config_Project_File_Name /= null and then (not Autoconf_Specified or else Config_Project_File_Name.all /= Arg (Autoconf_Project_Option'Length + 1 .. Arg'Last)) then Fail_Program (Project_Tree, "several different configuration switches cannot be" & " specified", Exit_Code => E_General); else Config_Project_File_Name := new String' (Arg (Autoconf_Project_Option'Length + 1 .. Arg'Last)); Autoconf_Specified := True; end if; elsif Arg'Length > Target_Project_Option'Length and then Arg (1 .. Target_Project_Option'Length) = Target_Project_Option then Forbidden_In_Package_Builder; if Target_Name /= null then if Target_Name.all /= Arg (Target_Project_Option'Length + 1 .. Arg'Last) then Fail_Program (Project_Tree, "several different target switches cannot be specified", Exit_Code => E_General); end if; else Target_Name := new String' (Arg (Target_Project_Option'Length + 1 .. Arg'Last)); end if; elsif Arg'Length > RTS_Option'Length and then Arg (1 .. RTS_Option'Length) = RTS_Option then declare Set : constant Boolean := Runtime_Name_Set_For (Name_Ada); Old : constant String := Runtime_Name_For (Name_Ada); RTS : constant String := Arg (RTS_Option'Length + 1 .. Arg'Last); begin if Command_Line then if Set and then Old /= RTS then Fail_Program (Project_Tree, "several different run-times cannot be specified", Exit_Code => E_General); end if; Set_Runtime_For (Name_Ada, RTS); Set_Default_Runtime_For (Name_Ada, RTS); end if; -- Ignore any --RTS= switch in package Builder. These are only -- taken into account to create the config file in -- auto-configuration. end; elsif Arg'Length > RTS_Language_Option'Length and then Arg (1 .. RTS_Language_Option'Length) = RTS_Language_Option then declare Language_Name : Name_Id := No_Name; RTS_Start : Natural := Arg'Last + 1; begin for J in RTS_Language_Option'Length + 2 .. Arg'Last loop if Arg (J) = '=' then Language_Name := Get_Lower_Name_Id (Arg (RTS_Language_Option'Length + 1 .. J - 1)); RTS_Start := J + 1; exit; end if; end loop; if Language_Name = No_Name then Fail_Program (Project_Tree, "illegal switch: " & Arg, Exit_Code => E_General); elsif Command_Line then -- Ignore any --RTS:= switch in package Builder. These -- are only taken into account to create the config file in -- auto-configuration. declare RTS : constant String := Arg (RTS_Start .. Arg'Last); Set : constant Boolean := Runtime_Name_Set_For (Language_Name); Old : constant String := Runtime_Name_For (Language_Name); begin if Set and then Old /= RTS then Fail_Program (Project_Tree, "several different run-times cannot be specified" & " for the same language"); else Set_Runtime_For (Language_Name, RTS); Set_Default_Runtime_For (Language_Name, RTS); end if; end; end if; end; elsif Arg'Length > Implicit_With_Option'Length and then Arg (Implicit_With_Option'Range) = Implicit_With_Option then Forbidden_In_Package_Builder; if Implicit_With /= null then Fail_Program (Project_Tree, "several " & Implicit_With_Option & " options cannot be specified", Exit_Code => E_General); end if; Implicit_With := new String' (Ensure_Suffix (Arg (Implicit_With_Option'Last + 1 .. Arg'Last), Project_File_Extension)); elsif Arg'Length > Subdirs_Option'Length and then Arg (1 .. Subdirs_Option'Length) = Subdirs_Option then Forbidden_In_Package_Builder; Subdirs := new String'(Arg (Subdirs_Option'Length + 1 .. Arg'Last)); elsif Is_Unix and then Arg'Length > Getrusage_Option'Length and then Arg (1 .. Getrusage_Option'Length) = Getrusage_Option then Forbidden_In_Package_Builder; Getrusage := new String' (GNAT.OS_Lib.Normalize_Pathname (Arg (Getrusage_Option'Length + 1 .. Arg'Last))); elsif Arg'Length > Src_Subdirs_Option'Length and then Arg (1 .. Src_Subdirs_Option'Length) = Src_Subdirs_Option then Forbidden_In_Package_Builder; Src_Subdirs := new String'(Arg (Src_Subdirs_Option'Length + 1 .. Arg'Last)); elsif Arg'Length >= Relocate_Build_Tree_Option'Length and then Arg (1 .. Relocate_Build_Tree_Option'Length) = Relocate_Build_Tree_Option then Forbidden_In_Package_Builder; if Arg'Length = Relocate_Build_Tree_Option'Length then Build_Tree_Dir := new String'(Current_Working_Dir); else Build_Tree_Dir := new String' (Normalize_Pathname (Arg (Relocate_Build_Tree_Option'Length + 2 .. Arg'Last), Current_Working_Dir, Resolve_Links => Opt.Follow_Links_For_Dirs) & Dir_Separator); end if; -- Out-of-tree compilation also imply -p (create missing dirs) Opt.Create_Dirs := Create_All_Dirs; elsif Arg'Length >= Root_Dir_Option'Length and then Arg (1 .. Root_Dir_Option'Length) = Root_Dir_Option then Forbidden_In_Package_Builder; Root_Dir := new String' (Normalize_Pathname (Arg (Root_Dir_Option'Length + 2 .. Arg'Last), Current_Working_Dir, Resolve_Links => Opt.Follow_Links_For_Dirs) & Dir_Separator); elsif Command_Line and then Arg = "--no-sal-binding" then No_SAL_Binding := True; elsif Command_Line and then Arg'Length > Restricted_To_Languages_Option'Length and then Arg (1 .. Restricted_To_Languages_Option'Length) = Restricted_To_Languages_Option then declare Start : Positive := Restricted_To_Languages_Option'Length + 1; Finish : Positive; begin Processed := False; while Start <= Arg'Last loop Finish := Start; loop exit when Finish > Arg'Last or else Arg (Finish) = ','; Finish := Finish + 1; end loop; if Finish > Start then Add_Restricted_Language (Arg (Start .. Finish - 1)); Processed := True; end if; Start := Finish + 1; end loop; end; elsif Arg = Indirect_Imports_Switch then Indirect_Imports := True; if Command_Line then Register_Command_Line_Option (Options.Indirect_Imports, 1); end if; elsif Arg in No_Indirect_Imports_Switch | Direct_Import_Only_Switch then Indirect_Imports := False; if Command_Line then Register_Command_Line_Option (Options.Indirect_Imports, 0); end if; elsif Arg = Gpr_Build_Util.Unchecked_Shared_Lib_Imports then Forbidden_In_Package_Builder; Opt.Unchecked_Shared_Lib_Imports := True; elsif Arg = No_Object_Check_Switch then Object_Checked := False; elsif Arg = No_Exit_Message_Option then Opt.No_Exit_Message := True; elsif Arg = "--codepeer" then Forbidden_In_Package_Builder; if not CodePeer_Mode then CodePeer_Mode := True; Object_Checked := False; if Target_Name = null then Target_Name := new String'(CodePeer_String); end if; if Subdirs = null then Subdirs := new String'(CodePeer_String); end if; end if; elsif Arg = "--gnatprove" then Forbidden_In_Package_Builder; if not GnatProve_Mode then GnatProve_Mode := True; end if; elsif Arg = Create_Map_File_Switch then if Subst_Switch_Present then return; -- ignore switch incompatible with --compiler-subst end if; Map_File := new String'(""); elsif Arg'Length > Create_Map_File_Switch'Length + 1 and then Arg (1 .. Create_Map_File_Switch'Length) = Create_Map_File_Switch and then Arg (Create_Map_File_Switch'Length + 1) = '=' then if Subst_Switch_Present then return; -- ignore switch incompatible with --compiler-subst end if; Map_File := new String'(Arg (Create_Map_File_Switch'Length + 2 .. Arg'Last)); elsif Arg'Length >= 3 and then Arg (1 .. 3) = "-aP" then Forbidden_In_Package_Builder; if Arg'Length = 3 then Search_Project_Dir_Expected := True; else GPR.Env.Add_Directories (Root_Environment.Project_Path, Arg (4 .. Arg'Last)); end if; elsif Arg = "-a" then if not Dash_A_Warning_Issued then Put_Line (Dash_A_Warning); Dash_A_Warning_Issued := True; end if; elsif Arg = "-b" then if Subst_Switch_Present then return; -- ignore switch incompatible with --compiler-subst end if; Opt.Bind_Only := True; elsif Arg = "-c" then Opt.Compile_Only := True; if Opt.Link_Only then Opt.Bind_Only := True; end if; elsif Arg = "-C" then -- This switch is only for upward compatibility null; elsif Arg = "-d" then Opt.Display_Compilation_Progress := True; elsif Arg'Length = 3 and then Arg (2) = 'd' then Set_Debug_Flag (Arg (3)); elsif Arg'Length > 3 and then Arg (1 .. 3) = "-eI" then if Subst_Switch_Present then return; -- ignore switch incompatible with --compiler-subst end if; Forbidden_In_Package_Builder; begin Main_Index := Int'Value (Arg (4 .. Arg'Last)); exception when Constraint_Error => Fail_Program (Project_Tree, "invalid switch " & Arg, Exit_Code => E_General); end; elsif Arg = "-eL" then Forbidden_In_Package_Builder; Opt.Follow_Links_For_Files := True; Opt.Follow_Links_For_Dirs := True; elsif Arg = "-eS" then Forbidden_In_Package_Builder; -- Accept switch for compatibility with gnatmake elsif Arg = "-f" then Opt.Force_Compilations := True; if Command_Line then Register_Command_Line_Option (Force_Compilations_Option); end if; elsif Arg = "-F" then Forbidden_In_Package_Builder; Opt.Full_Path_Name_For_Brief_Errors := True; elsif Arg = "-h" then Forbidden_In_Package_Builder; elsif Arg'Length > 2 and then Arg (2) = 'j' then declare Max_Proc : Natural := 0; Phase : Character := 'a'; -- all by default First : Positive; Opts : constant array (Maximum_Processes_Range) of access Positive := (Maximum_Compilers_Option => Opt.Maximum_Compilers'Access, Maximum_Binders_Option => Opt.Maximum_Binders'Access, Maximum_Linkers_Option => Opt.Maximum_Linkers'Access); procedure Register (Opt : Maximum_Processes_Range); -------------- -- Register -- -------------- procedure Register (Opt : Maximum_Processes_Range) is begin if Command_Line then Register_Command_Line_Option (Opt, Max_Proc); end if; Opts (Opt).all := Max_Proc; end Register; begin if Arg'Length > 3 and then Arg (3) not in '0' .. '9' then Phase := Arg (3); First := 4; else First := 3; end if; Max_Proc := Natural'Value (Arg (First .. Arg'Last)); if Max_Proc = 0 then Max_Proc := Natural (Number_Of_CPUs); if Max_Proc = 0 then Max_Proc := 1; end if; end if; case Phase is when 'a' => for J in Maximum_Processes_Range loop Register (J); end loop; when 'c' => Register (Maximum_Compilers_Option); when 'b' => Register (Maximum_Binders_Option); when 'l' => Register (Maximum_Linkers_Option); when others => Processed := False; end case; exception when Constraint_Error => Processed := False; end; elsif Arg = Autodetect_Jobserver_Option then Opt.Autodetect_Jobserver := True; elsif Arg = "-k" then Opt.Keep_Going := True; if Command_Line then Register_Command_Line_Option (Keep_Going_Option); end if; elsif Arg = "-l" then if Subst_Switch_Present then return; -- ignore switch incompatible with --compiler-subst end if; Opt.Link_Only := True; if Opt.Compile_Only then Opt.Bind_Only := True; end if; elsif Arg = "-m" then if Subst_Switch_Present then return; -- ignore switch incompatible with --compiler-subst end if; Opt.Minimal_Recompilation := True; elsif Arg = "-o" then Forbidden_In_Package_Builder; if Output_File_Name /= null then Fail_Program (Project_Tree, "cannot specify several -o switches"); else Output_File_Name_Expected := True; end if; elsif Arg = "-p" or else Arg = "--create-missing-dirs" then Forbidden_In_Package_Builder; Opt.Create_Dirs := Create_All_Dirs; elsif Arg'Length >= 2 and then Arg (2) = 'P' then Forbidden_In_Package_Builder; if No_Project_File then Fail_Program (Project_Tree, "cannot specify --no-project with a project file", Exit_Code => E_General); elsif Project_File_Name /= null then Fail_Program (Project_Tree, "cannot have several project files specified", Exit_Code => E_General); elsif Arg'Length = 2 then Project_File_Name_Expected := True; else Project_File_Name := new String'(Arg (3 .. Arg'Last)); end if; elsif Arg = "-q" then Opt.Quiet_Output := True; Opt.Verbose_Mode := False; Opt.Verbosity_Level := None; if Command_Line then Register_Command_Line_Option (Quiet_Output_Option); end if; elsif Arg = "-r" then Forbidden_In_Package_Builder; Recursive := True; elsif Arg = "-R" then if Subst_Switch_Present then return; -- ignore switch incompatible with --compiler-subst end if; Opt.Run_Path_Option := False; elsif Arg = "-s" then Opt.Check_Switches := True; if Command_Line then Register_Command_Line_Option (Check_Switches_Option); end if; elsif Arg = "-u" then Forbidden_In_Package_Builder; Unique_Compile := True; elsif Arg = "-U" then Forbidden_In_Package_Builder; Unique_Compile_All_Projects := True; Unique_Compile := True; elsif Arg = "-v" or else Arg = "-vl" then Opt.Verbose_Mode := True; Opt.Verbosity_Level := Opt.Low; Opt.Quiet_Output := False; if Command_Line then Register_Command_Line_Option (Verbose_Low_Mode_Option); end if; elsif Arg = "-vm" then Opt.Verbose_Mode := True; Opt.Verbosity_Level := Opt.Medium; Opt.Quiet_Output := False; if Command_Line then Register_Command_Line_Option (Verbose_Medium_Mode_Option); end if; elsif Arg = "-vh" then Opt.Verbose_Mode := True; Opt.Verbosity_Level := Opt.High; Opt.Quiet_Output := False; if Command_Line then Register_Command_Line_Option (Verbose_High_Mode_Option); end if; elsif Arg'Length >= 3 and then Arg (1 .. 3) = "-vP" then Forbidden_In_Package_Builder; if Arg'Length = 4 and then Arg (4) in '0' .. '2' then case Arg (4) is when '0' => Current_Verbosity := GPR.Default; when '1' => Current_Verbosity := GPR.Medium; when '2' => Current_Verbosity := GPR.High; when others => null; end case; else Fail_Program (Project_Tree, "invalid verbosity level " & Arg (4 .. Arg'Last), Exit_Code => E_General); end if; elsif Arg = "-we" then Opt.Warning_Mode := Opt.Treat_As_Error; if Command_Line then Register_Command_Line_Option (Warnings_Treat_As_Error); end if; elsif Arg = "-wn" then Opt.Warning_Mode := Opt.Normal; if Command_Line then Register_Command_Line_Option (Warnings_Normal); end if; elsif Arg = "-ws" then Opt.Warning_Mode := Opt.Suppress; if Command_Line then Register_Command_Line_Option (Warnings_Suppress); end if; elsif Arg = "-m2" then Opt.Checksum_Recompilation := True; elsif Arg = "-x" then Opt.Use_Include_Path_File := True; elsif Arg = "-z" then Opt.No_Main_Subprogram := True; elsif Arg'Length >= 3 and then Arg (2) = 'X' and then Is_External_Assignment (Root_Environment, Arg) then Forbidden_In_Package_Builder; -- Is_External_Assignment has side effects when it returns True null; elsif (Language = No_Name or else Language = Name_Ada) and then not Command_Line and then Arg = "-x" then -- For compatibility with gnatmake, ignore -x if found in the -- Builder switches. null; elsif (Language = No_Name or else Language = Name_Ada) and then not Subst_Switch_Present and then (Arg = "-fstack-check" or else Arg = "-fno-inline" or else (Arg'Length >= 2 and then (Arg (2) = 'O' or else Arg (2) = 'g'))) then -- For compatibility with gnatmake, use switch to compile Ada -- code. We don't do this if the --compiler-pkg-subst switch was -- given, because the tool won't understand normal compiler -- options. if Command_Line then Current_Comp_Option_Table := Compiling_Options_HTable.Get (Name_Ada); if Current_Comp_Option_Table = No_Comp_Option_Table then Current_Comp_Option_Table := new String_Vectors.Vector' (String_Vectors.Empty_Vector); Compiling_Options_HTable.Set (Name_Ada, Current_Comp_Option_Table); end if; else Current_Builder_Comp_Option_Table := Builder_Compiling_Options_HTable.Get (Name_Ada); if Current_Builder_Comp_Option_Table = No_Builder_Comp_Option_Table then Current_Builder_Comp_Option_Table := new String_Vectors.Vector'(String_Vectors.Empty_Vector); Builder_Compiling_Options_HTable.Set (Name_Ada, Current_Builder_Comp_Option_Table); end if; end if; Current_Processor := Compiler; Add_Option (Arg, Command_Line); Current_Processor := None; elsif (Language = No_Name or else Language = Name_Ada) and then (Arg = "-nostdlib" or else Arg = "-nostdinc") then -- For compatibility with gnatmake, use switch to bind Ada code -- code and for -nostdlib to link. Current_Bind_Option_Table := Binder_Options_HTable.Get (Name_Ada); if Current_Bind_Option_Table = No_Bind_Option_Table then Current_Bind_Option_Table := new String_Vectors.Vector'(String_Vectors.Empty_Vector); Binder_Options_HTable.Set (Name_Ada, Current_Bind_Option_Table); end if; Current_Processor := Binder; Add_Option (Arg, Command_Line); -- For -nostdlib, use the switch to link too if Arg = "-nostdlib" then Current_Processor := Linker; Add_Option (Arg, Command_Line); end if; Current_Processor := None; else Processed := False; end if; elsif Command_Line then -- The file name of a main or a project file declare File_Name : String := Arg; begin Canonical_Case_File_Name (File_Name); if File_Name'Length > Project_File_Extension'Length and then File_Name (File_Name'Last - Project_File_Extension'Length + 1 .. File_Name'Last) = Project_File_Extension then if No_Project_File then Fail_Program (Project_Tree, "cannot specify --no-project with a project file", Exit_Code => E_General); elsif Project_File_Name /= null then Fail_Program (Project_Tree, "cannot have several project files specified", Exit_Code => E_General); else Project_File_Name := new String'(File_Name); end if; else -- Not a project file, then it is a main Mains.Add_Main (Arg); Always_Compile := True; Main_On_Command_Line := True; end if; end; else Processed := False; end if; if not Processed then if Command_Line then Fail_Program (Project_Tree, "illegal option """ & Arg & """ on the command line", Exit_Code => E_General); else Success := False; end if; end if; end Scan_Arg; ---------------- -- Initialize -- ---------------- procedure Initialize is procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage); begin -- Do some necessary package initializations Snames.Initialize; Set_Program_Name ("gprbuild"); Set_Default_Verbosity; GPR.Tree.Initialize (Root_Environment, Gprbuild_Flags); GPR.Tree.Initialize (Project_Node_Tree); GPR.Initialize (Project_Tree); Mains.Delete; -- Get the name id for "-L"; Dash_L := Get_Name_Id ("-L"); -- Get the command line arguments, starting with --version and --help Check_Version_And_Help ("GPRBUILD", "2004"); -- Check for switch --dumpmachine and, if found, output the normalized -- hostname and exit. for Arg in 1 .. Argument_Count loop if Argument (Arg) = Dumpmachine then Knowledge.Parse_Knowledge_Base (Project_Tree); Put_Line (Knowledge.Normalized_Hostname); OS_Exit (0); end if; end loop; -- Check for switch -h an, if found, display usage and exit for Arg in 1 .. Argument_Count loop if Argument (Arg) = "-h" then Usage; OS_Exit (0); end if; end loop; -- By default, gprbuild should create artefact dirs if they are -- relative to the project directory Opt.Create_Dirs := Create_Relative_Dirs_Only; -- Now process the other options Autoconfiguration := True; Get_Command_Line_Arguments; declare Do_Not_Care : Boolean; begin for Next_Arg in 1 .. Last_Command_Line_Argument loop declare Arg : constant String := Command_Line_Argument (Next_Arg); begin if (Arg'Length >= Compiler_Subst_Option'Length and then Arg (1 .. Compiler_Subst_Option'Length) = Compiler_Subst_Option) or else (Arg'Length >= Compiler_Pkg_Subst_Option'Length and then Arg (1 .. Compiler_Pkg_Subst_Option'Length) = Compiler_Pkg_Subst_Option) then Subst_Switch_Present := True; end if; end; end loop; Scan_Args : for Next_Arg in 1 .. Last_Command_Line_Argument loop Scan_Arg (Command_Line_Argument (Next_Arg), Command_Line => True, Language => No_Name, Success => Do_Not_Care); end loop Scan_Args; end; if Debug.Debug_Flag_N then Opt.Keep_Temporary_Files := True; end if; if CodePeer_Mode then if Languages_Are_Restricted then Remove_All_Restricted_Languages; end if; Add_Restricted_Language ("ada"); Opt.Link_Only := False; if not Opt.Compile_Only and not Opt.Bind_Only then Opt.Compile_Only := True; Opt.Bind_Only := True; end if; elsif Languages_Are_Restricted then Opt.Compile_Only := True; Opt.Bind_Only := False; Opt.Link_Only := False; end if; Mains.Set_Multi_Unit_Index (Project_Tree, Main_Index); Current_Processor := None; GPR.Env.Initialize_Default_Project_Path (Root_Environment.Project_Path, Target_Name => "-"); -- If --display-paths was specified, display the config and the user -- project paths and exit. if Display_Paths then Put ('.'); declare Prefix_Path : constant String := Executable_Prefix_Path; begin if Prefix_Path'Length /= 0 then Put (Path_Separator); Put (Prefix_Path); Put ("share"); Put (Directory_Separator); Put ("gpr"); end if; New_Line; Put_Line (Env.Get_Path (Root_Environment.Project_Path)); Exit_Program (E_Success); end; end if; if Opt.Verbosity_Level > Opt.Low then Copyright; end if; -- Fail if command line ended with "-P" if Project_File_Name_Expected then Fail_Program (Project_Tree, "project file name missing after -P", Exit_Code => E_General); -- Or if it ended with "-o" elsif Output_File_Name_Expected then Fail_Program (Project_Tree, "output file name missing after -o", Exit_Code => E_General); -- Or if it ended with "-aP" elsif Search_Project_Dir_Expected then Fail_Program (Project_Tree, "directory name missing after -aP", Exit_Code => E_General); elsif Db_Directory_Expected then Fail_Program (Project_Tree, "directory name missing after --db", Exit_Code => E_General); elsif Slave_Env /= null and then not Distributed_Mode then Fail_Program (Project_Tree, "cannot use --slave-env in non distributed mode"); end if; if Load_Standard_Base then -- We need to parse the knowledge base so that we are able to -- normalize the target names. Unfortunately, if we have to spawn -- gprconfig, it will also have to parse that knowledge base on -- its own. Knowledge.Parse_Knowledge_Base (Project_Tree); end if; -- If no project file is specified, look for a default if Project_File_Name = null then Look_For_Default_Project; else No_Project_File_Found := False; end if; if Project_File_Name = null then Try_Help; Fail_Program (Project_Tree, "no project file specified and no default project file"); end if; -- Check consistency of out-of-tree build options. if Root_Dir /= null and then Build_Tree_Dir = null then Fail_Program (Project_Tree, "cannot use --root-dir without --relocate-build-tree option", Exit_Code => E_General); end if; begin if Opt.Autodetect_Jobserver then GPR.Jobserver.Initialize; end if; exception when GPR.Jobserver.JS_Makeflags_Parsing_Detects_Dry_Run => Finish_Program (Project_Tree, Exit_Code); end; end Initialize; ----------- -- Usage -- ----------- procedure Usage is begin if not Usage_Output then Usage_Output := True; Put ("Usage: "); Put ("gprbuild [-P] [.gpr] [opts] [name]"); New_Line; Put (" {[-cargs opts] [-cargs:lang opts] [-largs opts]" & " [-kargs opts] [-gargs opts]}"); New_Line; New_Line; Put (" name is zero or more file names"); New_Line; New_Line; -- GPRBUILD switches Put ("gprbuild switches:"); New_Line; Display_Usage_Version_And_Help; -- Line for --no-project Put_Line (" --no-project"); Put_Line (" Do not use project file"); -- Line for --distributed Put (" --distributed=slave1[,slave2]"); New_Line; Put (" Activate the remote/distributed compilations"); New_Line; -- Line for --hash Put (" --hash=string"); New_Line; Put (" Set an hash string to identified environment"); New_Line; -- Line for --slave-env Put (" --slave-env[=name]"); New_Line; Put (" Use a specific slave's environment"); New_Line; New_Line; -- Line for --complete-output Put (" --complete-output"); New_Line; Put (" Display all previous errors and warnings"); New_Line; -- Line for --no-complete-output Put (" --no-complete-output, -n"); New_Line; Put (" Do not store compilation outputs in files"); New_Line; New_Line; -- Line for Config_Project_Option Put (" "); Put (Config_Project_Option); Put ("file.cgpr"); New_Line; Put (" Specify the main config project file name"); New_Line; -- Line for Autoconf_Project_Option Put (" "); Put (Autoconf_Project_Option); Put ("file.cgpr"); New_Line; Put (" Specify/create the main config project file name"); New_Line; -- Line for Target_Project_Option Put (" "); Put (Target_Project_Option); Put ("targetname"); New_Line; Put (" Specify a target for cross platforms"); New_Line; -- Line for --db Put (" --db dir Parse dir as an additional knowledge base"); New_Line; -- Line for --db- Put (" --db- Do not load the standard knowledge base"); New_Line; Put (" --implicit-with=filename"); New_Line; Put (" Add the given projects as a dependency on all loaded" & " projects"); New_Line; -- Line for --relocate-build-tree= Put (" --relocate-build-tree[=dir]"); New_Line; Put (" Root obj/lib/exec dirs are current-directory" & " or dir"); New_Line; -- Line for --root-dir= Put (" --root-dir=dir"); New_Line; Put (" Root directory of obj/lib/exec to relocate"); New_Line; -- Line for --src-subdirs= Put (" --src-subdirs=dir"); New_Line; Put (" Prepend /dir to the list of source dirs" & " for each project"); New_Line; -- Line for --subdirs= Put (" --subdirs=dir"); New_Line; Put (" Use dir as suffix to obj/lib/exec directories"); New_Line; if Is_Unix then Put_Line (" --getrusage=file"); Put_Line (" Print getrusage call results into file"); end if; -- Line for --single-compile-per-obj-dir Put (" "); Put (Single_Compile_Per_Obj_Dir_Switch); New_Line; Put (" No simultaneous compilations for the same obj dir"); New_Line; -- Line for --build-script= Put (" "); Put (Build_Script_Option); Put_Line ("script_file"); Put (" Create build script script_file"); New_Line; Put (" "); Put (No_Indirect_Imports_Switch); New_Line; Put (" Sources can import only from directly imported " & "projects"); New_Line; Put (" "); Put (Indirect_Imports_Switch); New_Line; Put (" Sources can import from directly and indirectly " & "imported projects"); New_Line; Put (" --RTS="); New_Line; Put (" Use runtime for language Ada"); New_Line; Put (" --RTS:="); New_Line; Put (" Use runtime for language "); New_Line; Put (" "); Put (Gpr_Build_Util.Unchecked_Shared_Lib_Imports); New_Line; Put (" Shared lib projects may import any project"); New_Line; Put (" "); Put (No_Object_Check_Switch); New_Line; Put (" Do not check object files"); New_Line; Put (" --no-sal-binding"); New_Line; Put (" Reuse binder files when linking SALs"); New_Line; Put (" "); Put (Restricted_To_Languages_Option); Put (""); New_Line; Put (" Restrict the languages of the sources"); New_Line; New_Line; Put (" "); Put (Create_Map_File_Switch); New_Line; Put (" Create map file mainprog.map"); New_Line; Put (" "); Put (Create_Map_File_Switch); Put ("=mapfile"); New_Line; Put (" Create map file mapfile"); New_Line; Put (" "); Put (Source_Info_Option & ""); New_Line; Put (" Specify/create the project sources cache file"); New_Line; Put (" "); Put (Keep_Temp_Files_Option); New_Line; Put (" Do not delete temporary files"); New_Line; New_Line; Put (" "); Put (Autodetect_Jobserver_Option); New_Line; Put (" Autodetect GNU make jobserver and attempt to share" & " job slots"); New_Line; New_Line; -- Line for -aP Put (" -aP dir Add directory dir to project search path"); New_Line; -- Line for -b Put (" -b Bind only"); New_Line; -- Line for -c Put (" -c Compile only"); New_Line; -- Line for -d Put (" -d Display compilation progress"); New_Line; -- Line for -eInn Put (" -eInn Index of main unit in multi-unit source file"); New_Line; -- Line for -eL Put (" -eL " & "Follow symbolic links when processing project files"); New_Line; -- Line for -eS Put (" -eS " & "(no action, for compatibility with gnatmake only)"); New_Line; -- Line for -f Put (" -f Force recompilations"); New_Line; -- Line for -F Put (" -F Full project path name in brief error messages"); New_Line; -- Line for -jnnn Put (" -j Use processes to compile, bind, and link"); New_Line; Put (" -jc Use processes to compile"); New_Line; Put (" -jb Use processes to bind"); New_Line; Put (" -jl Use processes to link"); New_Line; -- Line for -k Put (" -k Keep going after compilation errors"); New_Line; -- Line for -l Put (" -l Link only"); New_Line; -- Line for -m Put (" -m Minimum Ada recompilation"); New_Line; -- Line for -m2 Put (" -m2 Checksum based Ada recompilation"); New_Line; -- Line for -o Put (" -o name Choose an alternate executable name"); New_Line; -- Line for -p Put (" -p Create missing obj, lib and exec dirs"); New_Line; -- Line for -P Put (" -P proj Use Project File proj"); New_Line; -- Line for -q Put (" -q Be quiet/terse"); New_Line; -- Line for -r Put (" -r Recursive (default except when using -c)"); New_Line; -- Line for -R Put (" -R Do not use run path option"); New_Line; -- Line for -s Put (" -s Recompile if compiler switches have changed"); New_Line; -- Line for -u Put (" -u Unique compilation, only compile the given files"); New_Line; -- Line for -U Put (" -U Unique compilation for all sources of all projects"); New_Line; -- Line for -v Put (" -v Verbose output"); New_Line; -- Line for -vl Put (" -vl Verbose output (low verbosity)"); New_Line; -- Line for -vm Put (" -vm Verbose output (medium verbosity)"); New_Line; -- Line for -vh Put (" -vh Verbose output (high verbosity)"); New_Line; -- Line for -vPx Put (" -vPx Specify verbosity when parsing Project Files" & " (x = 0/1/2)"); New_Line; -- Line for -we Put (" -we Treat all warnings as errors"); New_Line; -- Line for -wn Put (" -wn Treat warnings as warnings"); New_Line; -- Line for -ws Put (" -ws Suppress all gprbuild-specific warnings"); New_Line; -- Line for -x Put (" -x Always create include path file"); New_Line; -- Line for -X Put (" -Xnm=val Specify an external reference for " & "Project Files"); New_Line; New_Line; -- Line for -z Put (" -z No main subprogram (zero main)"); New_Line; -- Line for --compiler-subst Put_Line (" --compiler-subst=lang,tool Specify alternate " & "compiler"); -- Line for --compiler-pkg-subst Put_Line (" --compiler-pkg-subst=pkg Specify alternate " & "package"); New_Line; New_Line; -- Line for -cargs Put_Line (" -cargs opts opts are passed to all compilers"); -- Line for -cargs:lang Put_Line (" -cargs: opts"); Put_Line (" opts are passed to the compiler " & "for language "); -- Line for -bargs Put_Line (" -bargs opts opts are passed to all binders"); -- Line for -cargs:lang Put_Line (" -bargs: opts"); Put_Line (" opts are passed to the binder " & "for language "); -- Line for -largs Put (" -largs opts opts are passed to the linker"); New_Line; -- Line for -kargs Put (" -kargs opts opts are passed to gprconfig"); New_Line; -- Line for -gargs Put (" -gargs opts opts directly interpreted by gprbuild"); New_Line; -- Line for -margs Put (" -margs opts equivalent to -gargs opts"); New_Line; New_Line; Put ("For compatibility with gnatmake, these switches are passed " & "to the Ada compiler:"); New_Line; Put (" -nostdlib"); New_Line; Put (" -nostdinc"); New_Line; Put (" -fstack-check"); New_Line; Put (" -fno-inline"); New_Line; Put (" -gxxx"); New_Line; Put (" -Oxx"); New_Line; New_Line; end if; end Usage; User_Project_Node : Project_Node_Id; procedure Do_Compute_Builder_Switches is new Compute_Builder_Switches (Add_Global_Switches); begin -- First initialize and read the command line arguments Initialize; -- And install Ctrl-C handler Install_Int_Handler (Gprbuild.Sigint_Intercepted'Access); -- Add the external variable GPR_TOOL (default value "gprbuild") Add_Gpr_Tool_External; -- Check command line arguments. These will be overridden when looking -- for the configuration file if Target_Name = null then Target_Name := new String'(""); end if; if Config_Project_File_Name = null then Config_Project_File_Name := new String'(""); elsif Autoconf_Specified then -- Check if path needs to be created declare Config_Path : constant String := Ada.Directories.Containing_Directory (Config_Project_File_Name.all); begin if not Ada.Directories.Exists (Config_Path) then Ada.Directories.Create_Path (Config_Path); end if; end; end if; -- Then, parse the user's project and the configuration file. Apply the -- configuration file to the project so that its settings are -- automatically inherited by the project. -- If either the project or the configuration file contains errors, the -- following call with call Fail_Program and never return begin Main_Project := No_Project; Parse_Project_And_Apply_Config (Main_Project => Main_Project, User_Project_Node => User_Project_Node, Config_File_Name => Config_Project_File_Name.all, Autoconf_Specified => Autoconf_Specified, Project_File_Name => Project_File_Name.all, Project_Tree => Project_Tree, Env => Root_Environment, Project_Node_Tree => Project_Node_Tree, Packages_To_Check => Packages_To_Check, Allow_Automatic_Generation => Autoconfiguration, Automatically_Generated => Delete_Autoconf_File, Config_File_Path => Configuration_Project_Path, Target_Name => Target_Name.all, Normalized_Hostname => Knowledge.Normalized_Hostname, Implicit_Project => No_Project_File_Found, Gprconfig_Options => Command_Line_Gprconfig_Options); exception when E : GPR.Conf.Invalid_Config => Fail_Program (Project_Tree, Exception_Message (E), Exit_Code => E_Project); end; if Main_Project = No_Project then -- Don't flush messages in case of parsing error. This has already -- been taken care when parsing the tree. Otherwise, it results in -- the same message being displayed twice. Fail_Program (Project_Tree, """" & Project_File_Name.all & """ processing failed", Flush_Messages => Present (User_Project_Node), Exit_Code => E_Project); end if; if Configuration_Project_Path /= null then Free (Config_Project_File_Name); Config_Project_File_Name := new String' (Base_Name (Configuration_Project_Path.all)); end if; if Total_Errors_Detected > 0 then GPR.Err.Finalize; Fail_Program (Project_Tree, "problems while getting the configuration", Flush_Messages => False); end if; -- Warn if there have been binder option specified on the command line -- and the main project is a Stand-Alone Library project. declare Options_Instance : constant Bind_Option_Table_Ref := Binder_Options_HTable.Get (Name_Ada); begin if not All_Language_Binder_Options.Is_Empty or else (Options_Instance /= No_Bind_Option_Table and then not Options_Instance.Is_Empty) then if Main_Project.Standalone_Library /= No then GPR.Err.Error_Msg ("?binding options on the command line are not taken " & "into account when the main project is a Stand-Alone " & "Library project", Main_Project.Location); end if; end if; end; Main_Project_Dir := new String'(Get_Name_String (Main_Project.Directory.Display_Name)); if Warnings_Detected > 0 then GPR.Err.Finalize; GPR.Err.Initialize; end if; -- Adjust switches for C and jvm targets: never perform the link phase declare No_Link : Boolean := False; Variable : Variable_Value; begin if No_Link_Target (Target_Name.all) then No_Link := True; else Variable := GPR.Util.Value_Of (Name_Target, Main_Project.Decl.Attributes, Project_Tree.Shared); if Variable /= Nil_Variable_Value and then No_Link_Target (Get_Name_String (Variable.Value)) then No_Link := True; -- Set Target_Name so that e.g. gprbuild-post_compile.adb knows -- that we have Target = c/ccg/jvm. Free (Target_Name); Target_Name := new String'(Get_Name_String (Variable.Value)); end if; end if; if No_Link then Opt.Link_Only := False; if not Opt.Compile_Only and not Opt.Bind_Only then Opt.Compile_Only := True; Opt.Bind_Only := True; end if; end if; end; Compute_All_Imported_Projects (Main_Project, Project_Tree); if Main_Project.Qualifier = Aggregate_Library then if Main_On_Command_Line then if (not Opt.Compile_Only or else Opt.Bind_Only) and then not Unique_Compile then Fail_Program (Project_Tree, "cannot specify a main program " & "on the command line for a library project file", Exit_Code => E_General); else Mains.Complete_Mains (Root_Environment.Flags, Main_Project, Project_Tree, Unique_Compile); end if; end if; else if Mains.Number_Of_Mains (Project_Tree) = 0 and then not Unique_Compile then -- Register the Main units from the projects. -- No need to waste time when we are going to compile all files -- anyway (Unique_Compile). Mains.Fill_From_Project (Main_Project, Project_Tree); end if; Mains.Complete_Mains (Root_Environment.Flags, Main_Project, Project_Tree, Unique_Compile); if not Unique_Compile and then Output_File_Name /= null and then Mains.Number_Of_Mains (null) > 1 then Fail_Program (Project_Tree, "cannot specify -o when there are several mains", Exit_Code => E_General); end if; end if; Do_Compute_Builder_Switches (Project_Tree => Project_Tree, Env => Root_Environment, Main_Project => Main_Project); Queue.Initialize (Opt.One_Compilation_Per_Obj_Dir); Compute_Compilation_Phases (Project_Tree, Main_Project, Option_Unique_Compile => Unique_Compile, Option_Compile_Only => Opt.Compile_Only, Option_Bind_Only => Opt.Bind_Only, Option_Link_Only => Opt.Link_Only); if Mains.Number_Of_Mains (Project_Tree) > 0 and then Main_Project.Library and then Builder_Data (Project_Tree).Need_Binding then Fail_Program (Project_Tree, "cannot specify a main program " & "on the command line for a library project file", Exit_Code => E_General); end if; Add_Mains_To_Queue; -- If no sources to compile, then there is nothing to do if Queue.Size = 0 then if not Opt.Quiet_Output and then not Main_Project.Externally_Built then Write_Program_Name; Write_Line ("no sources to compile"); end if; Finish_Program (Project_Tree, E_Success); end if; Always_Compile := Always_Compile and then Opt.Force_Compilations and then Unique_Compile and then not Unique_Compile_All_Projects; -- Reprocess recorded command line options that have priority over -- those in the main project file. Options.Process_Command_Line_Options; Check_Maximum_Processes; -- If a build script is declared, try to create the file. Fail if the file -- cannot be created. if Build_Script_Name /= null then begin Create (Build_Script_File, Out_File, Build_Script_Name.all); exception when others => Fail_Program (null, "build script """ & Build_Script_Name.all & """ could not be created"); end; end if; if Debug.Debug_Flag_M then Put_Line ("Maximum number of simultaneous compilations =" & Opt.Maximum_Compilers'Img); end if; -- Warn if --create-map-file is not supported if Map_File /= null and then Main_Project.Config.Map_File_Option = No_Name then Put ("warning: option "); Put (Create_Map_File_Switch); Put (" is not supported in this configuration"); New_Line; end if; -- Set slave-env if Distributed_Mode then if Slave_Env = null then Slave_Env := new String'(Aux.Compute_Slave_Env (Project_Tree, Slave_Env_Auto)); if Slave_Env_Auto and not Opt.Quiet_Output then Put ("slave environment is "); Put (Slave_Env.all); New_Line; end if; end if; end if; Compile.Run; -- If the build script file is opened, close it, so that it can be reopened -- by gprlib and gprbind. if Is_Open (Build_Script_File) then Close (Build_Script_File); Opt.Maximum_Binders := 1; Opt.Maximum_Linkers := 1; end if; Post_Compile.Run; Link.Run; if Warnings_Detected /= 0 then GPR.Err.Finalize; end if; if Getrusage /= null then Put_Resource_Usage (Getrusage.all); end if; Finish_Program (Project_Tree, Exit_Code); exception when C : Constraint_Error => if Distributed_Mode then GPR.Compilation.Slave.Unregister_Remote_Slaves (From_Signal => True); end if; Fail_Program (Project_Tree, Exception_Information (C)); when Project_Error => Fail_Program (Project_Tree, '"' & Project_File_Name.all & """ processing failed"); when A : Assertion_Error => if GPR.Util.Has_Incomplete_Withs (Flags => Root_Environment.Flags) then GPR.Err.Error_Msg (Root_Environment.Flags, "error in project file", One_Line => True, Always => True); Fail_Program (Project_Tree, '"' & Project_File_Name.all & """ processing failed"); else Fail_Program (Project_Tree, Exception_Information (A)); end if; when E : GPR.Jobserver.JS_Initialize_Error | GPR.Jobserver.JS_Access_Error | GPR.Jobserver.JS_Process_Error => Fail_Program (Project_Tree, Exception_Message (E)); when E : others => Fail_Program (Project_Tree, Exception_Information (E)); end Gprbuild.Main; gprbuild-25.0.0/src/gprbuild-post_compile.adb000066400000000000000000005521351470075373400211750ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2011-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ with Ada.Calendar; with Ada.Containers.Hashed_Maps; with Ada.Containers.Ordered_Sets; with Ada.Directories; with Ada.Strings.Fixed; with Ada.Text_IO; use Ada, Ada.Text_IO; with GNAT.Case_Util; use GNAT.Case_Util; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.Dynamic_HTables; with GNAT.MD5; use GNAT.MD5; with GNAT.OS_Lib; use GNAT.OS_Lib; with Gpr_Build_Util; use Gpr_Build_Util; with Gprexch; use Gprexch; with GPR.Env; with GPR.Err; use GPR.Err; with GPR.Names; use GPR.Names; with GPR.Opt; with GPR.Script; use GPR.Script; with GPR.Snames; use GPR.Snames; with GPR.Tempdir; with GPR.Util; use GPR.Util; package body Gprbuild.Post_Compile is type Lang_Names is array (Positive range <>) of Language_Ptr; type Lang_Names_Ptr is access Lang_Names; Langs : Lang_Names_Ptr := new Lang_Names (1 .. 4); Last_Lang : Natural := 0; Libs_Are_Building : Name_Id_Set.Set; -- Libraries currently being built package FNHS is new GNAT.Dynamic_HTables.Simple_HTable (Header_Num => GPR.Header_Num, Element => Boolean, No_Element => False, Key => File_Name_Type, Hash => GPR.Hash, Equal => "="); procedure Build_Library (For_Project : Project_Id; Project_Tree : Project_Tree_Ref; No_Create : Boolean); -- Build, if necessary, the library of a library project. If No_Create -- is True then the actual static or shared library is not built, yet -- the exchange file with dependencies is created. procedure Emit_Compiler_Switches (Exchange_File : Text_IO.File_Type; Index : Name_List_Index); -- Helper subprogram to emit and filter compiler switches given by -- Index, one per line in the givenfile Exchange_File. procedure Post_Compilation_Phase (Main_Project : Project_Id; Project_Tree : Project_Tree_Ref); function Is_Included_In_Global_Archive (Object_Name : File_Name_Type; Project : Project_Id) return Boolean; -- Return True if the object Object_Name is not overridden by a source -- in a project extending project Project. procedure Wait_For_Slots_Less_Than (Count : Positive); -- Wait for the number of available process slots less then Count type Library_Object is record Path : Path_Name_Type; TS : Time_Stamp_Type; Known : Boolean; end record; function "<" (Left, Right : Library_Object) return Boolean is (Get_Name_String (Left.Path) < Get_Name_String (Right.Path)); -- Operator uses for the ordered set Library_Objs in procedure -- Build_Library. Left < Right if Left path as a string is before -- Right path in alphabetical order. -- Dependency Files type Dep_Name; type Dep_Ptr is access Dep_Name; type Dep_Name is record Name : String_Access; Next : Dep_Ptr; end record; First_Dep : Dep_Ptr; -- Head of the list of dependency file path names procedure Add_Dep (Name : String); -- Insert a dependency file path name in the list starting at First_Dep, -- at the right place so that the list is sorted. ---------------- -- Add_Dep -- ---------------- procedure Add_Dep (Name : String) is Next : Dep_Ptr := First_Dep; begin if Next = null or else Name < Next.Name.all then First_Dep := new Dep_Name'(new String'(Name), Next); else while Next.Next /= null and then Name > Next.Next.Name.all loop Next := Next.Next; end loop; Next.Next := new Dep_Name'(new String'(Name), Next.Next); end if; end Add_Dep; ------------------- -- Build_Library -- ------------------- procedure Build_Library (For_Project : Project_Id; Project_Tree : Project_Tree_Ref; No_Create : Boolean) is package Objects is new Containers.Ordered_Sets (Library_Object); Library_Objs : Objects.Set; -- Objects that are in the library file with their time stamps, ordered -- by increasing path names. Library_SAL_Projs : Project_Vectors.Vector; -- List of non extended projects that are part of a Stand-Alone -- (aggregate) library project. Library_Sources : Source_Vectors.Vector; -- Library Ada sources of Stand-Alone library, that is sources of the -- project in the closure of the interface. Complete_Interface_ALIs : FNHS.Instance; -- The ALI files in the complete interface set Expected_File_Name : String_Access; -- Expected library file name Mapping_Path : Path_Name_Type := No_Path; -- The path name of an eventual binder mapping file Mapping_FD : File_Descriptor := Invalid_FD; -- A File Descriptor for an eventual binder mapping file Library_Options_Success : Boolean := False; package Lang_Set renames GPR.Name_Id_Set; procedure Get_Objects; -- Get the paths of the object files of the library in ordered set -- Library_Objs. procedure Write_List (Label : Library_Section; List : String_List_Id); -- Write values in list into section Label in the given file. Ouptut -- Label is written first if it is not the current section. procedure Write_Name_List (Label : Library_Section; List : Name_List_Index); -- Write name list values into the Exchange_File, output Label first. -- Output Label is written first if it is not the current section. procedure Write_Name (Label : Library_Section; Name : Name_Id); -- Write name with label if Name /= No_Name procedure Write_Filename (Label : Library_Section; Filename : File_Name_Type); -- Write Filename with label if Filename /= No_File procedure Check_Section (Section : Library_Section); -- Check that current exchange file output section is Section and set it -- if not. -- Procedures to write specific sections of the exchange file procedure Write_Object_Files; procedure Write_Object_Directory; procedure Write_Compilers; procedure Write_Compiler_Leading_Switches; procedure Write_Compiler_Trailing_Switches; procedure Write_Partial_Linker; procedure Write_Shared_Lib_Minimum_Options; procedure Write_Library_Version; procedure Write_Runtime_Library_Dir; procedure Write_Auto_Init; procedure Write_Binding_Options; procedure Write_Run_Path_Option; procedure Write_Leading_Library_Options; procedure Write_Library_Options (Success : out Boolean); procedure Write_Library_Rpath_Options; procedure Write_Imported_Libraries; procedure Write_Dependency_Files; procedure Write_Toolchain_Version; procedure Write_Interface_Dep_Files; procedure Write_Other_Interfaces; procedure Write_Interface_Obj_Files; procedure Write_Sources; procedure Write_Response_Files; procedure Write_Mapping_File; procedure Wait_For_Dependency (P : Project_Id); -- Wait for dependent library project P build completed function In_Library_SAL_Projs (Src : Source_Id) return Boolean is (Library_SAL_Projs.Contains (Ultimate_Extending_Project_Of (Src.Project))); -- Returns True of Src.Project founder is in the Library_SAL_Projs Project_Name : constant String := Get_Name_String (For_Project.Name); Current_Dir : constant String := Get_Current_Dir; Exchange_File : Text_IO.File_Type; Exchange_File_Name : String_Access; Latest_Object_TS : Time_Stamp_Type := Empty_Time_Stamp; Library_Builder_Name : String_Access; Library_Builder : String_Access; Library_Needs_To_Be_Built : Boolean := False; Dependencies_Ready : Boolean := False; Object_Path : Path_Name_Type; Object_TS : Time_Stamp_Type; Source : Source_Id; Project : Project_Id; Disregard : Boolean; Path_Found : Boolean; Iter : Source_Iterator; Current_Section : Library_Section := No_Library_Section; ------------------- -- Check_Section -- ------------------- procedure Check_Section (Section : Library_Section) is begin if Current_Section /= Section then Current_Section := Section; Put_Line (Exchange_File, Library_Label (Section)); end if; end Check_Section; ----------------- -- Get_Objects -- ----------------- procedure Get_Objects is Library_ALIs : FNHS.Instance; -- The ALI files of the Stand-Alone Library project Processed_ALIs : FNHS.Instance; -- The ALI files that have been processed to check if the -- corresponding library unit is in the interface set. Never : constant Time_Stamp_Type := (others => '9'); -- A time stamp that is greater than any real one procedure Check_Latest_Object_TS (Source : Source_Id); -- Check if source object timestamp later than in Latest_Object_TS -- and update it if this is the case. If object is absent, set the -- Latest_Object_TS to Never and set Library_Needs_To_Be_Built to -- True. procedure Check_Interface (Proj : Project_Id; Tree : Project_Tree_Ref); -- Check if the interface of SAL project Proj is complete procedure Find_ALI_Path (The_ALI : File_Name_Type; ALI_Path : in out Path_Name_Type; Proj : Project_Id; Tree : Project_Tree_Ref); -- Find the path of the ALI file The_ALI. It may be in project -- Proj, or if Proj is an aggregate library in one of its aggregated -- projects. procedure Get_Roots (Source : Source_Id); -- Get Roots of the SAL Source into object or ALI containers procedure Process (Proj : Project_Id; Tree : Project_Tree_Ref); -- Get objects for non Stand-Alone library procedure Process_ALI (The_ALI : File_Name_Type; Proj : Project_Id; Tree : Project_Tree_Ref); -- Check if the closure of a library unit which is or should be in -- the interface set is also in the interface set. Issue a warning -- for each missing library unit. procedure Process_Standalone (Proj : Project_Id; Tree : Project_Tree_Ref); -- Get objects for a Stand-Alone Library procedure Get_Closure; -- For Stand-Alone libraries, get the closure of the Ada interface -- and put the object files in Library_Objs. ---------------------------- -- Check_Latest_Object_TS -- ---------------------------- procedure Check_Latest_Object_TS (Source : Source_Id) is begin if Source.Object_TS = Empty_Time_Stamp then Latest_Object_TS := Never; if not Library_Needs_To_Be_Built then Library_Needs_To_Be_Built := True; if Opt.Verbosity_Level > Opt.Low then Put (" -> missing object file: "); Put_Line (Get_Name_String (Source.Object)); end if; end if; elsif Source.Object_TS > Latest_Object_TS then Latest_Object_TS := Source.Object_TS; end if; end Check_Latest_Object_TS; ------------- -- Process -- ------------- procedure Process (Proj : Project_Id; Tree : Project_Tree_Ref) is pragma Unreferenced (Tree); Source : Source_Id; Iter : Source_Iterator; begin Iter := For_Each_Source (Project_Tree, Proj); loop Source := GPR.Element (Iter); exit when Source = No_Source; -- Always get the time stamps when the main project is an -- aggregate project. Initialize_Source_Record (Source, Always => Main_Project.Qualifier = Aggregate); if Is_Compilable (Source) and then Source.Replaced_By = No_Source and then Source.Language.Config.Objects_Linked and then ((Source.Unit = No_Unit_Index and then Source.Kind = Impl) or else (Source.Unit /= No_Unit_Index and then (Source.Kind = Impl or else Other_Part (Source) = No_Source) and then not Is_Subunit (Source))) and then (not Source.Project.Externally_Built or else not For_Project.Externally_Built or else Source.Project.Extended_By /= No_Project) then Library_Objs.Insert ((Path => Source.Object_Path, TS => Source.Object_TS, Known => False)); Check_Latest_Object_TS (Source); end if; Next (Iter); end loop; end Process; ------------------- -- Find_ALI_Path -- ------------------- procedure Find_ALI_Path (The_ALI : File_Name_Type; ALI_Path : in out Path_Name_Type; Proj : Project_Id; Tree : Project_Tree_Ref) is Source : Source_Id; Iter : Source_Iterator; Aggr_Projs : Aggregated_Project_List; Prj : Project_Id := Proj; begin while Prj /= No_Project loop Iter := For_Each_Source (Tree, Prj); loop Source := GPR.Element (Iter); exit when Source = No_Source; Initialize_Source_Record (Source); if Source.Dep_Name = The_ALI then ALI_Path := Source.Dep_Path; return; end if; Next (Iter); end loop; Prj := Prj.Extends; end loop; if Proj.Qualifier = Aggregate_Library then Aggr_Projs := Proj.Aggregated_Projects; while Aggr_Projs /= null loop -- We are passing the root Tree as in Aggregate_Library all -- Tree.Projects are stored in the Aggregate_Library.Tree -- and not in Aggr_Projs.Tree Find_ALI_Path (The_ALI, ALI_Path, Aggr_Projs.Project, Tree); exit when ALI_Path /= No_Path; Aggr_Projs := Aggr_Projs.Next; end loop; end if; end Find_ALI_Path; ----------------- -- Process_ALI -- ----------------- Interface_Incomplete : Boolean := False; procedure Process_ALI (The_ALI : File_Name_Type; Proj : Project_Id; Tree : Project_Tree_Ref) is use ALI; Text : Text_Buffer_Ptr; Idread : ALI_Id; First_Unit : Unit_Id; Last_Unit : ALI.Unit_Id; Unit_Data : ALI.Unit_Record; Afile : File_Name_Type; ALI_Path : Path_Name_Type; begin -- Nothing to do if the ALI file has already been processed. -- This happens if an interface imports another interface. if not FNHS.Get (Processed_ALIs, The_ALI) then FNHS.Set (Processed_ALIs, The_ALI, True); ALI_Path := No_Path; Find_ALI_Path (The_ALI, ALI_Path, Proj, Tree); if ALI_Path /= No_Path then Text := Read_Library_Info (File_Name_Type (ALI_Path)); end if; if Text /= null then Idread := Scan_ALI (F => The_ALI, T => Text, Ignore_ED => False, Err => True, Read_Lines => "W"); Free (Text); if Idread /= No_ALI_Id then First_Unit := ALI.ALIs.Table (Idread).First_Unit; Last_Unit := ALI.ALIs.Table (Idread).Last_Unit; -- Process both unit (spec and body) if the body is -- needed by the spec (inline or generic). Otherwise, -- just process the spec. if First_Unit /= Last_Unit and then not ALI.Units.Table (Last_Unit).Body_Needed_For_SAL then First_Unit := Last_Unit; end if; for Unit in First_Unit .. Last_Unit loop Unit_Data := ALI.Units.Table (Unit); -- Check if each withed unit which is in the library -- is also in the interface set, if it has not yet -- been processed. for W in Unit_Data.First_With .. Unit_Data.Last_With loop Afile := Withs.Table (W).Afile; if Afile /= No_File and then FNHS.Get (Library_ALIs, Afile) and then not FNHS.Get (Processed_ALIs, Afile) then if not FNHS.Get (Complete_Interface_ALIs, Afile) then if not Interface_Incomplete then Put ("Warning: In library project """); Get_Name_String (Proj.Name); To_Mixed (Name_Buffer (1 .. Name_Len)); Put (Name_Buffer (1 .. Name_Len)); Put_Line (""""); Interface_Incomplete := True; end if; Put (" Unit """); Get_Name_String (Withs.Table (W).Uname); To_Mixed (Name_Buffer (1 .. Name_Len - 2)); Put (Name_Buffer (1 .. Name_Len - 2)); Put_Line (""" is not in the interface set"); Put (" but it is needed by "); case Unit_Data.Utype is when Is_Spec => Put ("the spec of "); when Is_Body => Put ("the body of "); when others => null; end case; Put ('"'); Get_Name_String (Unit_Data.Uname); To_Mixed (Name_Buffer (1 .. Name_Len - 2)); Put (Name_Buffer (1 .. Name_Len - 2)); Put_Line (""""); FNHS.Set (Complete_Interface_ALIs, Afile, True); end if; -- Now, process this unit Process_ALI (Afile, Proj, Tree); end if; end loop; end loop; end if; end if; end if; end Process_ALI; ------------------------ -- Process_Standalone -- ------------------------ procedure Process_Standalone (Proj : Project_Id; Tree : Project_Tree_Ref) is pragma Unreferenced (Tree); Source : Source_Id; Iter : Source_Iterator; List : String_List_Id; Elem : String_Element; OK : Boolean; begin if Proj.Qualifier /= Aggregate_Library and then Proj.Extended_By = No_Project then Library_SAL_Projs.Append (Proj); end if; Iter := For_Each_Source (Project_Tree, Proj); loop Source := GPR.Element (Iter); exit when Source = No_Source; -- Always get the time stamps when the main project is an -- aggregate project. Initialize_Source_Record (Source, Main_Project.Qualifier = Aggregate); if Is_Compilable (Source) and then Source.Replaced_By = No_Source and then Source.Language.Config.Objects_Linked and then ((Source.Unit = No_Unit_Index and then Source.Kind = Impl) or else (Source.Unit /= No_Unit_Index and then (Source.Kind = Impl or else Other_Part (Source) = No_Source) and then not Is_Subunit (Source))) and then (not Source.Project.Externally_Built or else not For_Project.Externally_Built or else Source.Project.Extended_By /= No_Project) then if Source.Unit = No_Unit_Index then OK := True; Library_Objs.Insert ((Path => Source.Object_Path, TS => Source.Object_TS, Known => False)); Get_Roots (Source); else FNHS.Set (Library_ALIs, Source.Dep_Name, True); -- Check if it is an interface and record if it is one OK := False; List := For_Project.Lib_Interface_ALIs; while List /= Nil_String loop Elem := Project_Tree.Shared.String_Elements.Table (List); -- Checking against Lib_Interface_ALIs will never -- succeed if Source is in a multi-unit file because -- Dep_Name will be in the format ~.ali -- whereas the corresponding Elem will be .ali. -- ??? Fix the computation of Lib_Interface_ALIs ??? -- As a quick fix we compare . declare use Ada.Strings.Fixed; Dep_Str : constant String := Get_Name_String (Source.Dep_Name); Elem_Str : constant String := Get_Name_String (Elem.Value); Dep_Multi_Index : constant Natural := Index (Dep_Str, "~"); Elem_Dot_Index : constant Natural := Index (Elem_Str, "."); begin if Elem.Value = Name_Id (Source.Dep_Name) or else (Source.Index /= 0 and then Dep_Multi_Index = Elem_Dot_Index and then Head (Dep_Str, Dep_Multi_Index - 1) = Head (Elem_Str, Elem_Dot_Index - 1)) then OK := True; Library_Sources.Append (Source); FNHS.Set (Complete_Interface_ALIs, Source.Dep_Name, True); exit; end if; end; List := Elem.Next; end loop; end if; if OK then Check_Latest_Object_TS (Source); end if; end if; Next (Iter); end loop; end Process_Standalone; --------------------- -- Check_Interface -- --------------------- procedure Check_Interface (Proj : Project_Id; Tree : Project_Tree_Ref) is Iface : String_List_Id := Proj.Lib_Interface_ALIs; begin while Iface /= Nil_String loop Process_ALI (File_Name_Type (Tree.Shared.String_Elements.Table (Iface).Value), Proj, Tree); Iface := Tree.Shared.String_Elements.Table (Iface).Next; end loop; end Check_Interface; ----------------- -- Get_Closure -- ----------------- procedure Get_Closure is Index : Natural := 0; The_ALI : ALI.ALI_Id; Text : Text_Buffer_Ptr; Dep_Path : Path_Name_Type; Dep_TS : aliased File_Attributes := Unknown_Attributes; Sfile : File_Name_Type; Afile : File_Name_Type; Src_Id : GPR.Source_Id; Source : Source_Id; procedure Add_To_Mapping (Source : Source_Id; From_Object_Dir : Boolean); -- Add data for Source in binder mapping file. Use the ALI file -- in the library ALI directory if From_Object_Dir is False and -- the project is a library project. Otherwise, use the ALI file -- in the object directory. -------------------- -- Add_To_Mapping -- -------------------- procedure Add_To_Mapping (Source : Source_Id; From_Object_Dir : Boolean) is Unit : Unit_Index; ALI_Unit : Unit_Name_Type := No_Unit_Name; -- The unit name of an ALI file ALI_Name : File_Name_Type := No_File; -- The file name of the ALI file ALI_Project : Project_Id := No_Project; -- The project of the ALI file begin if Source = No_Source then return; end if; Unit := Source.Unit; if Source.Replaced_By /= No_Source or else Unit = No_Unit_Index or else Unit.Name = No_Name then ALI_Name := No_File; -- If this is a body, put it in the mapping elsif Source.Kind = Impl and then Unit.File_Names (Impl) /= No_Source and then Unit.File_Names (Impl).Project /= No_Project then Get_Name_String (Unit.Name); Add_Str_To_Name_Buffer ("%b"); ALI_Unit := Name_Find; ALI_Name := Lib_File_Name (Unit.File_Names (Impl).Display_File); ALI_Project := Unit.File_Names (Impl).Project; -- Otherwise, if this is a spec and there is no body, put it in -- the mapping. elsif Source.Kind = Spec and then Unit.File_Names (Impl) = No_Source and then Unit.File_Names (Spec) /= No_Source and then Unit.File_Names (Spec).Project /= No_Project then Get_Name_String (Unit.Name); Add_Str_To_Name_Buffer ("%s"); ALI_Unit := Name_Find; ALI_Name := Lib_File_Name (Unit.File_Names (Spec).Display_File); ALI_Project := Unit.File_Names (Spec).Project; else ALI_Name := No_File; end if; -- If we have something to put in the mapping then do it now. -- If the project is extended, look for the ALI file in the -- project, then in the extending projects in order, and use -- the last one found. if ALI_Name /= No_File then -- Look in the project and the projects that are extending -- it to find the real ALI declare ALI : constant String := Get_Name_String (ALI_Name); ALI_Path : Name_Id := No_Name; procedure Write_Mapping (Id : Name_Id); -- Write name and line feed to Mapping_FD ---------------- -- Write_Name -- ---------------- procedure Write_Mapping (Id : Name_Id) is begin Get_Name_String (Id); Add_Char_To_Name_Buffer (ASCII.LF); if Write (Mapping_FD, Name_Buffer'Address, Name_Len) /= Name_Len then raise Program_Error with "Disk full"; end if; end Write_Mapping; begin loop -- For library projects, use the library ALI -- directory, for other projects, use the -- object directory. if ALI_Project.Library and then not From_Object_Dir then Get_Name_String (ALI_Project.Library_ALI_Dir.Display_Name); else Get_Name_String (ALI_Project.Object_Directory.Display_Name); end if; Add_Str_To_Name_Buffer (ALI); if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then ALI_Path := Name_Find; end if; ALI_Project := ALI_Project.Extended_By; exit when ALI_Project = No_Project; end loop; if ALI_Path /= No_Name then -- First line is the unit name Write_Mapping (Name_Id (ALI_Unit)); -- Second line is the ALI file name Write_Mapping (Name_Id (ALI_Name)); -- Third line is the ALI path name Write_Mapping (ALI_Path); end if; end; end if; end Add_To_Mapping; Closure_Sources : Source_Vectors.Vector := Library_Sources; -- Library Ada sources of Stand-Alone library, that is sources -- in the closure of the interface, including in imported -- projects. -- Start of processing for Get_Closure begin Over_Sources : while Index < Closure_Sources.Last_Index loop Index := Index + 1; Source := Closure_Sources (Index); Add_To_Mapping (Source, From_Object_Dir => Library_Sources.Contains (Source)); Dep_Path := Source.Dep_Path; Dep_TS := Source.Dep_TS; Text := Read_Library_Info_From_Full (File_Name_Type (Dep_Path), Dep_TS'Access); if Text /= null then The_ALI := ALI.Scan_ALI (File_Name_Type (Dep_Path), Text, Ignore_ED => False, Err => True, Read_Lines => "W"); Free (Text); -- Get the withed sources Over_Units : for J in ALI.ALIs.Table (The_ALI).First_Unit .. ALI.ALIs.Table (The_ALI).Last_Unit loop Over_Imports : for K in ALI.Units.Table (J).First_With .. ALI.Units.Table (J).Last_With loop Sfile := ALI.Withs.Table (K).Sfile; -- Skip generics if Sfile /= No_File then Afile := ALI.Withs.Table (K).Afile; Src_Id := Source_Files_Htable.Get (Project_Tree.Source_Files_HT, Sfile); while Src_Id /= No_Source loop Initialize_Source_Record (Src_Id); if Is_Compilable (Src_Id) and then Src_Id.Dep_Name = Afile then case Src_Id.Kind is when Spec => declare Bdy : constant GPR.Source_Id := Other_Part (Src_Id); begin if Bdy /= No_Source and then not Bdy.Locally_Removed then Src_Id := Bdy; end if; end; when Impl => if Is_Subunit (Src_Id) then Src_Id := No_Source; end if; when Sep => Src_Id := No_Source; end case; exit; end if; Src_Id := Src_Id.Next_With_File_Name; end loop; if Src_Id /= No_Source then if not Closure_Sources.Contains (Src_Id) then Closure_Sources.Append (Src_Id); end if; if In_Library_SAL_Projs (Src_Id) and then not Library_Sources.Contains (Src_Id) then Library_Sources.Append (Src_Id); Initialize_Source_Record (Src_Id); Check_Latest_Object_TS (Src_Id); end if; end if; end if; end loop Over_Imports; end loop Over_Units; end if; Get_Roots (Source); end loop Over_Sources; end Get_Closure; --------------- -- Get_Roots -- --------------- procedure Get_Roots (Source : Source_Id) is Root : Roots_Access := Source.Roots; Position : Objects.Cursor; Inserted : Boolean; begin while Root /= null loop Initialize_Source_Record (Root.Root); if Root.Root.Unit = No_Unit_Index then Library_Objs.Insert ((Path => Root.Root.Object_Path, TS => Root.Root.Object_TS, Known => False), Position, Inserted); Get_Roots (Root.Root); elsif In_Library_SAL_Projs (Root.Root) and then not Library_Sources.Contains (Root.Root) then Library_Sources.Append (Root.Root); Check_Latest_Object_TS (Root.Root); end if; Root := Root.Next; end loop; end Get_Roots; procedure Process_Non_Standalone_Aggregate_Library is new For_Project_And_Aggregated (Process); procedure Process_Standalone_Aggregate_Library is new For_Project_And_Aggregated (Process_Standalone); Proj : Project_Id := For_Project; -- Start of processing of Get_Objects begin Library_Objs.Clear; Library_Sources.Clear; Library_Projs.Clear; Library_SAL_Projs.Clear; FNHS.Reset (Processed_ALIs); FNHS.Reset (Library_ALIs); FNHS.Reset (Complete_Interface_ALIs); if For_Project.Qualifier = Aggregate_Library then if For_Project.Standalone_Library = No then Process_Non_Standalone_Aggregate_Library (For_Project, Project_Tree); else Process_Standalone_Aggregate_Library (For_Project, Project_Tree); end if; else while Proj /= No_Project loop if For_Project.Standalone_Library = No then Process (Proj, Project_Tree); else Process_Standalone (Proj, Project_Tree); end if; Proj := Proj.Extends; end loop; end if; if For_Project.Standalone_Library /= No then -- Check the interface Check_Interface (For_Project, Project_Tree); -- Create the binder maping file Tempdir.Create_Temp_File (Mapping_FD, Mapping_Path); Record_Temp_File (Project_Tree.Shared, Mapping_Path); Get_Closure; Close (Mapping_FD); -- Put all the object files in the closure in Library_Objs for Source of Library_Sources loop Library_Objs.Insert ((Path => Source.Object_Path, TS => Source.Object_TS, Known => False)); end loop; end if; end Get_Objects; ------------------------- -- Wait_For_Dependency -- ------------------------- procedure Wait_For_Dependency (P : Project_Id) is begin while Libs_Are_Building.Contains (P.Name) loop -- There may be some executable binding in parallel to the library -- build operations, i.e. Outstanding_Processes may be greater -- than the list of libs being built. pragma Assert (Natural (Libs_Are_Building.Length) <= Outstanding_Processes, "more libs building than outstanding processes " & Libs_Are_Building.Length'Img & Outstanding_Processes'Img & ' ' & Get_Name_String_Safe (P.Name)); -- Wait for any process to be done to check is the dependency -- resolved. Wait_For_Slots_Less_Than (Outstanding_Processes); end loop; end Wait_For_Dependency; ------------------------ -- Write_Object_Files -- ------------------------ procedure Write_Object_Files is begin if not Library_Objs.Is_Empty then Put_Line (Exchange_File, Library_Label (Object_Files)); for Item of Library_Objs loop Put_Line (Exchange_File, Get_Name_String (Item.Path)); end loop; end if; end Write_Object_Files; ---------------------------- -- Write_Object_Directory -- ---------------------------- procedure Write_Object_Directory is Object_Projects : Project_Vectors.Vector; Prj : Project_Id; Index : Natural; -- The projects that have already be found when looking for object -- directories. package PNHT renames Path_Name_HTable; Object_Directories : PNHT.Instance; -- The object directories that have already be found procedure Get_Object_Projects (Prj : Project_Id); -- Recursive procedure to collect the aggregated projects function Is_In_Object_Projects (Prj : Project_Id) return Boolean; -- Returns True iff Prj is in table Object_Projects function Is_In_Object_Directories (Dir : Path_Name_Type) return Boolean is (PNHT.Get (Object_Directories, Dir)); -- Returns True iff Dir is in table Object_Directories ------------------------- -- Get_Object_Projects -- ------------------------- procedure Get_Object_Projects (Prj : Project_Id) is begin if Prj.Qualifier = Aggregate_Library then declare List : Aggregated_Project_List := Prj.Aggregated_Projects; begin while List /= null loop Get_Object_Projects (List.Project); List := List.Next; end loop; end; else -- Add object directories of the project and of the projects it -- extends, if any. declare Proj : Project_Id := Prj; begin while Proj /= No_Project loop if not Is_In_Object_Projects (Proj) then Object_Projects.Append (Proj); if Proj.Object_Directory /= No_Path_Information and then not Is_In_Object_Directories (Proj.Object_Directory.Display_Name) then PNHT.Set (Object_Directories, Proj.Object_Directory.Display_Name, True); Put_Line (Exchange_File, Get_Name_String (Proj.Object_Directory.Display_Name)); end if; end if; Proj := Proj.Extends; end loop; end; end if; end Get_Object_Projects; --------------------------- -- Is_In_Object_Projects -- --------------------------- function Is_In_Object_Projects (Prj : Project_Id) return Boolean is begin return Object_Projects.Contains (Prj); end Is_In_Object_Projects; -- Start of processing for Write_Object_Directory begin Object_Projects.Clear; PNHT.Reset (Object_Directories); Put_Line (Exchange_File, Library_Label (Object_Directory)); Get_Object_Projects (For_Project); Index := Object_Projects.First_Index; -- Note: cannot iterate on Object_Projects as we're modifying -- the container within the loop. while Index <= Object_Projects.Last_Index loop Prj := Object_Projects.Element (Index); Index := Index + 1; -- Add object directories of imported non library projects Process_Imported_Non_Libraries (Prj); for Proj of Non_Library_Projs loop Get_Object_Projects (Proj); end loop; -- Add ALI dir directories of imported projects (only if it -- is not an externally built project or if the project has -- sources). This skip the library projects with no sources -- used for example to add a system library to the linker. declare List : Project_List := Prj.All_Imported_Projects; begin while List /= null loop if not Is_In_Object_Projects (List.Project) and then (not List.Project.Externally_Built or else List.Project.Source_Dirs /= Nil_String) then if List.Project.Library_ALI_Dir /= No_Path_Information then Put_Line (Exchange_File, Get_Name_String (List.Project.Library_ALI_Dir.Display_Name)); elsif List.Project.Library_Dir /= No_Path_Information then Put_Line (Exchange_File, Get_Name_String (List.Project.Library_Dir.Display_Name)); end if; end if; List := List.Next; end loop; end; end loop; end Write_Object_Directory; --------------------- -- Write_Compilers -- --------------------- procedure Write_Compilers is procedure Compilers_For (Project : Project_Id; Tree : Project_Tree_Ref; Dummy : in out Boolean); -- Write compilers for the given project Dummy : Boolean := True; Lang_Seen : Lang_Set.Set; ------------------- -- Compilers_For -- ------------------- procedure Compilers_For (Project : Project_Id; Tree : Project_Tree_Ref; Dummy : in out Boolean) is pragma Unreferenced (Tree, Dummy); Lang : Language_Ptr := Project.Languages; Compiler : String_Access; begin -- Exchange file, Compilers section while Lang /= No_Language_Index loop if not Lang_Seen.Contains (Lang.Name) then Lang_Seen.Insert (Lang.Name); Compiler := Get_Compiler_Driver_Path (Project, Lang); if Compiler /= null then Put_Line (Exchange_File, Get_Name_String (Lang.Name) & ASCII.LF & Compiler.all); elsif Lang.Config.Compiler_Driver /= No_File then Put_Line (Exchange_File, Get_Name_String (Lang.Name) & ASCII.LF & Get_Name_String (Lang.Config.Compiler_Driver)); end if; end if; Lang := Lang.Next; end loop; end Compilers_For; procedure For_Imported is new For_Every_Project_Imported (Boolean, Compilers_For); -- Start of processing for Write_Compilers begin Put_Line (Exchange_File, Library_Label (Compilers)); Compilers_For (For_Project, Project_Tree, Dummy); if For_Project.Qualifier = Aggregate_Library then For_Imported (For_Project, Project_Tree, Dummy); end if; end Write_Compilers; ------------------------------------- -- Write_Compiler_Leading_Switches -- ------------------------------------- procedure Write_Compiler_Leading_Switches is procedure Compiler_Leading_Switches_For (Project : Project_Id; Tree : Project_Tree_Ref; Dummy : in out Boolean); -- Write compilers for the given project Dummy : Boolean := True; Lang_Seen : Lang_Set.Set; ----------------------------------- -- Compiler_Leading_Switches_For -- ----------------------------------- procedure Compiler_Leading_Switches_For (Project : Project_Id; Tree : Project_Tree_Ref; Dummy : in out Boolean) is pragma Unreferenced (Tree, Dummy); Lang : Language_Ptr := Project.Languages; Indx : Name_List_Index; begin while Lang /= No_Language_Index loop if not Lang_Seen.Contains (Lang.Name) then Lang_Seen.Insert (Lang.Name); Indx := Lang.Config.Compiler_Leading_Required_Switches; if Indx /= No_Name_List then Put_Line (Exchange_File, "language=" & Get_Name_String (Lang.Name)); Emit_Compiler_Switches (Exchange_File, Indx); if Opt.CodePeer_Mode then Put_Line (Exchange_File, "-gnatcC"); end if; end if; end if; Lang := Lang.Next; end loop; end Compiler_Leading_Switches_For; procedure For_Imported is new For_Every_Project_Imported (Boolean, Compiler_Leading_Switches_For); -- Start of processing for Write_Compiler_Leading_Switches begin Put_Line (Exchange_File, Library_Label (Compiler_Leading_Switches)); Compiler_Leading_Switches_For (For_Project, Project_Tree, Dummy); if For_Project.Qualifier = Aggregate_Library then For_Imported (For_Project, Project_Tree, Dummy); end if; end Write_Compiler_Leading_Switches; -------------------------------------- -- Write_Compiler_Trailing_Switches -- -------------------------------------- procedure Write_Compiler_Trailing_Switches is procedure Compiler_Trailing_Switches_For (Project : Project_Id; Tree : Project_Tree_Ref; Dummy : in out Boolean); -- Write compilers for the given project Dummy : Boolean := True; Lang_Seen : Lang_Set.Set; ------------------------------------ -- Compiler_Trailing_Switches_For -- ------------------------------------ procedure Compiler_Trailing_Switches_For (Project : Project_Id; Tree : Project_Tree_Ref; Dummy : in out Boolean) is pragma Unreferenced (Tree, Dummy); Lang : Language_Ptr := Project.Languages; Indx : Name_List_Index; Node : Name_Node; begin while Lang /= No_Language_Index loop if not Lang_Seen.Contains (Lang.Name) then Lang_Seen.Insert (Lang.Name); Indx := Lang.Config.Compiler_Trailing_Required_Switches; if Indx /= No_Name_List then Put_Line (Exchange_File, "language=" & Get_Name_String (Lang.Name)); while Indx /= No_Name_List loop Node := Project_Tree.Shared.Name_Lists.Table (Indx); Put_Line (Exchange_File, Get_Name_String (Node.Name)); Indx := Node.Next; end loop; end if; end if; Lang := Lang.Next; end loop; end Compiler_Trailing_Switches_For; procedure For_Imported is new For_Every_Project_Imported (Boolean, Compiler_Trailing_Switches_For); -- Start of processing for Write_Compiler_Trailing_Switches begin Put_Line (Exchange_File, Library_Label (Compiler_Trailing_Switches)); Compiler_Trailing_Switches_For (For_Project, Project_Tree, Dummy); if For_Project.Qualifier = Aggregate_Library then For_Imported (For_Project, Project_Tree, Dummy); end if; end Write_Compiler_Trailing_Switches; ---------------- -- Write_Name -- ---------------- procedure Write_Name (Label : Library_Section; Name : Name_Id) is begin if Name /= No_Name then Put_Line (Exchange_File, Library_Label (Label) & ASCII.LF & Get_Name_String (Name)); end if; end Write_Name; -------------------- -- Write_Filename -- -------------------- procedure Write_Filename (Label : Library_Section; Filename : File_Name_Type) is begin Write_Name (Label, Name_Id (Filename)); end Write_Filename; ---------------- -- Write_List -- ---------------- procedure Write_List (Label : Library_Section; List : String_List_Id) is Current : String_List_Id := List; Element : String_Element; begin while Current /= Nil_String loop Element := Project_Tree.Shared.String_Elements.Table (Current); Get_Name_String (Element.Value); if Name_Len /= 0 then Check_Section (Label); Put_Line (Exchange_File, Name_Buffer (1 .. Name_Len)); end if; Current := Element.Next; end loop; end Write_List; --------------------- -- Write_Name_List -- --------------------- procedure Write_Name_List (Label : Library_Section; List : Name_List_Index) is Current : Name_List_Index := List; Nam : Name_Node; begin if List /= No_Name_List then Check_Section (Label); loop Nam := Project_Tree.Shared.Name_Lists.Table (Current); Put_Line (Exchange_File, Get_Name_String (Nam.Name)); Current := Nam.Next; exit when Current = No_Name_List; end loop; end if; end Write_Name_List; -------------------------- -- Write_Partial_Linker -- -------------------------- procedure Write_Partial_Linker is List : constant Name_List_Index := For_Project.Config.Lib_Partial_Linker; begin if List /= No_Name_List then Write_Name_List (Partial_Linker, List); end if; end Write_Partial_Linker; -------------------------------------- -- Write_Shared_Lib_Minimum_Options -- -------------------------------------- procedure Write_Shared_Lib_Minimum_Options is Library_Options : Variable_Value := Nil_Variable_Value; begin -- Output the minimal options to build a shared library (standard -- or encapsulated). if For_Project.Standalone_Library = Encapsulated then Library_Options := Value_Of (Name_Library_Encapsulated_Options, For_Project.Decl.Attributes, Project_Tree.Shared); if not Library_Options.Default then Write_List (Gprexch.Shared_Lib_Minimum_Options, Library_Options.Values); end if; else Write_Name_List (Shared_Lib_Minimum_Options, For_Project.Config.Shared_Lib_Min_Options); end if; end Write_Shared_Lib_Minimum_Options; --------------------------- -- Write_Library_Version -- --------------------------- procedure Write_Library_Version is List : constant Name_List_Index := For_Project.Config.Lib_Version_Options; begin if List /= No_Name_List then Write_Name_List (Library_Version_Options, List); end if; end Write_Library_Version; ------------------------------- -- Write_Runtime_Library_Dir -- ------------------------------- procedure Write_Runtime_Library_Dir is procedure RTL_For (Project : Project_Id; Tree : Project_Tree_Ref; Dummy : in out Boolean); -- Write runtime libraries for the given project Dummy : Boolean := True; Lang_Seen : Lang_Set.Set; ------------- -- RTL_For -- ------------- procedure RTL_For (Project : Project_Id; Tree : Project_Tree_Ref; Dummy : in out Boolean) is pragma Unreferenced (Tree, Dummy); List : Language_Ptr := Project.Languages; Lib_Dirs : Name_List_Index; Nam_Nod : Name_Node; begin while List /= No_Language_Index loop if List.Config.Runtime_Library_Dirs /= No_Name_List then Lib_Dirs := List.Config.Runtime_Library_Dirs; while Lib_Dirs /= No_Name_List loop Nam_Nod := Project_Tree.Shared.Name_Lists.Table (Lib_Dirs); if not Lang_Seen.Contains (Nam_Nod.Name) then if Lang_Seen.Length = 0 then Put_Line (Exchange_File, Library_Label (Runtime_Library_Dir)); end if; Lang_Seen.Insert (Nam_Nod.Name); Put_Line (Exchange_File, Get_Name_String (List.Name) & ASCII.LF & Get_Name_String (Nam_Nod.Name)); end if; Lib_Dirs := Nam_Nod.Next; end loop; end if; List := List.Next; end loop; end RTL_For; procedure For_Imported is new For_Every_Project_Imported (Boolean, RTL_For); -- Start of processing for Write_Runtime_Library_Dir begin RTL_For (For_Project, Project_Tree, Dummy); if For_Project.Qualifier = Aggregate_Library then For_Imported (For_Project, Project_Tree, Dummy); end if; end Write_Runtime_Library_Dir; --------------------- -- Write_Auto_Init -- --------------------- procedure Write_Auto_Init is begin if For_Project.Standalone_Library /= No and then For_Project.Lib_Auto_Init then Put_Line (Exchange_File, Library_Label (Auto_Init)); end if; end Write_Auto_Init; --------------------------- -- Write_Binding_Options -- --------------------------- procedure Write_Binding_Options is begin if For_Project.Standalone_Library /= No then declare Binder_Package : constant Package_Id := Value_Of (Name => Name_Binder, In_Packages => For_Project.Decl.Packages, Shared => Project_Tree.Shared); begin if Binder_Package /= No_Package then declare Defaults : constant Array_Element_Id := Value_Of (Name => Name_Default_Switches, In_Arrays => Project_Tree.Shared.Packages.Table (Binder_Package).Decl.Arrays, Shared => Project_Tree.Shared); Switch_Array : constant Array_Element_Id := Value_Of (Name => Name_Switches, In_Arrays => Project_Tree.Shared.Packages.Table (Binder_Package).Decl.Arrays, Shared => Project_Tree.Shared); Switches : Variable_Value := Nil_Variable_Value; begin if Defaults /= No_Array_Element then Switches := Value_Of (Index => Name_Ada, Src_Index => 0, In_Array => Defaults, Shared => Project_Tree.Shared); if not Switches.Default then Write_List (Gprexch.Binding_Options, Switches.Values); end if; end if; if Switch_Array /= No_Array_Element then Switches := Value_Of (Index => Name_Ada, Src_Index => 0, In_Array => Switch_Array, Force_Lower_Case_Index => True, Shared => Project_Tree.Shared); if not Switches.Default and then Switches.Kind = List then Write_List (Gprexch.Binding_Options, Switches.Values); end if; end if; end; end if; end; end if; end Write_Binding_Options; --------------------------- -- Write_Run_Path_Option -- --------------------------- procedure Write_Run_Path_Option is List : constant Name_List_Index := For_Project.Config.Run_Path_Option; begin if Opt.Run_Path_Option and then List /= No_Name_List then Write_Name_List (Run_Path_Option, List); Put_Line (Exchange_File, Library_Label (Gprexch.Run_Path_Origin)); if For_Project.Config.Run_Path_Origin /= No_Name then Put_Line (Exchange_File, Get_Name_String (For_Project.Config.Run_Path_Origin)); end if; if For_Project.Config.Separate_Run_Path_Options then Put_Line (Exchange_File, Library_Label (Gprexch.Separate_Run_Path_Options)); end if; end if; end Write_Run_Path_Option; ----------------------------------- -- Write_Leading_Library_Options -- ----------------------------------- procedure Write_Leading_Library_Options is Leading_Library_Options : Variable_Value := Nil_Variable_Value; begin -- If attribute Leading_Library_Options was specified, add these -- additional options. Leading_Library_Options := Value_Of (Name_Leading_Library_Options, For_Project.Decl.Attributes, Project_Tree.Shared); if not Leading_Library_Options.Default then Write_List (Gprexch.Leading_Library_Options, Leading_Library_Options.Values); end if; end Write_Leading_Library_Options; --------------------------- -- Write_Library_Options -- --------------------------- procedure Write_Library_Options (Success : out Boolean) is procedure Write_Linker_Options (P : Project_Id); -- Write linker options for Project ------------------------------ -- Write_Linker_Options -- ------------------------------ procedure Write_Linker_Options (P : Project_Id) is Linker_Package : constant Package_Id := Value_Of (Name => Name_Linker, In_Packages => P.Decl.Packages, Shared => Project_Tree.Shared); begin -- Check linker package for a definition of Linker_Options if Linker_Package /= No_Package then Check_Attribute : declare Opts : constant Variable_Value := Value_Of (Variable_Name => Name_Linker_Options, In_Variables => Project_Tree.Shared.Packages.Table (Linker_Package).Decl.Attributes, Shared => Project_Tree.Shared); begin -- If a Linker_Options attribute is found, output it -- into the Library_Options section. if not Opts.Default then Output_Options : declare List : String_List_Id := Opts.Values; Elem : String_Element; begin if List /= Nil_String then -- First ensure the section is opended Check_Section (Library_Options); if P.Library_Dir.Name /= No_Path then Put_Line (Exchange_File, "-L" & Get_Name_String (P.Library_Dir.Name)); end if; loop Elem := Project_Tree.Shared.String_Elements.Table (List); Put_Line (Exchange_File, Get_Name_String (Elem.Value)); List := Elem.Next; exit when List = Nil_String; end loop; end if; end Output_Options; end if; end Check_Attribute; end if; end Write_Linker_Options; Library_Options : Variable_Value := Nil_Variable_Value; -- Start of processing for Write_Library_Options begin Success := True; -- If attribute Library_Options was specified, add these -- additional options. Library_Options := Value_Of (Name_Library_Options, For_Project.Decl.Attributes, Project_Tree.Shared); if not Library_Options.Default then Write_List (Gprexch.Library_Options, Library_Options.Values); -- For static libraries, check that the library options are -- existing object files. -- Also, skip this check for SALs so that Library_Options other -- than object files may be specified for the partial linking. if For_Project.Standalone_Library = No and then Is_Static (For_Project) then declare List : String_List_Id := Library_Options.Values; Elem : String_Element; OK : Boolean; begin while List /= Nil_String loop Elem := Project_Tree.Shared.String_Elements.Table (List); Get_Name_String (Elem.Value); if Is_Absolute_Path (Name_Buffer (1 .. Name_Len)) then OK := Is_Regular_File (Name_Buffer (1 .. Name_Len)); else OK := Is_Regular_File (Get_Name_String (For_Project.Object_Directory.Name) & Directory_Separator & Name_Buffer (1 .. Name_Len)); end if; if not OK then Error_Msg (Msg => "unknown object file " & Name_Buffer (1 .. Name_Len), Flag_Location => Library_Options.Location); Success := False; end if; List := Elem.Next; end loop; end; end if; end if; -- For encapsulated and shared libraries we also want to add the -- Linker_Options for all imported projects. if not Is_Static (For_Project) or else For_Project.Standalone_Library = Encapsulated then declare L : Project_List := For_Project.All_Imported_Projects; begin while L /= null loop Write_Linker_Options (L.Project); L := L.Next; end loop; end; end if; -- Get -largs section from command line for shared libraries if not Is_Static (For_Project) then for Arg of Command_Line_Linker_Options loop Check_Section (Gprexch.Library_Options); Put_Line (Exchange_File, Arg); end loop; end if; end Write_Library_Options; --------------------------------- -- Write_Library_Rpath_Options -- --------------------------------- procedure Write_Library_Rpath_Options is procedure Add_Language (Lang : Language_Ptr); -- Add language Name in array Langs if not already there procedure Find_Languages (Project : Project_Id; Tree : Project_Tree_Ref; With_State : in out Boolean); -- Find the languages of a project procedure Find_All_Languages is new For_Every_Project_Imported (Boolean, Find_Languages); procedure Get_Directory; -- Get a directory for one language procedure Get_Languages; -- Put in Langs the languages of the project tree rooted at project -- For_Project. ------------------ -- Add_Language -- ------------------ procedure Add_Language (Lang : Language_Ptr) is begin -- Only add a language if it is not already in the list for J in 1 .. Last_Lang loop if Lang.Name = Langs (J).Name then return; end if; end loop; -- Double array Langs if already full if Last_Lang = Langs'Last then declare New_Langs : constant Lang_Names_Ptr := new Lang_Names (1 .. 2 * Langs'Length); begin New_Langs (Langs'Range) := Langs.all; Langs := New_Langs; end; end if; Last_Lang := Last_Lang + 1; Langs (Last_Lang) := Lang; end Add_Language; -------------------- -- Find_Languages -- -------------------- procedure Find_Languages (Project : Project_Id; Tree : Project_Tree_Ref; With_State : in out Boolean) is pragma Unreferenced (Tree); pragma Unreferenced (With_State); Lang : Language_Ptr := Project.Languages; begin while Lang /= No_Language_Index loop Add_Language (Lang); Lang := Lang.Next; end loop; end Find_Languages; ------------------- -- Get_Languages -- ------------------- procedure Get_Languages is OK : Boolean := True; begin Last_Lang := 0; Find_Languages (For_Project, Project_Tree, OK); Find_All_Languages (By => For_Project, Tree => Project_Tree, With_State => OK, Include_Aggregated => False); end Get_Languages; List : Array_Element_Id; Elem : Array_Element; Label_Issued : Boolean := False; Lang_Index : Natural; Lang_Ptr : Language_Ptr; Opt_List : String_List_Id; Opt_Elem : String_Element; ------------------- -- Get_Directory -- ------------------- procedure Get_Directory is Opt_Nmb : Natural := 0; Args : Argument_List_Access; FD : File_Descriptor; Pname : Path_Name_Type; Return_Code : Integer; File : Text_File; Line : String (1 .. 1000); Last : Natural; Disregard : Boolean; begin -- Check that the compiler driver exists if Lang_Ptr.Config.Compiler_Driver_Path = null then Lang_Ptr.Config.Compiler_Driver_Path := Locate_Exec_On_Path (Get_Name_String (Lang_Ptr.Config.Compiler_Driver)); end if; if Lang_Ptr.Config.Compiler_Driver_Path /= null then -- Count the options while Opt_List /= Nil_String loop Opt_Elem := Project_Tree.Shared.String_Elements.Table (Opt_List); Opt_Nmb := Opt_Nmb + 1; Opt_List := Opt_Elem.Next; end loop; Args := new Argument_List (1 .. Opt_Nmb); -- Put the options in Args Opt_Nmb := 0; Opt_List := Elem.Value.Values; while Opt_List /= Nil_String loop Opt_Elem := Project_Tree.Shared.String_Elements.Table (Opt_List); Opt_Nmb := Opt_Nmb + 1; Args (Opt_Nmb) := new String'(Get_Name_String (Opt_Elem.Value)); Opt_List := Opt_Elem.Next; end loop; -- Create a temporary file and invoke the compiler with the -- options redirecting the output to this temporary file. Tempdir.Create_Temp_File (FD, Pname); Spawn (Program_Name => Lang_Ptr.Config.Compiler_Driver_Path.all, Args => Args.all, Output_File_Descriptor => FD, Return_Code => Return_Code); Close (FD); Free (Args); -- Now read the temporary file and get the first non empty -- line, if any. Open (File, Get_Name_String (Pname)); if Is_Valid (File) then Last := 0; while not End_Of_File (File) loop Get_Line (File, Line, Last); exit when Last > 0; end loop; -- Get the directory name of the path if Last /= 0 then declare Dir : constant String := Dir_Name (Normalize_Pathname (Line (1 .. Last), Resolve_Links => Opt.Follow_Links_For_Files)); begin -- If it is in fact a directory, put it in the -- exchange file. if Is_Directory (Dir) then if not Label_Issued then Put_Line (Exchange_File, Library_Label (Gprexch.Library_Rpath_Options)); Label_Issued := True; end if; Put_Line (Exchange_File, Dir); end if; end; end if; end if; if Is_Valid (File) then Close (File); end if; -- Delete the temporary file, if gprbuild was not invoked -- with -dn. if not Opt.Keep_Temporary_Files then Delete_File (Get_Name_String (Pname), Disregard); end if; end if; end Get_Directory; -- Start of processing for Write_Library_Rpath_Options begin if Opt.Run_Path_Option and then For_Project.Config.Run_Path_Option /= No_Name_List then List := Value_Of (Name_Library_Rpath_Options, For_Project.Decl.Arrays, Project_Tree.Shared); if List /= No_Array_Element then Get_Languages; while Last_Lang /= 0 and then List /= No_Array_Element loop Elem := Project_Tree.Shared.Array_Elements.Table (List); Lang_Index := 0; for J in 1 .. Last_Lang loop if Elem.Index = Langs (J).Name then Lang_Index := J; exit; end if; end loop; if Lang_Index /= 0 then Lang_Ptr := Langs (Lang_Index); -- Remove language from the list so that rpath options -- are not looked for twice for the same language. Langs (Lang_Index .. Last_Lang - 1) := Langs (Lang_Index + 1 .. Last_Lang); Last_Lang := Last_Lang - 1; -- Invoke the compiler for the language, followed by -- the options and put the result into a temporary file. Opt_List := Elem.Value.Values; -- Nothing to do if there is no options if Opt_List /= Nil_String then Get_Directory; end if; end if; List := Elem.Next; end loop; end if; end if; end Write_Library_Rpath_Options; ------------------------------ -- Write_Imported_Libraries -- ------------------------------ procedure Write_Imported_Libraries is begin -- If there are imported libraries, put their data in the exchange -- file. if not Library_Projs.Is_Empty then Put_Line (Exchange_File, Library_Label (Imported_Libraries)); for J in reverse 1 .. Library_Projs.Last_Index loop if For_Project.Qualifier /= Aggregate_Library or else Library_Projs (J).Proj.Externally_Built then Put_Line (Exchange_File, Get_Name_String (Library_Projs (J).Proj.Library_Dir.Display_Name) & ASCII.LF & Get_Name_String (Library_Projs (J).Proj.Library_Name)); end if; end loop; end if; end Write_Imported_Libraries; ---------------------------- -- Write_Dependency_Files -- ---------------------------- procedure Write_Dependency_Files is procedure Process (Proj : Project_Id; Tree : Project_Tree_Ref); procedure Add (Source : Source_Id); --------- -- Add -- --------- procedure Add (Source : Source_Id) is begin if Source.Unit = No_Unit_Index or else For_Project.Standalone_Library = No then Add_Dep (Get_Name_String (Source.Dep_Path)); end if; end Add; ------------- -- Process -- ------------- procedure Process (Proj : Project_Id; Tree : Project_Tree_Ref) is pragma Unreferenced (Tree); Current_Proj : Project_Id := Proj; Source : Source_Id; begin while Current_Proj /= No_Project loop declare Iter : Source_Iterator; begin Iter := For_Each_Source (Project_Tree, Current_Proj); loop Source := GPR.Element (Iter); exit when Source = No_Source; if not Source.Locally_Removed and then Source.Dep_Path /= No_Path and then (not Source.Project.Externally_Built or else not For_Project.Externally_Built or else Source.Project.Extended_By /= No_Project) then if Source.Kind = Spec then if Other_Part (Source) = No_Source then Add (Source); end if; elsif not Is_Subunit (Source) then Add (Source); end if; end if; Next (Iter); end loop; end; Current_Proj := Current_Proj.Extends; end loop; end Process; procedure Process_Aggregate_Library is new For_Project_And_Aggregated (Process); -- Start of processing for Write_Dependency_Files begin Put_Line (Exchange_File, Library_Label (Dependency_Files)); First_Dep := null; Process_Aggregate_Library (For_Project, Project_Tree); if For_Project.Standalone_Library /= No then for Source of Library_Sources loop Add_Dep (Get_Name_String (Source.Dep_Path)); end loop; end if; while First_Dep /= null loop Put_Line (Exchange_File, First_Dep.Name.all); First_Dep := First_Dep.Next; end loop; end Write_Dependency_Files; ------------------------ -- Write_Mapping_File -- ------------------------ procedure Write_Mapping_File is begin if Mapping_Path /= No_Path then Put_Line (Exchange_File, Library_Label (Mapping_File) & ASCII.LF & Get_Name_String (Mapping_Path)); end if; end Write_Mapping_File; ----------------------------- -- Write_Toolchain_Version -- ----------------------------- procedure Write_Toolchain_Version is procedure Toolchain_Version_For (Project : Project_Id; Tree : Project_Tree_Ref; Dummy : in out Boolean); -- Write runtime libraries for the given project Dummy : Boolean := True; Lang_Seen : Lang_Set.Set; --------------------------- -- Toolchain_Version_For -- --------------------------- procedure Toolchain_Version_For (Project : Project_Id; Tree : Project_Tree_Ref; Dummy : in out Boolean) is pragma Unreferenced (Tree, Dummy); List : Language_Ptr := Project.Languages; begin while List /= No_Language_Index loop if (List.Config.Toolchain_Version /= No_Name or else List.Config.Runtime_Library_Version /= No_Name) and then not Lang_Seen.Contains (List.Name) then if Lang_Seen.Length = 0 then Put_Line (Exchange_File, Library_Label (Toolchain_Version)); end if; Lang_Seen.Insert (List.Name); Put_Line (Exchange_File, Get_Name_String (List.Name)); if List.Config.Runtime_Library_Version /= No_Name then Put_Line (Exchange_File, Get_Name_String (List.Config.Runtime_Library_Version)); else Put_Line (Exchange_File, Get_Name_String (List.Config.Toolchain_Version)); end if; end if; List := List.Next; end loop; end Toolchain_Version_For; procedure For_Imported is new For_Every_Project_Imported (Boolean, Toolchain_Version_For); -- Start of processing for Write_Toolchain_Version begin Toolchain_Version_For (For_Project, Project_Tree, Dummy); if For_Project.Qualifier = Aggregate_Library then For_Imported (For_Project, Project_Tree, Dummy); end if; end Write_Toolchain_Version; ------------------------------- -- Write_Interface_Dep_Files -- ------------------------------- procedure Write_Interface_Dep_Files is Key : FNHS.Key_Option; function Interface_ALI return File_Name_Type is (Key.K); begin Put_Line (Exchange_File, Library_Label (Interface_Dep_Files)); Key := FNHS.Get_First_Key (Complete_Interface_ALIs); while Key.Present loop -- Find the source to get the absolute path of the ALI file declare Next_Proj : Project_Id; Iter : Source_Iterator; begin Next_Proj := For_Project.Extends; if For_Project.Qualifier = Aggregate_Library then Iter := For_Each_Source (Project_Tree); else Iter := For_Each_Source (Project_Tree, For_Project); end if; loop while GPR.Element (Iter) /= No_Source and then (GPR.Element (Iter).Unit = null or else GPR.Element (Iter).Dep_Name /= Interface_ALI) loop Next (Iter); end loop; Source := GPR.Element (Iter); exit when Source /= No_Source or else Next_Proj = No_Project; Iter := For_Each_Source (Project_Tree, Next_Proj); Next_Proj := Next_Proj.Extends; end loop; if Source /= No_Source then if Source.Kind = Sep then Source := No_Source; elsif Source.Kind = Spec and then Other_Part (Source) /= No_Source then Source := Other_Part (Source); end if; end if; if Source /= No_Source then if Source.Project /= Project and then not Is_Extending (For_Project, Source.Project) and then For_Project.Qualifier /= Aggregate_Library then Source := No_Source; end if; end if; if Source /= No_Source then Put_Line (Exchange_File, Get_Name_String (Source.Dep_Path)); end if; end; Key := FNHS.Get_Next_Key (Complete_Interface_ALIs); end loop; end Write_Interface_Dep_Files; ---------------------------- -- Write_Other_Interfaces -- ---------------------------- procedure Write_Other_Interfaces is Interfaces : String_List_Id := For_Project.Other_Interfaces; Element : String_Element; begin Put_Line (Exchange_File, Library_Label (Other_Interfaces)); while Interfaces /= Nil_String loop Element := Project_Tree.Shared.String_Elements.Table (Interfaces); Put_Line (Exchange_File, Get_Name_String (Element.Value)); Interfaces := Element.Next; end loop; end Write_Other_Interfaces; ------------------------------- -- Write_Interface_Obj_Files -- ------------------------------- procedure Write_Interface_Obj_Files is List : String_List_Id := For_Project.Other_Interfaces; Element : String_Element; Other_Int : Boolean := False; Key : FNHS.Key_Option; function Interface_Dep return File_Name_Type is (Key.K); function Base_Name (Name : Name_Id) return String; -- File name without path nor extension procedure Find_Source; -- Find the source corresponding to Interface_Dep (when Other_Int is -- False) or Element.Value (when Other_Int is True). --------------- -- Base_Name -- --------------- function Base_Name (Name : Name_Id) return String is N : constant String := Get_Name_String (Name); begin return Base_Name (N, File_Extension (N)); end Base_Name; ----------------- -- Find_Source -- ----------------- procedure Find_Source is Next_Proj : Project_Id; Iter : Source_Iterator; begin Next_Proj := For_Project.Extends; if For_Project.Qualifier = Aggregate_Library then Iter := For_Each_Source (Project_Tree); else Iter := For_Each_Source (Project_Tree, For_Project); end if; loop -- Look for the Source_Id corresponding to this unit while GPR.Element (Iter) /= No_Source and then -- Either an foreign language, we need the -- implementation of this unit. ((Other_Int and then (Base_Name (Name_Id (GPR.Element (Iter).Object)) /= Base_Name (Element.Value) or else GPR.Element (Iter).Kind = Spec or else GPR.Element (Iter).Locally_Removed)) -- Or and Ada unit, we need the dependency file or else (not Other_Int and then (GPR.Element (Iter).Unit = null or else GPR.Element (Iter).Dep_Name /= Interface_Dep))) loop Next (Iter); end loop; Source := GPR.Element (Iter); exit when Source /= No_Source or else Next_Proj = No_Project; Iter := For_Each_Source (Project_Tree, Next_Proj); Next_Proj := Next_Proj.Extends; end loop; if Source /= No_Source then if Source.Kind = Sep then Source := No_Source; elsif Source.Kind = Spec and then Other_Part (Source) /= No_Source then Source := Other_Part (Source); end if; end if; if Source /= No_Source and then Source.Project /= Project and then not Is_Extending (For_Project, Source.Project) and then For_Project.Qualifier /= Aggregate_Library then Source := No_Source; end if; if Source /= No_Source then Put_Line (Exchange_File, Get_Name_String (Source.Object_Path)); end if; end Find_Source; begin Put_Line (Exchange_File, Library_Label (Interface_Obj_Files)); -- First the Ada sources Other_Int := False; Key := FNHS.Get_First_Key (Complete_Interface_ALIs); while Key.Present loop Find_Source; Key := FNHS.Get_Next_Key (Complete_Interface_ALIs); end loop; -- Then the foreign language objects Other_Int := True; while List /= Nil_String loop Element := Project_Tree.Shared.String_Elements.Table (List); Find_Source; List := Element.Next; end loop; end Write_Interface_Obj_Files; ------------------- -- Write_Sources -- ------------------- procedure Write_Sources is begin Put_Line (Exchange_File, Library_Label (Sources)); -- Copy the path of the sources Project := For_Project; while Project /= No_Project loop Iter := For_Each_Source (Project_Tree, Project); loop Source := GPR.Element (Iter); exit when Source = No_Source; if not Source.Locally_Removed and then Source.Replaced_By = No_Source then Put_Line (Exchange_File, Get_Name_String (Source.Path.Display_Name)); end if; Next (Iter); end loop; Project := Project.Extends; end loop; end Write_Sources; -------------------------- -- Write_Response_Files -- -------------------------- procedure Write_Response_Files is begin if For_Project.Config.Max_Command_Line_Length > 0 and then For_Project.Config.Resp_File_Format /= None then Put_Line (Exchange_File, Library_Label (Max_Command_Line_Length) & ASCII.LF & For_Project.Config.Max_Command_Line_Length'Img & ASCII.LF & Library_Label (Gprexch.Response_File_Format) & ASCII.LF & For_Project.Config.Resp_File_Format'Img); if For_Project.Config.Resp_File_Options /= No_Name_List then Write_Name_List (Response_File_Switches, For_Project.Config.Resp_File_Options); end if; end if; end Write_Response_Files; -- Start of processing for Build_Library begin -- Check if there is an object directory if For_Project.Object_Directory.Display_Name = No_Path then Fail_Program (Project_Tree, "no object directory for library project " & Get_Name_String_Safe (For_Project.Display_Name), Exit_Code => E_Project); end if; -- Check consistency and build environment if For_Project.Config.Lib_Support = None then Fail_Program (Project_Tree, "library projects not supported on this platform", Exit_Code => E_General); elsif not Is_Static (For_Project) and then For_Project.Config.Lib_Support /= Full then Fail_Program (Project_Tree, "shared library projects not supported on this platform", Exit_Code => E_General); elsif not For_Project.Config.Lib_Encapsulated_Supported and then For_Project.Standalone_Library = Encapsulated then Fail_Program (Project_Tree, "encapsulated library projects not supported on this platform", Exit_Code => E_General); end if; if For_Project.Config.Library_Builder = No_Path then Fail_Program (Project_Tree, "no library builder specified"); end if; Library_Builder := Locate_Exec_On_Path (Get_Name_String (For_Project.Config.Library_Builder)); if Library_Builder = null then Fail_Program (Project_Tree, "could not locate library builder """ & Get_Name_String_Safe (For_Project.Config.Library_Builder) & '"'); end if; Library_Builder_Name := new String'(Ada.Directories.Base_Name (Library_Builder.all)); if Opt.CodePeer_Mode then null; elsif Is_Static (For_Project) and then not Empty_Archive_Builder then Check_Archive_Builder; elsif For_Project.Standalone_Library /= No then Check_Object_Lister; Check_Export_File; Check_Library_Symbol_File; end if; Library_Needs_To_Be_Built := Opt.Force_Compilations or else For_Project.Need_Build; if not Library_Needs_To_Be_Built and then Opt.Verbosity_Level > Opt.Low then Put (" Checking library "); Put (Get_Name_String (For_Project.Library_Name)); Put_Line (" ..."); end if; Get_Objects; -- Work occurs in the object directory Change_To_Object_Directory (For_Project); -- Get the name of the library exchange file Get_Name_String (For_Project.Library_Name); Add_Str_To_Name_Buffer (Library_Exchange_Suffix); Exchange_File_Name := new String'(Name_Buffer (1 .. Name_Len)); if not Library_Needs_To_Be_Built then declare TS : constant Time_Stamp_Type := File_Stamp (Exchange_File_Name.all); begin if String (TS) < String (Latest_Object_TS) then Library_Needs_To_Be_Built := True; if Opt.Verbosity_Level > Opt.Low then if TS = Empty_Time_Stamp then Put (" -> library exchange file "); Put (Exchange_File_Name.all); Put_Line (" does not exist"); else Put (" -> object files more recent than library" & " exchange file "); Put_Line (Exchange_File_Name.all); end if; end if; else begin Open (Exchange_File, In_File, Exchange_File_Name.all); if End_Of_File (Exchange_File) then if Opt.Verbosity_Level > Opt.Low then Put (" -> library exchange file """); Put (Exchange_File_Name.all); Put_Line (""" is empty"); end if; Library_Needs_To_Be_Built := True; end if; exception when others => if Opt.Verbosity_Level > Opt.Low then Put (" -> library exchange file """); Put (Exchange_File_Name.all); Put_Line (""" cannot be open"); end if; Library_Needs_To_Be_Built := True; end; end if; end; end if; if not Library_Needs_To_Be_Built then -- The exchange file is open in input -- Get the path of the library file that should be the first field Get_Line (Exchange_File, Name_Buffer, Name_Len); if Name_Buffer (1 .. Name_Len) /= Library_Label (Library_Path) then Library_Needs_To_Be_Built := True; Close (Exchange_File); if Opt.Verbosity_Level > Opt.Low then Put (" -> library exchange file "); Put (Exchange_File_Name.all); Put_Line (" has wrong format"); end if; else Get_Line (Exchange_File, Name_Buffer, Name_Len); declare Lib_File_Name : constant String := Base_Name (Name_Buffer (1 .. Name_Len)); Shared_Lib_Prefix : String_Access := new String'("lib"); Shared_Lib_Suffix : String_Access := new String'(".so"); Archive_Suffix : String_Access := new String'(".a"); begin if Is_Static (For_Project) then if For_Project.Config.Archive_Suffix /= No_File then Archive_Suffix := new String' (Get_Name_String (For_Project.Config.Archive_Suffix)); end if; Expected_File_Name := new String' ("lib" & Get_Name_String (For_Project.Library_Name) & Archive_Suffix.all); else if For_Project.Config.Shared_Lib_Prefix /= No_File then Shared_Lib_Prefix := new String' (Get_Name_String (For_Project.Config.Shared_Lib_Prefix)); end if; if For_Project.Config.Shared_Lib_Suffix /= No_File then Shared_Lib_Suffix := new String' (Get_Name_String (For_Project.Config.Shared_Lib_Suffix)); end if; Expected_File_Name := new String' (Shared_Lib_Prefix.all & Get_Name_String (For_Project.Library_Name) & Shared_Lib_Suffix.all); end if; if Lib_File_Name /= Expected_File_Name.all then Library_Needs_To_Be_Built := True; Close (Exchange_File); if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> incorrect library file name"); Put_Line (" expected " & Expected_File_Name.all); Put_Line (" actual " & Lib_File_Name); end if; end if; end; if not Library_Needs_To_Be_Built then For_Project.Library_TS := File_Stamp (Name_Buffer (1 .. Name_Len)); if For_Project.Library_TS < Latest_Object_TS then Library_Needs_To_Be_Built := True; Close (Exchange_File); if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> " & "object file(s) more recent than library file " & Exchange_File_Name.all); end if; end if; end if; end if; end if; if not Library_Needs_To_Be_Built then -- The next line should be the object file label, followed by the -- object paths and time stamps. Get_Line (Exchange_File, Name_Buffer, Name_Len); if Name_Buffer (1 .. Name_Len) /= Library_Label (Object_Files) then Library_Needs_To_Be_Built := True; if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> library exchange file " & Exchange_File_Name.all & " has wrong format"); end if; end if; while not Library_Needs_To_Be_Built and then not End_Of_File (Exchange_File) loop Get_Line (Exchange_File, Name_Buffer, Name_Len); exit when Name_Buffer (1) = '['; Object_Path := Name_Find; Library_Needs_To_Be_Built := True; if End_Of_File (Exchange_File) then if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> library exchange file " & Exchange_File_Name.all & " has wrong format"); end if; else Get_Line (Exchange_File, Name_Buffer, Name_Len); if Name_Len = Time_Stamp_Length then Object_TS := Time_Stamp_Type (Name_Buffer (1 .. Name_Len)); Path_Found := False; declare Elem : Library_Object; Cursor : Objects.Cursor := Library_Objs.First; use Objects; begin -- Look in the Library_Objs set. If the path name is in -- the set, indicate that it has been found. -- The library need to be re-build if the time stamp is -- different in the set. while Cursor /= No_Element loop Elem := Element (Cursor); if Object_Path = Elem.Path then Path_Found := True; Library_Needs_To_Be_Built := Object_TS /= Elem.TS; Elem.Known := True; Library_Objs.Replace_Element (Cursor, Elem); exit; end if; Next (Cursor); end loop; end; -- If the object file is not found, it may be that the path -- in the library is the same as the path of the object -- files, but with different symbolic links. So, we try -- again resolving the symbolic links. if not Path_Found then declare Norm_Path : constant String := Normalize_Pathname (Get_Name_String (Object_Path), Resolve_Links => Opt.Follow_Links_For_Dirs); Elem : Library_Object; Cursor : Objects.Cursor := Library_Objs.First; use Objects; begin while Cursor /= No_Element loop Elem := Element (Cursor); if Norm_Path = Normalize_Pathname (Get_Name_String (Elem.Path), Resolve_Links => Opt.Follow_Links_For_Dirs) then Library_Needs_To_Be_Built := Object_TS /= Elem.TS; Elem.Known := True; Library_Objs.Replace_Element (Cursor, Elem); exit; end if; Next (Cursor); end loop; end; end if; if Library_Needs_To_Be_Built and then Opt.Verbosity_Level > Opt.Low then Put (" -> object file "); Put (Get_Name_String (Object_Path)); Put_Line (" does not exist or have wrong time stamp"); end if; else if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> library exchange file " & Exchange_File_Name.all & " has wrong format"); end if; end if; end if; end loop; -- Check a possible different library version if not Library_Needs_To_Be_Built and then not Is_Static (For_Project) and then For_Project.Config.Symbolic_Link_Supported and then not End_Of_File (Exchange_File) and then Name_Buffer (1 .. Name_Len) = Library_Label (Gprexch.Library_Version) then Get_Line (Exchange_File, Name_Buffer, Name_Len); if Name_Buffer (1 .. Name_Len) /= Get_Name_String (For_Project.Lib_Internal_Name) then Library_Needs_To_Be_Built := True; if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> different library version"); end if; end if; end if; Close (Exchange_File); if not Library_Needs_To_Be_Built then declare Cursor : Objects.Cursor := Library_Objs.First; Elem : Library_Object; use Objects; begin while Cursor /= No_Element loop Elem := Element (Cursor); if not Elem.Known then Library_Needs_To_Be_Built := True; if Opt.Verbosity_Level > Opt.Low then Put (" -> library was built without object file "); Put_Line (Get_Name_String (Elem.Path)); end if; exit; end if; Next (Cursor); end loop; end; end if; end if; if not Library_Needs_To_Be_Built then -- Check if in a project imported directly or indirectly the time -- stamp of a library is greater than the time stamp of this library. declare List : Project_List; Proj2 : Project_Id; Lib_Timestamp1 : constant Time_Stamp_Type := For_Project.Library_TS; begin List := For_Project.All_Imported_Projects; while List /= null loop Proj2 := List.Project; Wait_For_Dependency (Proj2); if not Library_Needs_To_Be_Built and then Proj2.Library and then (Proj2.Was_Built or else Lib_Timestamp1 < Proj2.Library_TS) then Library_Needs_To_Be_Built := True; if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> library file for project " & Get_Name_String_Safe (Proj2.Display_Name) & " is more recent than library file for project " & Get_Name_String_Safe (For_Project.Display_Name)); end if; end if; exit when Library_Needs_To_Be_Built and then Libs_Are_Building.Is_Empty; List := List.Next; end loop; Dependencies_Ready := True; end; end if; if not Library_Needs_To_Be_Built then if Opt.Verbosity_Level > Opt.Low then if For_Project = Main_Project then Put ('"'); Put (Expected_File_Name.all); Put_Line (""" up to date"); else Put_Line (" -> up to date"); end if; end if; else -- The current directory is already the correct object directory. -- However, we call again Change_To_Object_Directory with -- Must_Be_Writable set to True, to check if the object directory -- is writable and to fail graciously if it not. Change_To_Object_Directory (For_Project, Must_Be_Writable => True); -- Create the library exchange file begin Create (Exchange_File, Out_File, Exchange_File_Name.all); exception when others => Fail_Program (Project_Tree, "unable to create library exchange file " & Exchange_File_Name.all); end; if Opt.CodePeer_Mode then Put_Line (Exchange_File, Library_Label (CodePeer_Mode)); end if; if Opt.Quiet_Output then Put_Line (Exchange_File, Library_Label (Quiet)); elsif Opt.Verbose_Mode then if Opt.Verbosity_Level = Opt.Low then Put_Line (Exchange_File, Library_Label (Verbose_Low)); else Put_Line (Exchange_File, Library_Label (Verbose_Higher)); end if; end if; if No_SAL_Binding then Put_Line (Exchange_File, Library_Label (Gprexch.No_SAL_Binding)); end if; Write_Object_Files; -- Library name Put_Line (Exchange_File, Library_Label (Library_Name) & ASCII.LF & Get_Name_String (For_Project.Library_Name)); -- Library version Write_Name (Library_Version, For_Project.Lib_Internal_Name); -- Library directory Put_Line (Exchange_File, Library_Label (Library_Directory) & ASCII.LF & Get_Name_String (For_Project.Library_Dir.Display_Name) & ASCII.LF -- Project directory & Library_Label (Project_Directory) & ASCII.LF & Get_Name_String (For_Project.Directory.Display_Name)); if For_Project.Library_ALI_Dir /= No_Path_Information and then For_Project.Library_ALI_Dir.Name /= For_Project.Library_Dir.Name then Put_Line (Exchange_File, Library_Label (Library_Dependency_Directory) & ASCII.LF & Get_Name_String (For_Project.Library_ALI_Dir.Display_Name)); end if; Write_Object_Directory; Write_Compilers; Write_Compiler_Leading_Switches; Write_Compiler_Trailing_Switches; Write_Partial_Linker; if No_Create then Put_Line (Exchange_File, Library_Label (Gprexch.No_Create)); end if; if Opt.CodePeer_Mode then Put_Line (Exchange_File, Library_Label (Gprexch.CodePeer_Mode)); elsif Is_Static (For_Project) then Put_Line (Exchange_File, Library_Label (Static) & ASCII.LF & Library_Label (Archive_Builder) & ASCII.LF & (if not Empty_Archive_Builder then Archive_Builder_Path.all else "")); for Opt of Archive_Builder_Opts loop Put_Line (Exchange_File, Opt.Name); end loop; if not Archive_Builder_Append_Opts.Is_Empty then Put_Line (Exchange_File, Library_Label (Archive_Builder_Append_Option)); for Option of Archive_Builder_Append_Opts loop Put_Line (Exchange_File, Option.Name); end loop; end if; Write_Filename (Archive_Suffix, For_Project.Config.Archive_Suffix); if Archive_Indexer_Path /= null then Put_Line (Exchange_File, Library_Label (Archive_Indexer) & ASCII.LF & Archive_Indexer_Path.all); for Option of Archive_Indexer_Opts loop Put_Line (Exchange_File, Option.Name); end loop; end if; else -- Driver_Name Write_Filename (Driver_Name, For_Project.Config.Shared_Lib_Driver); -- Shared_Lib_Prefix Write_Filename (Shared_Lib_Prefix, For_Project.Config.Shared_Lib_Prefix); -- Shared_Lib_Suffix Write_Filename (Shared_Lib_Suffix, For_Project.Config.Shared_Lib_Suffix); Write_Shared_Lib_Minimum_Options; Write_Library_Version; -- Symbolic_Link_Supported if For_Project.Config.Symbolic_Link_Supported then Put_Line (Exchange_File, Library_Label (Symbolic_Link_Supported)); end if; -- Major_Minor_Id_Supported if For_Project.Config.Lib_Maj_Min_Id_Supported then Put_Line (Exchange_File, Library_Label (Major_Minor_Id_Supported)); end if; -- Relocatable Put_Line (Exchange_File, Library_Label (Relocatable)); -- Auto_init Write_Auto_Init; -- Archive_Suffix -- This is needed even in the case of dynamic libraries as they -- may rely on static libraries (e.g. if they are encapsulated) Write_Filename (Archive_Suffix, For_Project.Config.Archive_Suffix); -- Gprexch.Install_Name if Opt.Run_Path_Option then Write_Name (Gprexch.Install_Name, For_Project.Config.Library_Install_Name_Option); end if; Write_Run_Path_Option; Write_Leading_Library_Options; Write_Library_Rpath_Options; end if; Write_Runtime_Library_Dir; Write_Binding_Options; Write_Library_Options (Library_Options_Success); Write_Dependency_Files; Write_Mapping_File; Write_Toolchain_Version; if not Is_Static (For_Project) or else For_Project.Standalone_Library = Encapsulated then Process_Imported_Libraries (For_Project, There_Are_SALs => Disregard); Write_Imported_Libraries; end if; if For_Project.Standalone_Library /= No then if For_Project.Lib_Auto_Init then Put_Line (Exchange_File, Library_Label (Auto_Init)); end if; Write_Interface_Dep_Files; if For_Project.Other_Interfaces /= Nil_String then Write_Other_Interfaces; end if; if For_Project.Library_Src_Dir /= No_Path_Information then -- Copy_Source_Dir Put_Line (Exchange_File, Library_Label (Copy_Source_Dir) & ASCII.LF & Get_Name_String (For_Project.Library_Src_Dir.Display_Name)); Write_Sources; end if; -- Standalone mode Put_Line (Exchange_File, Library_Label (Standalone_Mode) & ASCII.LF & Standalone'Image (For_Project.Standalone_Library)); if For_Project.Symbol_Data.Symbol_Policy = Restricted then if Library_Symbol_File /= null then Put_Line (Exchange_File, Library_Label (Gprexch.Library_Symbol_File) & ASCII.LF & Library_Symbol_File.all); elsif Object_Lister_Path /= null then -- Write interface objects Write_Interface_Obj_Files; -- Write object lister Put_Line (Exchange_File, Library_Label (Object_Lister) & ASCII.LF & Object_Lister_Path.all); for Option of Object_Lister_Opts loop Put_Line (Exchange_File, Option.Name); end loop; Put_Line (Exchange_File, Library_Label (Gprexch.Object_Lister_Matcher) & ASCII.LF & Object_Lister_Matcher.all); end if; if Export_File_Switch /= null then -- Write export symbols format Put_Line (Exchange_File, Library_Label (Export_File) & ASCII.LF & GPR.Export_File_Format'Image (Export_File_Format) & ASCII.LF & Export_File_Switch.all); end if; end if; elsif For_Project.Other_Interfaces /= Nil_String then Write_Other_Interfaces; end if; Write_Response_Files; if Opt.Keep_Temporary_Files then Put_Line (Exchange_File, Library_Label (Keep_Temporary_Files)); end if; if Build_Script_Name /= null then Put_Line (Exchange_File, Library_Label (Script_Path) & ASCII.LF & Build_Script_Name.all); end if; Close (Exchange_File); declare Arguments : constant Argument_List := (1 => Exchange_File_Name); Success : Boolean; begin if Library_Options_Success then if not Opt.Quiet_Output then if Opt.Verbose_Mode then Put_Line (Library_Builder.all & " " & Exchange_File_Name.all); else Display (Section => Build_Libraries, Command => Library_Builder_Name.all, Argument => Exchange_File_Name.all); end if; end if; if not Dependencies_Ready then declare L : Project_List := For_Project.All_Imported_Projects; begin while L /= null loop Wait_For_Dependency (L.Project); L := L.Next; end loop; end; end if; Wait_For_Slots_Less_Than (Opt.Maximum_Binders); if Stop_Spawning then return; end if; declare Pid : Process_Id; MI : Main_Info; begin Pid := Non_Blocking_Spawn (Library_Builder.all, Arguments); Success := Pid /= Invalid_Pid; if Success then MI.File := No_File; MI.Project := For_Project; MI.Tree := Project_Tree; Libs_Are_Building.Insert (For_Project.Name); Add_Process (Pid, (Binding, MI)); Display_Processes ("bind"); end if; end; else Success := False; end if; if not Success then Fail_Program (Project_Tree, "could not build library for project " & Project_Name); end if; end; end if; -- Restore the current working directory to its previous value Change_Dir (Current_Dir); end Build_Library; ---------------------------- -- Emit_Compiler_Switches -- ---------------------------- procedure Emit_Compiler_Switches (Exchange_File : Text_IO.File_Type; Index : Name_List_Index) is Node : Name_Node; List : Name_List_Index := Index; Previous_Was_X : Boolean := False; begin while List /= No_Name_List loop Node := Project_Tree.Shared.Name_Lists.Table (List); declare Arg : constant String := Get_Name_String (Node.Name); begin if Opt.CodePeer_Mode then if Previous_Was_X then Put_Line (Exchange_File, "adascil"); -- Strip target specific -m switches in CodePeer mode. elsif Arg'Length <= 2 or else Arg (1 .. 2) /= "-m" then Put_Line (Exchange_File, Arg); end if; else Put_Line (Exchange_File, Arg); end if; Previous_Was_X := Arg = "-x"; end; List := Node.Next; end loop; end Emit_Compiler_Switches; ----------------------------------- -- Is_Included_In_Global_Archive -- ----------------------------------- function Is_Included_In_Global_Archive (Object_Name : File_Name_Type; Project : Project_Id) return Boolean is Proj : Project_Id; Source : Source_Id; Iter : Source_Iterator; begin -- If a source is overriden in an extending project, then the object -- file is not included in the global archive. Proj := Project.Extended_By; while Proj /= No_Project loop Iter := For_Each_Source (Project_Tree, Proj); loop Source := GPR.Element (Iter); exit when Source = No_Source; if Object_To_Global_Archive (Source) and then Source.Object = Object_Name then return False; end if; Next (Iter); end loop; Proj := Proj.Extended_By; end loop; Iter := For_Each_Source (Project_Tree, Project); loop Source := GPR.Element (Iter); exit when Source = No_Source; if Object_To_Global_Archive (Source) and then Source.Object = Object_Name then return Source.Language.Config.Objects_Linked; end if; Next (Iter); end loop; return True; end Is_Included_In_Global_Archive; --------- -- Run -- --------- procedure Run is Main : Main_Info; procedure Do_Post (Project : Project_Id; Tree : Project_Tree_Ref); ------------- -- Do_Post -- ------------- procedure Do_Post (Project : Project_Id; Tree : Project_Tree_Ref) is begin if Builder_Data (Tree).Need_Binding and then not Stop_Spawning then Post_Compilation_Phase (Project, Tree); end if; end Do_Post; procedure Post_Compile_All is new For_Project_And_Aggregated (Do_Post); begin Clear_Time_Stamp_Cache; Libs_Are_Building.Clear; Outstanding_Processes := 0; Stop_Spawning := False; if Main_Project.Qualifier = Aggregate_Library then -- For an aggregate library we do not want to build separate -- libraries if any, this means that at this point we want to -- handle only the main aggregate library project. if Builder_Data (Project_Tree).Need_Binding then Post_Compilation_Phase (Main_Project, Project_Tree); end if; else Post_Compile_All (Main_Project, Project_Tree); end if; Wait_For_Slots_Less_Than (1); if Bad_Processes.Length = 1 then Main := Bad_Processes.First_Element; Fail_Program (Main.Tree, (if Main.File = No_File -- It was gprlib call then "could not build library for project " & Get_Name_String_Safe (Main.Project.Name) else "unable to bind " & Get_Name_String_Safe (Main.File)), Exit_Code => E_Subtool); elsif not Bad_Processes.Is_Empty then for Main of Bad_Processes loop Put (" binding of "); Put (if Main.File = No_File -- gprlib call then Get_Name_String (Main.Project.Name) else Get_Name_String (Main.File)); Put_Line (" failed"); end loop; Fail_Program (Bad_Processes.Last_Element.Tree, "*** post compilation phase failed", Exit_Code => E_Subtool); end if; end Run; ---------------------------- -- Post_Compilation_Phase -- ---------------------------- procedure Post_Compilation_Phase (Main_Project : Project_Id; Project_Tree : Project_Tree_Ref) is use Ada.Calendar; Exchange_File : Text_IO.File_Type; Line : String (1 .. 1_000); Last : Natural; Proj_List : Project_List; Shared_Libs : Boolean := False; Bind_Exchange_TS : Time; Bind_Object_TS : Time; Binder_Driver_Needs_To_Be_Called : Boolean := False; function Get_Project_Checksum (Project : Project_Id) return Message_Digest; -- Calculate checksum of the Project variables and attributes There_Are_Stand_Alone_Libraries : Boolean := False; -- Set to True if there are SALS in the project tree procedure Bind_Language (Main_Proj : Project_Id; Main : String; Main_Base_Name_Index : File_Name_Type; Main_File : Main_Info; Main_Id : File_Name_Type; B_Data : Binding_Data); -- Do the "binding" phase for the language described in B_Data procedure Add_Dependency_Files (For_Project : Project_Id; Language : Language_Ptr; Main_Source : Source_Id; Dep_Files : out Boolean); -- Put the dependency files of the project in the binder exchange file -------------------------- -- Add_Dependency_Files -- -------------------------- procedure Add_Dependency_Files (For_Project : Project_Id; Language : Language_Ptr; Main_Source : Source_Id; Dep_Files : out Boolean) is Config : constant Language_Config := Language.Config; Roots : Roots_Access; Iter : Source_Iterator; procedure Put_Dependency_File (Source : Source_Id); -- Put in the exchange file the dependency file path name for source -- Source, if applicable. ------------------------- -- Put_Dependency_File -- ------------------------- procedure Put_Dependency_File (Source : Source_Id) is begin if Source.Language.Name = Language.Name and then ((Config.Kind = File_Based and then Source.Kind = Impl) or else (Config.Kind = Unit_Based and then Source.Unit not in No_Unit_Index | Main_Source.Unit and then (Source.Kind = Impl or else Other_Part (Source) = No_Source) and then not Is_Subunit (Source))) and then Is_Included_In_Global_Archive (Source.Object, Source.Project) then if Source.Project = For_Project or not Source.Project.Library or Config.Kind = File_Based then Add_Dep (Get_Name_String (Source.Dep_Path)); Dep_Files := True; elsif Source.Project.Standalone_Library = No then Get_Name_String (Source.Project.Library_ALI_Dir.Display_Name); Get_Name_String_And_Append (Name_Id (Source.Dep_Name)); Add_Dep (Name_Buffer (1 .. Name_Len)); Dep_Files := True; end if; end if; end Put_Dependency_File; -- Start of processing for Add_Dependency_Files begin Dep_Files := False; Roots := Main_Source.Roots; if Roots = null then if Main_Source.Unit = No_Unit_Index then if Main_Project.Qualifier = Aggregate_Library then Iter := For_Each_Source (Project_Tree); else Iter := For_Each_Source (Project_Tree, Encapsulated_Libs => False); end if; while GPR.Element (Iter) /= No_Source loop Initialize_Source_Record (GPR.Element (Iter)); -- Do not bind the non compilable sources, such as those -- that have been locally removed. if Is_Compilable (GPR.Element (Iter)) then Put_Dependency_File (GPR.Element (Iter)); end if; Next (Iter); end loop; end if; else -- Put the Roots while Roots /= null loop if Roots.Root /= No_Source then Put_Dependency_File (Roots.Root); end if; Roots := Roots.Next; end loop; end if; end Add_Dependency_Files; ------------------- -- Bind_Language -- ------------------- procedure Bind_Language (Main_Proj : Project_Id; Main : String; Main_Base_Name_Index : File_Name_Type; Main_File : Main_Info; Main_Id : File_Name_Type; B_Data : Binding_Data) is subtype Project_Check_String is String (1 .. Time_Stamp_Type'Length + 1 + Message_Digest'Length); -- Project timestamp and checksum of the project variables with a -- space in between. Empty_Check_String : constant Project_Check_String := (others => ASCII.NUL); type Project_Check_Line is record Project : Project_Id; Line : Project_Check_String := Empty_Check_String; end record; function Hash (Item : Path_Name_Type) return Ada.Containers.Hash_Type is (Ada.Containers.Hash_Type'Mod (Item)); function File_Stamp (File : Path_Name_Type) return Time is (File_Time_Stamp (Get_Name_String (File))); -- Returns file modification time package Project_File_Paths is new Ada.Containers.Hashed_Maps (Key_Type => Path_Name_Type, Element_Type => Project_Check_Line, Hash => Hash, Equivalent_Keys => "="); function Get_Project_Checkline (Project : Project_Id) return Project_Check_String; -- Returns project check line either from Projects container or -- calculate it if absent. Projects : Project_File_Paths.Map; Project_Path : Path_Name_Type; Position : Project_File_Paths.Cursor; Counter : Natural := 0; Main_Source : constant Source_Id := Main_File.Source; Bind_Exchange : constant String_Access := Binder_Exchange_File_Name (Main_Base_Name_Index, B_Data.Binder_Prefix); Dep_Files : Boolean; Lang_Index : Language_Ptr; Object_File_Suffix_Label_Written : Boolean; --------------------------- -- Get_Project_Checkline -- --------------------------- function Get_Project_Checkline (Project : Project_Id) return Project_Check_String is begin Position := Projects.Find (Project.Path.Display_Name); if Project_File_Paths.Has_Element (Position) and then Project_File_Paths.Element (Position).Line (1) /= ASCII.NUL then return Project_File_Paths.Element (Position).Line; end if; return String (Osint.File_Stamp (Project.Path.Display_Name)) & ' ' & Get_Project_Checksum (Project); end Get_Project_Checkline; begin Binder_Driver_Needs_To_Be_Called := Opt.Force_Compilations; -- First check if the binder driver needs to be called. -- It needs to be called if -- 1) there is no existing binder exchange file -- 2) there is no binder generated object file -- 3) there is a dependency file of the language that -- is more recent than any of these two files if not Binder_Driver_Needs_To_Be_Called and then Opt.Verbosity_Level > Opt.Low then Put_Line (" Checking binder generated files for " & Main & "..."); end if; Bind_Exchange_TS := File_Stamp (Path_Name_Type'(Create_Name (Bind_Exchange.all))); if not Binder_Driver_Needs_To_Be_Called then if Bind_Exchange_TS = Osint.Invalid_Time then Binder_Driver_Needs_To_Be_Called := True; if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> binder exchange file " & Bind_Exchange.all & " does not exist"); end if; else begin Open (Exchange_File, In_File, Bind_Exchange.all); exception when others => Binder_Driver_Needs_To_Be_Called := True; if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> could not open " & "binder exchange file" & Bind_Exchange.all); end if; end; end if; end if; if not Binder_Driver_Needs_To_Be_Called then begin Get_Line (Exchange_File, Line, Last); exception when others => Binder_Driver_Needs_To_Be_Called := True; if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> previous gprbind failed, or " & Bind_Exchange.all & " corrupted"); end if; end; end if; -- Check the generated object file if not Binder_Driver_Needs_To_Be_Called then if Line (1 .. Last) /= Binding_Label (Generated_Object_File) or else End_Of_File (Exchange_File) then Binder_Driver_Needs_To_Be_Called := True; if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> previous gprbind failed, or " & Bind_Exchange.all & " corrupted"); end if; else Get_Line (Exchange_File, Line, Last); Bind_Object_TS := File_Stamp (Path_Name_Type'(Create_Name (Line (1 .. Last)))); -- Do not perform this check in CodePeer mode where there is -- no object file per se. if Bind_Object_TS = Osint.Invalid_Time and not Opt.CodePeer_Mode then Binder_Driver_Needs_To_Be_Called := True; if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> binder generated object " & Line (1 .. Last) & " does not exist"); end if; end if; end if; end if; if not Binder_Driver_Needs_To_Be_Called then if End_Of_File (Exchange_File) then Binder_Driver_Needs_To_Be_Called := True; else Get_Line (Exchange_File, Line, Last); if Line (1 .. Last) /= Binding_Label (Project_Files) or else End_Of_File (Exchange_File) then Binder_Driver_Needs_To_Be_Called := True; end if; end if; if Binder_Driver_Needs_To_Be_Called then if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> previous gprbind failed, or " & Bind_Exchange.all & " corrupted"); end if; else -- Populate the hash table Project_File_Paths with -- the paths of all project files in the closure -- of the main project. Projects.Insert (Main_Proj.Path.Display_Name, Project_Check_Line'(Main_Proj, Line => <>)); Proj_List := Main_Proj.All_Imported_Projects; while Proj_List /= null loop Projects.Insert (Proj_List.Project.Path.Display_Name, (Proj_List.Project, Line => <>)); Proj_List := Proj_List.Next; end loop; -- Get the project file paths from the exchange -- file and check if they are the expected project -- files with the same time stamps. while not End_Of_File (Exchange_File) loop Get_Line (Exchange_File, Name_Buffer, Name_Len); exit when Name_Len > 0 and then Name_Buffer (1) = '['; if End_Of_File (Exchange_File) then Binder_Driver_Needs_To_Be_Called := True; if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> previous gprbind failed, " & "or " & Bind_Exchange.all & " corrupted"); end if; exit; end if; Project_Path := Name_Find; Position := Projects.Find (Project_Path); if Project_File_Paths.Has_Element (Position) then Counter := Counter + 1; pragma Assert (Projects (Position).Line = Empty_Check_String); Projects (Position).Line := String (Osint.File_Stamp (Project_Path)) & ' ' & Get_Project_Checksum (Projects (Position).Project); Get_Line (Exchange_File, Line, Last); if Projects (Position).Line /= Line (1 .. Last) then Binder_Driver_Needs_To_Be_Called := True; if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> project file " & Get_Name_String_Safe (Project_Path) & " has been modified"); end if; exit; end if; else Binder_Driver_Needs_To_Be_Called := True; if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> unknown project file " & Get_Name_String_Safe (Project_Path)); end if; exit; end if; end loop; -- Check if there are still project file paths in -- the hash table. if not Binder_Driver_Needs_To_Be_Called and then Counter < Natural (Projects.Length) then Binder_Driver_Needs_To_Be_Called := True; if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> more project files"); end if; end if; end if; end if; if Is_Open (Exchange_File) then Close (Exchange_File); end if; if not Binder_Driver_Needs_To_Be_Called then Queue.Initialize (Opt.One_Compilation_Per_Obj_Dir, Force => True); declare Config : constant Language_Config := B_Data.Language.Config; Source_Identity : Source_Id; Roots : Roots_Access; Source : Source_Id; Iter : Source_Iterator; begin -- Put the root sources in the queue if Main_Source.Language.Name = B_Data.Language.Name then Queue.Insert (Source => (Tree => Main_File.Tree, Id => Main_File.Source, Closure => False)); end if; Roots := Main_Source.Roots; while Roots /= null loop Queue.Insert (Source => (Tree => Main_File.Tree, Id => Roots.Root, Closure => False)); Roots := Roots.Next; end loop; -- If main is not unit base and there is no root, -- check all sources with the language name of the -- binder, except those that are not interfaces of -- their project. if Queue.Is_Empty then Iter := For_Each_Source (Project_Tree); Loop1 : loop Source := GPR.Element (Iter); exit Loop1 when Source = No_Source; if Source.Language.Name = B_Data.Language.Name and then not Source.Locally_Removed and then Is_Compilable (Source) and then ((Config.Kind = File_Based and then Source.Kind = Impl) or else (Config.Kind = Unit_Based and then Source.Unit /= No_Unit_Index and then Source.Unit /= Main_Source.Unit and then (Source.Kind = Impl or else Other_Part (Source) = No_Source) and then not Is_Subunit (Source))) and then Source.In_Interfaces then declare Proj : Project_Id; Src : Source_Id; Iter2 : Source_Iterator; begin -- If a source is overriden in an -- extending project, then the object file -- is not included in the global archive. Proj := Source.Project.Extended_By; Loop2 : while Proj /= No_Project loop Iter2 := For_Each_Source (Project_Tree, Proj); loop Src := GPR.Element (Iter2); exit when Src = No_Source; exit Loop1 when Src.Object = Source.Object; Next (Iter2); end loop; Proj := Proj.Extended_By; end loop Loop2; end; Queue.Insert (Source => (Tree => Main_File.Tree, Id => Source, Closure => False)); end if; Next (Iter); end loop Loop1; end if; -- Get each file from the queue and check its -- dependency file. declare Dep_TS : aliased File_Attributes := Unknown_Attributes; Dep_File : File_Name_Type; Dep_Path : Path_Name_Type; The_ALI : ALI.ALI_Id; Text : Text_Buffer_Ptr; Found : Boolean; Source : Queue.Source_Info; begin while not Queue.Is_Empty loop Queue.Extract (Found, Source); Source_Identity := Source.Id; Initialize_Source_Record (Source_Identity); -- Get the dependency file for this source Dep_File := Source_Identity.Dep_Name; Dep_Path := Source_Identity.Dep_Path; Dep_TS := Source_Identity.Dep_TS; -- For a library file, if there is no ALI file -- in the object directory, check in the Library -- ALI directory. if not Is_Regular_File (Get_Name_String (Dep_Path)) and then Source_Identity.Project.Library and then Source_Identity.Project.Library_ALI_Dir /= No_Path_Information then Set_Name_Buffer (Get_Name_String (Source_Identity.Project .Library_ALI_Dir.Display_Name)); Add_Char_To_Name_Buffer (Directory_Separator); Get_Name_String_And_Append (Dep_File); Dep_TS := Unknown_Attributes; if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then Dep_Path := Name_Find; end if; end if; declare Proj : Project_Id := Source_Identity.Project.Extended_By; begin while Proj /= No_Project loop Name_Len := 0; if Proj.Library and then Proj.Library_ALI_Dir /= No_Path_Information then Get_Name_String_And_Append (Proj.Library_ALI_Dir.Display_Name); else Get_Name_String_And_Append (Proj.Object_Directory.Display_Name); end if; Add_Char_To_Name_Buffer (Directory_Separator); Get_Name_String_And_Append (Dep_File); -- Check if the dependency file exists in -- the extended project, and if it does, -- replace both Dep_Path and Dep_TS with -- the information for it. if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then Dep_Path := Name_Find; end if; Proj := Proj.Extended_By; end loop; end; -- Check the time stamp against the binder -- exchange file time stamp. if File_Time_Stamp (Dep_Path, Dep_TS'Access) = Empty_Time_Stamp then Binder_Driver_Needs_To_Be_Called := True; if Opt.Verbosity_Level > Opt.Low then Put (" -> cannot find "); Put_Line (Get_Name_String (Dep_Path)); end if; exit; elsif File_Stamp (Dep_Path) > Bind_Exchange_TS then Binder_Driver_Needs_To_Be_Called := True; if Opt.Verbosity_Level > Opt.Low then Put (" -> "); Put (Get_Name_String (Dep_Path)); Put_Line (" is more recent than the binder exchange file"); end if; exit; else Text := Read_Library_Info_From_Full (File_Name_Type (Dep_Path), Dep_TS'Access); if Text /= null then The_ALI := ALI.Scan_ALI (File_Name_Type (Dep_Path), Text, Ignore_ED => False, Err => True, Read_Lines => "W"); Free (Text); Queue.Insert_Withed_Sources_For (The_ALI, Project_Tree, Excluding_Shared_SALs => True); end if; end if; end loop; end; end; end if; if not Binder_Driver_Needs_To_Be_Called then if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> up to date"); end if; else begin Create (Exchange_File, Out_File, Bind_Exchange.all); exception when others => Fail_Program (Project_Tree, "unable to create binder exchange file " & Bind_Exchange.all); end; -- Optional line: Quiet or Verbose if Opt.Quiet_Output then Put_Line (Exchange_File, Binding_Label (Quiet)); elsif Opt.Verbose_Mode then if Opt.Verbosity_Level = Opt.Low then Put_Line (Exchange_File, Binding_Label (Verbose_Low)); else Put_Line (Exchange_File, Binding_Label (Verbose_Higher)); end if; end if; -- If -dn was used, indicate to gprbind that the -- temporary response file, if created, should not -- deleted. if Opt.Keep_Temporary_Files then Put_Line (Exchange_File, Binding_Label (Delete_Temp_Files) & ASCII.LF & "False"); end if; -- If there are Stand-Alone Libraries, tell it to gprbind if There_Are_Stand_Alone_Libraries then Put_Line (Exchange_File, Binding_Label (Gprexch.There_Are_Stand_Alone_Libraries)); end if; -- If the language is Ada, create a binder mapping file -- and pass it to gprbind. if B_Data.Language_Name = Name_Ada then declare Mapping_Path : constant Path_Name_Type := Create_Binder_Mapping_File (Project_Tree); begin if Mapping_Path /= No_Path then Put_Line (Exchange_File, Binding_Label (Gprexch.Mapping_File) & ASCII.LF & Get_Name_String (Mapping_Path)); end if; end; end if; -- Send the Toolchain Version if there is one for the language if B_Data.Language.Config.Toolchain_Version /= No_Name or else B_Data.Language.Config.Runtime_Library_Version /= No_Name then Put_Line (Exchange_File, Binding_Label (Toolchain_Version) & ASCII.LF & Get_Name_String (B_Data.Language.Name)); if B_Data.Language.Config.Runtime_Library_Version /= No_Name then Put_Line (Exchange_File, Get_Name_String (B_Data.Language.Config.Runtime_Library_Version)); else Put_Line (Exchange_File, Get_Name_String (B_Data.Language.Config.Toolchain_Version)); end if; end if; -- Send the object file suffix for each language where it -- is declared. Lang_Index := Main_Proj.Languages; Object_File_Suffix_Label_Written := False; while Lang_Index /= No_Language_Index loop if Lang_Index.Config.Object_File_Suffix /= No_Name then if not Object_File_Suffix_Label_Written then Put_Line (Exchange_File, Binding_Label (Gprexch.Object_File_Suffix)); Object_File_Suffix_Label_Written := True; end if; Put_Line (Exchange_File, Get_Name_String (Lang_Index.Name) & ASCII.LF & Get_Name_String (Lang_Index.Config.Object_File_Suffix)); end if; Lang_Index := Lang_Index.Next; end loop; -- Optional line: shared libs if Shared_Libs then Put_Line (Exchange_File, Binding_Label (Gprexch.Shared_Libs)); end if; -- First, the main base name Put_Line (Exchange_File, Binding_Label (Gprexch.Main_Base_Name) & ASCII.LF & Get_Name_String (Main_Base_Name_Index)); -- Then, the compiler path and required switches declare Config : Language_Config renames B_Data.Language.Config; List : Name_List_Index; Nam_Nod : Name_Node; begin -- Compiler path Put_Line (Exchange_File, Binding_Label (Gprexch.Compiler_Path) & ASCII.LF & Get_Compiler_Driver_Path (Main_Proj, B_Data.Language).all); -- Leading required switches, if any List := Config.Compiler_Leading_Required_Switches; if List /= No_Name_List then Put_Line (Exchange_File, Binding_Label (Gprexch.Compiler_Leading_Switches)); Emit_Compiler_Switches (Exchange_File, List); if Opt.CodePeer_Mode then Put_Line (Exchange_File, "-gnatcC"); end if; end if; -- Trailing required switches, if any List := Config.Compiler_Trailing_Required_Switches; if List /= No_Name_List then Put_Line (Exchange_File, Binding_Label (Gprexch.Compiler_Trailing_Switches)); while List /= No_Name_List loop Nam_Nod := Project_Tree.Shared.Name_Lists.Table (List); Put_Line (Exchange_File, Get_Name_String (Nam_Nod.Name)); List := Nam_Nod.Next; end loop; end if; end; -- Then, the Dependency files if Main_Source.Unit /= No_Unit_Index then Initialize_Source_Record (Main_Source); Put_Line (Exchange_File, Binding_Label (Main_Dependency_File) & ASCII.LF & Get_Name_String (Main_Source.Dep_Path)); end if; -- Add the relevant dependency files, either those in -- Roots (
) for the project, or all dependency -- files in the project tree, if Roots (
) is not -- specified . Put_Line (Exchange_File, Binding_Label (Dependency_Files)); First_Dep := null; Add_Dependency_Files (Main_Proj, B_Data.Language, Main_Source, Dep_Files); while First_Dep /= null loop Put_Line (Exchange_File, First_Dep.Name.all); First_Dep := First_Dep.Next; end loop; -- Put the options, if any declare The_Packages : constant Package_Id := Main_Proj.Decl.Packages; Binder_Package : constant GPR.Package_Id := GPR.Util.Value_Of (Name => Name_Binder, In_Packages => The_Packages, Shared => Project_Tree.Shared); Config : constant Language_Config := B_Data.Language.Config; Options_Instance : constant Bind_Option_Table_Ref := Binder_Options_HTable.Get (B_Data.Language_Name); Switches : Variable_Value; Switch_List : String_List_Id; Element : String_Element; begin -- First, check if there are binder options -- specified in the main project file. if Binder_Package /= No_Package then declare Defaults : constant Array_Element_Id := GPR.Util.Value_Of (Name => Name_Default_Switches, In_Arrays => Project_Tree.Shared.Packages.Table (Binder_Package).Decl.Arrays, Shared => Project_Tree.Shared); Switches_Array : constant Array_Element_Id := GPR.Util.Value_Of (Name => Name_Switches, In_Arrays => Project_Tree.Shared.Packages.Table (Binder_Package).Decl.Arrays, Shared => Project_Tree.Shared); begin Switches := GPR.Util.Value_Of (Index => Name_Id (Main_Id), Src_Index => 0, In_Array => Switches_Array, Shared => Project_Tree.Shared, Allow_Wildcards => True); if Switches = Nil_Variable_Value then Switches := GPR.Util.Value_Of (Index => B_Data.Language_Name, Src_Index => 0, In_Array => Switches_Array, Shared => Project_Tree.Shared, Force_Lower_Case_Index => True); end if; if Switches = Nil_Variable_Value then Switches := GPR.Util.Value_Of (Index => All_Other_Names, Src_Index => 0, In_Array => Switches_Array, Shared => Project_Tree.Shared, Force_Lower_Case_Index => True); end if; if Switches = Nil_Variable_Value then Switches := GPR.Util.Value_Of (Index => B_Data.Language_Name, Src_Index => 0, In_Array => Defaults, Shared => Project_Tree.Shared); end if; end; end if; -- If there are binder options, either minimum -- binder options, or in the main project file or -- on the command line, put them in the exchange -- file. if Config.Binder_Required_Switches /= No_Name_List or else Switches.Kind = GPR.List or else not All_Language_Binder_Options.Is_Empty or else Options_Instance /= No_Bind_Option_Table or else Opt.CodePeer_Mode or else (B_Data.Language_Name = Name_Ada and then Opt.No_Main_Subprogram) then Put_Line (Exchange_File, Binding_Label (Gprexch.Binding_Options)); -- First, the required switches, if any declare List : Name_List_Index := Config.Binder_Required_Switches; Elem : Name_Node; begin while List /= No_Name_List loop Elem := Project_Tree.Shared.Name_Lists.Table (List); Get_Name_String (Elem.Name); if Name_Len > 0 then Put_Line (Exchange_File, Name_Buffer (1 .. Name_Len)); end if; List := Elem.Next; end loop; end; -- Then, the eventual options in the main -- project file. if Switches.Kind = GPR.List then declare Option : String_Access; begin Switch_List := Switches.Values; while Switch_List /= Nil_String loop Element := Project_Tree.Shared.String_Elements.Table (Switch_List); Get_Name_String (Element.Value); if Name_Len > 0 then Option := new String' (Name_Buffer (1 .. Name_Len)); Test_If_Relative_Path (Option, Main_Project_Dir.all, No_Name); Put_Line (Exchange_File, Option.all); end if; Switch_List := Element.Next; end loop; end; end if; -- Then -P if in CodePeer mode if Opt.CodePeer_Mode then Put_Line (Exchange_File, "-P"); end if; -- Then those on the command line, for all -- binder drivers, if any. for Option of All_Language_Binder_Options loop Put_Line (Exchange_File, Option); end loop; -- Then -z if specified if B_Data.Language_Name = Name_Ada and then Opt.No_Main_Subprogram then Put_Line (Exchange_File, "-z"); end if; -- Finally those on the command line for the -- binder driver of the language if Options_Instance /= No_Bind_Option_Table then for Option of Options_Instance.all loop Put_Line (Exchange_File, Option); end loop; end if; end if; end; if Build_Script_Name /= null then Put_Line (Exchange_File, Binding_Label (Script_Path) & ASCII.LF & Build_Script_Name.all); end if; -- Finally, the list of the project paths with their -- time stamps. Put_Line (Exchange_File, Binding_Label (Project_Files) & ASCII.LF -- The main project file is always the first one, so that -- gprbind may know the main project dir. & Get_Name_String (Main_Proj.Path.Display_Name) & ASCII.LF & Get_Project_Checkline (Main_Proj)); Proj_List := Main_Proj.All_Imported_Projects; while Proj_List /= null loop if Main_Proj.Standalone_Library = Encapsulated or else not Proj_List.From_Encapsulated_Lib then declare Project : Project_Id := Proj_List.Project; begin while Project.Virtual and then Project.Extends /= No_Project loop Project := Project.Extends; end loop; Put_Line (Exchange_File, Get_Name_String (Project.Path.Display_Name)); Put_Line (Exchange_File, Get_Project_Checkline (Project)); end; end if; Proj_List := Proj_List.Next; end loop; if Main_Source.Unit = No_Unit_Index and then not Dep_Files then Close (Exchange_File); begin Create (Exchange_File, Out_File, Bind_Exchange.all); exception when others => Fail_Program (Project_Tree, "unable to create binder exchange file " & Bind_Exchange.all); end; Put_Line (Exchange_File, Binding_Label (Nothing_To_Bind)); Close (Exchange_File); if Opt.Verbosity_Level > Opt.Low then Put_Line (" -> nothing to bind"); end if; else Close (Exchange_File); if B_Data.Language.Config.Objects_Path /= No_Name then declare Env_Var : constant String := Get_Name_String (B_Data.Language.Config. Objects_Path); Path_Name : String_Access := Main_Proj.Objects_Path; begin if Path_Name = null then if Current_Verbosity = High then Put_Line (Env_Var & " :"); end if; Get_Directories (Project_Tree => Project_Tree, For_Project => Main_Proj, Activity => Executable_Binding, Languages => No_Names); Path_Name := Create_Path_From_Dirs; Main_Proj.Objects_Path := Path_Name; end if; Setenv (Env_Var, Path_Name.all); if Opt.Verbosity_Level > Opt.Low then Put (Env_Var); Put (" = "); Put_Line (Path_Name.all); end if; end; elsif B_Data.Language.Config.Objects_Path_File /= No_Name then declare Env_Var : constant String := Get_Name_String (B_Data.Language.Config. Objects_Path_File); Path_Name : Path_Name_Type := Main_Proj.Objects_Path_File_Without_Libs; begin if Path_Name = No_Path then if Current_Verbosity = High then Put_Line (Env_Var & " :"); end if; Get_Directories (Project_Tree => Project_Tree, For_Project => Main_Proj, Activity => Executable_Binding, Languages => No_Names); declare FD : File_Descriptor; Len : Integer; Status : Boolean; begin GPR.Env.Create_New_Path_File (Shared => Project_Tree.Shared, Path_FD => FD, Path_Name => Main_Proj.Objects_Path_File_Without_Libs); if FD = Invalid_FD then Fail_Program (Project_Tree, "could not create temporary path file"); end if; Path_Name := Main_Proj.Objects_Path_File_Without_Libs; for Index in 1 .. Gpr_Build_Util.Directories.Last loop Get_Name_String (Gpr_Build_Util.Directories.Table (Index)); if Current_Verbosity = High then Put_Line (Name_Buffer (1 .. Name_Len)); end if; Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := ASCII.LF; Len := Write (FD, Name_Buffer (1)'Address, Name_Len); if Len /= Name_Len then Fail_Program (Project_Tree, "disk full"); end if; end loop; Close (FD, Status); if not Status then Fail_Program (Project_Tree, "disk full"); end if; end; end if; Setenv (Env_Var, Get_Name_String (Path_Name)); if Opt.Verbosity_Level > Opt.Low then Put (Env_Var); Put (" = "); Put_Line (Get_Name_String (Path_Name)); end if; end; end if; if not Opt.Quiet_Output then if Opt.Verbose_Mode then Set_Name_Buffer (B_Data.Binder_Driver_Path.all); Add_Str_To_Name_Buffer (" "); Add_Str_To_Name_Buffer (Bind_Exchange.all); Put_Line (Name_Buffer (1 .. Name_Len)); else Display (Section => GPR.Bind, Command => Ada.Directories.Base_Name (Ada.Directories.Simple_Name (B_Data.Binder_Driver_Path.all)), Argument => Bind_Exchange.all); end if; end if; declare Pid : Process_Id; begin Pid := Non_Blocking_Spawn (B_Data.Binder_Driver_Path.all, (1 => Bind_Exchange)); if Pid = Invalid_Pid then Put ("Can't start binder "); Put_Line (B_Data.Binder_Driver_Path.all); Record_Failure (Main_File); else Add_Process (Pid, (Binding, Main_File)); Display_Processes ("bind"); end if; end; end if; end if; end Bind_Language; -------------------------- -- Get_Project_Checksum -- -------------------------- function Get_Project_Checksum (Project : Project_Id) return Message_Digest is procedure Update_Vars (Items : Variable_Id); Chk : Context; Pkg : Package_Id := Project.Decl.Packages; Tbl : Package_Table.Table_Ptr renames Project_Tree.Shared.Packages.Table; ----------------- -- Update_Vars -- ----------------- procedure Update_Vars (Items : Variable_Id) is Vars : Variable_Id := Items; Strs : String_List_Id; Var : Variable; Str : String_Element; begin while Vars /= No_Variable loop Var := Project_Tree.Shared.Variable_Elements.Table (Vars); Update (Chk, Get_Name_String (Var.Name)); case Var.Value.Kind is when Single => Update (Chk, Get_Name_String (Var.Value.Value)); if Var.Value.Index /= 0 then Update (Chk, Var.Value.Index'Img); end if; when List => Strs := Var.Value.Values; while Strs /= Nil_String loop Str := Project_Tree.Shared.String_Elements.Table (Strs); Update (Chk, Get_Name_String (Str.Value)); if Str.Index /= 0 then Update (Chk, Str.Index'Img); end if; Strs := Str.Next; end loop; when Undefined => null; end case; Vars := Var.Next; end loop; end Update_Vars; begin Update_Vars (Project.Decl.Variables); Update_Vars (Project.Decl.Attributes); while Pkg /= No_Package loop Update_Vars (Tbl (Pkg).Decl.Variables); Update_Vars (Tbl (Pkg).Decl.Attributes); Pkg := Tbl (Pkg).Next; end loop; Update (Chk, Hex_Image (Project.Checksum)); return Digest (Chk); end Get_Project_Checksum; -- Start of processing for Post_Compilation_Phase begin -- Build the libraries, if any -- First, get the libraries in building order in table Library_Projs Process_Imported_Libraries (Main_Project, There_Are_SALs => There_Are_Stand_Alone_Libraries, And_Project_Itself => True); if not Library_Projs.Is_Empty then declare Lib_Projs : array (1 .. Library_Projs.Last_Index) of Library_Project; Proj : Library_Project; begin -- Copy the list of library projects in local array Lib_Projs, -- as procedure Build_Library uses table Library_Projs. for J in Lib_Projs'Range loop Lib_Projs (J) := Library_Projs (J); end loop; for J in Lib_Projs'Range loop Proj := Lib_Projs (J); if not Proj.Is_Aggregated then -- Try building a library only if no error occurred in -- library project and projects it depends on. -- Do not actually create the library for aggregate projects -- or in CodePeer mode or when generating C or Java byte -- code, since there is no notion of library is this case, -- only the rest of the processing (creation and compilation -- of binder file in particular, possibly copying ALI files) -- is useful. if not Project_Compilation_Failed (Proj.Proj) then if Proj.Proj.Extended_By = No_Project then if not Proj.Proj.Externally_Built then while Libs_Are_Building.Contains (Proj.Proj.Name) loop Wait_For_Slots_Less_Than (Outstanding_Processes); end loop; Build_Library (Proj.Proj, Project_Tree, No_Create => Proj.Is_Aggregated or else Opt.CodePeer_Mode or else No_Link_Target (Target_Name.all)); exit when Stop_Spawning; end if; if not Is_Static (Proj.Proj) then Shared_Libs := True; end if; end if; end if; end if; end loop; end; end if; -- If no main is specified, there is nothing else to do if Mains.Number_Of_Mains (Project_Tree) = 0 then return; end if; -- Check if there is a need to call a binder driver Find_Binding_Languages (Project_Tree, Main_Project); -- Proceed to bind (or rebind if needed) for each main Mains.Reset; Wait_For_Slots_Less_Than (1); loop declare Main_File : constant Main_Info := Mains.Next_Main; begin exit when Main_File = No_Main_Info; if Main_File.Tree /= Project_Tree or else Project_Compilation_Failed (Main_File.Project) then -- Will be processed later, or do not need any processing in -- the case of compilation errors in the project. null; elsif not Builder_Data (Main_File.Tree).There_Are_Binder_Drivers then if Current_Verbosity = High then Debug_Output ("Post-compilation, no binding required for", Debug_Name (Main_File.Tree)); end if; else declare Main : constant String := Get_Name_String (Main_File.File); Main_Id : constant File_Name_Type := Create_Name (Base_Name (Main)); Main_Base_Name_Index : constant File_Name_Type := Base_Name_Index_For (Main, Main_File.Index, Main_File.Source.Language.Config .Multi_Unit_Object_Separator); Main_Src_Lang_Config_Driver : constant File_Name_Type := Main_File.Source.Language.Config.Compiler_Driver; Main_Proj : constant Project_Id := Ultimate_Extending_Project_Of (Main_File.Source.Project); B_Data : Binding_Data := Builder_Data (Main_File.Tree).Binding; begin while B_Data /= null loop if B_Data.Language.Config.Compiler_Driver /= Empty_File and then Main_Src_Lang_Config_Driver /= Empty_File then Wait_For_Slots_Less_Than (Opt.Maximum_Binders); exit when Stop_Spawning; Change_To_Object_Directory (Main_Proj); Bind_Language (Main_Proj, Main, Main_Base_Name_Index, Main_File, Main_Id, B_Data); exit when Stop_Spawning; end if; B_Data := B_Data.Next; end loop; end; end if; end; end loop; end Post_Compilation_Phase; ------------------------------ -- Wait_For_Slots_Less_Then -- ------------------------------ procedure Wait_For_Slots_Less_Than (Count : Positive) is Data : Process_Data; OK : Boolean; begin while Outstanding_Processes >= Count loop Await_Process (Data, OK); if Data /= No_Process_Data then Libs_Are_Building.Exclude (Data.Main.Project.Name); if OK then Data.Main.Project.Was_Built := True; else Exit_Code := E_Subtool; Record_Failure (Data.Main); end if; end if; Display_Processes ("bind"); end loop; end Wait_For_Slots_Less_Than; end Gprbuild.Post_Compile; gprbuild-25.0.0/src/gprbuild-post_compile.ads000066400000000000000000000031061470075373400212030ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2011-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ package Gprbuild.Post_Compile is procedure Run; -- Build libraries, if needed, and perform binding, if needed. -- This is either for a specific project tree, or for the root project and -- all its aggregated projects. end Gprbuild.Post_Compile; gprbuild-25.0.0/src/gprbuild.adb000066400000000000000000000573301470075373400164770ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2004-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; use Ada.Text_IO; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GPR.Compilation.Slave; use GPR.Compilation.Slave; with GPR.Jobserver; with GPR.Names; use GPR.Names; with GPR.Script; use GPR.Script; package body Gprbuild is package Processed_Projects is new GNAT.HTable.Simple_HTable (Header_Num => GPR.Header_Num, Element => Boolean, No_Element => False, Key => Name_Id, Hash => Hash, Equal => "="); -- Projects that have already been processed ------------------ -- Options_List -- ------------------ function Options_List (Options : Options_Data) return String_Vectors.Vector is Ret : String_Vectors.Vector; begin for Opt of Options loop Ret.Append (Opt.Name); end loop; return Ret; end Options_List; ---------------- -- Add_Option -- ---------------- procedure Add_Option (Value : Name_Id; To : in out Options_Data; Display : Boolean; Simple_Name : Boolean := False) is begin Add_Option (Get_Option (Value), To, Display, Simple_Name); end Add_Option; ---------------- -- Add_Option -- ---------------- procedure Add_Option (Value : String; To : in out Options_Data; Display : Boolean; Simple_Name : Boolean := False) is begin -- For compatibility with gnatmake, do not consider empty options if Value'Length = 0 then return; end if; To.Append (Option_Type' (Name_Len => Value'Length, Name => Value, Displayed => Display, Simple_Name => Simple_Name)); end Add_Option; ---------------------------------- -- Add_Option_Internal_Codepeer -- ---------------------------------- procedure Add_Option_Internal_Codepeer (Value : String; To : in out Options_Data; Display : Boolean; Simple_Name : Boolean := False) is begin if not Opt.CodePeer_Mode or else Value'Length <= 2 or else Value (Value'First .. Value'First + 1) /= "-m" then Add_Option (Value, To, Display, Simple_Name); end if; end Add_Option_Internal_Codepeer; ----------------- -- Add_Options -- ----------------- procedure Add_Options (Value : String_List_Id; To : in out Options_Data; Display_All : Boolean; Display_First : Boolean; Simple_Name : Boolean := False) is List : String_List_Id := Value; Element : String_Element; First_Display : Boolean := Display_First; begin while List /= Nil_String loop Element := Project_Tree.Shared.String_Elements.Table (List); -- Ignore empty options if Element.Value /= Empty_String then Add_Option (Value => Element.Value, To => To, Display => Display_All or First_Display, Simple_Name => Simple_Name); First_Display := False; end if; List := Element.Next; end loop; end Add_Options; ----------------- -- Add_Process -- ----------------- procedure Add_Process (Process : Process_Id; Data : Process_Data) is begin Processes.Insert (Process, Data); Outstanding_Processes := Outstanding_Processes + 1; end Add_Process; -------------------- -- Archive_Suffix -- -------------------- function Archive_Suffix (For_Project : Project_Id) return String is begin if For_Project.Config.Archive_Suffix = No_File then return ".a"; else return Get_Name_String (For_Project.Config.Archive_Suffix); end if; end Archive_Suffix; ------------------- -- Await_Process -- ------------------- procedure Await_Process (Data : out Process_Data; OK : out Boolean) is Pid : Process_Id; CP : Process_Maps.Cursor; begin loop Data := No_Process_Data; Wait_Process (Pid, OK); if Pid = Invalid_Pid then return; end if; CP := Processes.Find (Pid); if Process_Maps.Has_Element (CP) then Data := Process_Maps.Element (CP); Processes.Delete (CP); Outstanding_Processes := Outstanding_Processes - 1; return; end if; end loop; end Await_Process; -------------------------------- -- Change_To_Object_Directory -- -------------------------------- procedure Change_To_Object_Directory (Project : Project_Id; Must_Be_Writable : Boolean := False) is Proj : constant Project_Id := Object_Project (Project, Must_Be_Writable); begin if Proj = No_Project then if Project.Qualifier = Aggregate or else Project.Qualifier = Aggregate_Library then Fail_Program (Project_Tree, "no project with writable object directory for project " & Get_Name_String_Safe (Project.Name), Exit_Code => E_General); else Fail_Program (Project_Tree, "object directory """ & Get_Name_String_Safe (Project.Object_Directory.Display_Name) & """ for project """ & Get_Name_String_Safe (Project.Name) & """ is not writable", Exit_Code => E_General); end if; end if; -- Nothing to do if the current working directory is already the correct -- object directory. if Project_Of_Current_Object_Directory /= Proj then Project_Of_Current_Object_Directory := Proj; -- Set the working directory to the object directory of the actual -- project. Script_Change_Dir (Proj.Object_Directory.Display_Name); Change_Dir (Get_Name_String (Proj.Object_Directory.Display_Name)); if Opt.Verbose_Mode then Put ("Changing to object directory of """); Put (Get_Name_String (Proj.Display_Name)); Put (""": """); Put (Get_Name_String (Proj.Object_Directory.Display_Name)); Put_Line (""""); end if; end if; exception -- Fail if unable to change to the object directory when Directory_Error => Fail_Program (Project_Tree, "unable to change to object directory """ & Get_Name_String (Project.Object_Directory.Display_Name) & """ of project " & Get_Name_String (Project.Display_Name)); end Change_To_Object_Directory; --------------------------- -- Check_Archive_Builder -- --------------------------- procedure Check_Archive_Builder is List : Name_List_Index; begin -- First, make sure that the archive builder (ar) is on the path if Archive_Builder_Path = null then List := Main_Project.Config.Archive_Builder; if List = No_Name_List then Empty_Archive_Builder := True; else Archive_Builder_Name := new String'(Get_Name_String (Project_Tree.Shared.Name_Lists.Table (List).Name)); Archive_Builder_Path := Locate_Exec_On_Path (Archive_Builder_Name.all); if Archive_Builder_Path = null then Fail_Program (Project_Tree, "unable to locate archive builder """ & Archive_Builder_Name.all & '"'); end if; loop List := Project_Tree.Shared.Name_Lists.Table (List).Next; exit when List = No_Name_List; Add_Option (Value => Project_Tree.Shared.Name_Lists.Table (List).Name, To => Archive_Builder_Opts, Display => True); end loop; List := Main_Project.Config.Archive_Builder_Append_Option; while List /= No_Name_List loop Add_Option (Value => Project_Tree.Shared.Name_Lists.Table (List).Name, To => Archive_Builder_Append_Opts, Display => True); List := Project_Tree.Shared.Name_Lists.Table (List).Next; end loop; -- If there is an archive indexer (ranlib), try to locate it on -- the path. Don't fail if it is not found. List := Main_Project.Config.Archive_Indexer; if List /= No_Name_List then Archive_Indexer_Name := new String'(Get_Name_String (Project_Tree.Shared.Name_Lists.Table (List).Name)); Archive_Indexer_Path := Locate_Exec_On_Path (Archive_Indexer_Name.all); if Archive_Builder_Path /= null then loop List := Project_Tree.Shared.Name_Lists.Table (List).Next; exit when List = No_Name_List; Add_Option (Value => Project_Tree.Shared.Name_Lists.Table (List).Name, To => Archive_Indexer_Opts, Display => True); end loop; end if; end if; end if; end if; end Check_Archive_Builder; ----------------------- -- Check_Export_File -- ----------------------- procedure Check_Export_File is begin if Main_Project.Config.Export_File_Switch /= No_Name then Export_File_Switch := new String' (Get_Name_String (Main_Project.Config.Export_File_Switch)); end if; Export_File_Format := Main_Project.Config.Export_File_Format; if Export_File_Switch /= null and then Export_File_Format = None then Fail_Program (Project_Tree, "attribute export_file_format must be defined" & " when export_file_switch is set.", Exit_Code => E_General); end if; end Check_Export_File; ------------------------------- -- Check_Library_Symbol_File -- ------------------------------- procedure Check_Library_Symbol_File is begin if Main_Project.Symbol_Data.Symbol_File /= No_Path then Library_Symbol_File := new String'(Get_Name_String (Main_Project.Symbol_Data.Symbol_File)); end if; end Check_Library_Symbol_File; ------------------------- -- Check_Object_Lister -- ------------------------- procedure Check_Object_Lister is List : Name_List_Index; begin -- First, make sure that the archive builder (nm) is on the path if Object_Lister_Path = null then List := Main_Project.Config.Object_Lister; if List /= No_Name_List then Object_Lister_Name := new String'(Get_Name_String (Project_Tree.Shared.Name_Lists.Table (List).Name)); Object_Lister_Path := Locate_Exec_On_Path (Object_Lister_Name.all); if Object_Lister_Path = null then Fail_Program (Project_Tree, "unable to locate object lister """ & Object_Lister_Name.all & '"'); end if; loop List := Project_Tree.Shared.Name_Lists.Table (List).Next; exit when List = No_Name_List; Add_Option (Value => Project_Tree.Shared.Name_Lists.Table (List).Name, To => Object_Lister_Opts, Display => True); end loop; end if; -- Check object matcher if Main_Project.Config.Object_Lister_Matcher /= No_Name then Object_Lister_Matcher := new String' (Get_Name_String (Main_Project.Config.Object_Lister_Matcher)); end if; if Object_Lister_Path /= null and then Object_Lister_Matcher = null then Fail_Program (Project_Tree, "attribute object_lister_matcher must be defined when" & " object_lister is set.", Exit_Code => E_General); end if; end if; end Check_Object_Lister; --------------------------- -- Create_Path_From_Dirs -- --------------------------- function Create_Path_From_Dirs return String_Access is Result : String_Access; Tmp : String_Access; Path_Last : Natural := 0; begin for Index in 1 .. Directories.Last loop Get_Name_String (Directories.Table (Index)); while Name_Len > 1 and then (Name_Buffer (Name_Len) = Directory_Separator or else Name_Buffer (Name_Len) = '/') loop Name_Len := Name_Len - 1; end loop; if Result = null then Result := new String (1 .. Name_Len); else while Path_Last + Name_Len + 1 > Result'Last loop Tmp := new String (1 .. 2 * Result'Length); Tmp (1 .. Path_Last) := Result (1 .. Path_Last); Free (Result); Result := Tmp; end loop; Path_Last := Path_Last + 1; Result (Path_Last) := Path_Separator; end if; Result (Path_Last + 1 .. Path_Last + Name_Len) := Name_Buffer (1 .. Name_Len); Path_Last := Path_Last + Name_Len; end loop; if Current_Verbosity = High and then Result /= null then Put_Line ("Path=" & Result (1 .. Path_Last)); end if; Tmp := new String'(Result (1 .. Path_Last)); Free (Result); return Tmp; end Create_Path_From_Dirs; ----------------------- -- Display_Processes -- ----------------------- procedure Display_Processes (Name : String) is begin if (if Name = "bind" then Opt.Maximum_Binders elsif Name = "link" then Opt.Maximum_Linkers else Opt.Maximum_Compilers) > 1 and then Opt.Verbose_Mode and then Current_Verbosity = High then Put (" "); Put (Outstanding_Processes'Img); Put (' '); Put (Name); if Outstanding_Processes <= 1 then Put_Line (" process"); else Put_Line (" processes"); end if; end if; end Display_Processes; ---------------- -- Get_Option -- ---------------- function Get_Option (Option : Name_Id) return String renames Get_Name_String; ---------- -- Hash -- ---------- function Hash (Pid : Process_Id) return Ada.Containers.Hash_Type is begin return Ada.Containers.Hash_Type (Pid_To_Integer (Pid)); end Hash; -------------------------------- -- Process_Imported_Libraries -- -------------------------------- procedure Process_Imported_Libraries (For_Project : Project_Id; There_Are_SALs : out Boolean; And_Project_Itself : Boolean := False) is procedure Process_Project (Project : Project_Id; Aggregated : Boolean); -- Process Project and its imported projects recursively. -- Add any library projects to table Library_Projs. --------------------- -- Process_Project -- --------------------- procedure Process_Project (Project : Project_Id; Aggregated : Boolean) is Imported : Project_List := Project.Imported_Projects; begin -- Nothing to do if project has already been processed if not Processed_Projects.Get (Project.Name) then Processed_Projects.Set (Project.Name, True); -- For an extending project, process the project being extended if Project.Extends /= No_Project then Process_Project (Project.Extends, Aggregated => Aggregated); end if; -- We first process the imported projects to guarantee that -- We have a proper reverse order for the libraries. Do not add -- library for encapsulated libraries dependencies except when -- building the encapsulated library itself. Also, do not add -- libraries aggregated from an aggregate library. if For_Project.Standalone_Library = Encapsulated or else Project.Standalone_Library /= Encapsulated then while Imported /= null loop if Imported.Project /= No_Project then Process_Project (Imported.Project, Aggregated => Project.Qualifier = Aggregate_Library); end if; Imported := Imported.Next; end loop; end if; -- If it is a library project, add it to Library_Projs if (And_Project_Itself or else Project /= For_Project) and then Project.Extended_By = No_Project and then Project.Library then if Project.Standalone_Library /= No then There_Are_SALs := True; end if; Library_Projs.Append (Library_Project' (Project, Aggregated and then not Project.Externally_Built)); end if; end if; end Process_Project; -- Start of processing for Process_Imported_Libraries begin Processed_Projects.Reset; Library_Projs.Clear; There_Are_SALs := False; Process_Project (For_Project, Aggregated => False); end Process_Imported_Libraries; ------------------------------------ -- Process_Imported_Non_Libraries -- ------------------------------------ procedure Process_Imported_Non_Libraries (For_Project : Project_Id) is procedure Process_Project (Project : Project_Id); -- Process Project and its imported projects recursively. -- Add any non library project to table Non_Library_Projs. --------------------- -- Process_Project -- --------------------- procedure Process_Project (Project : Project_Id) is Imported : Project_List := Project.Imported_Projects; begin -- Nothing to do if project has already been processed if not Processed_Projects.Get (Project.Name) then Processed_Projects.Set (Project.Name, True); -- Call Process_Project recursively for any imported project. -- We first process the imported projects to guarantee that -- we have a proper reverse order for the libraries. while Imported /= null loop if Imported.Project /= No_Project then Process_Project (Imported.Project); end if; Imported := Imported.Next; end loop; -- For an extending project, process the project being extended if Project.Extends /= No_Project then Process_Project (Project.Extends); end if; -- If it is not a library project, add it to Non_Library_Projs if Project /= For_Project and then Project.Extended_By = No_Project and then not Project.Library then Non_Library_Projs.Append (Project); end if; end if; end Process_Project; -- Start of processing for Process_Imported_Non_Libraries begin Processed_Projects.Reset; Non_Library_Projs.Clear; Process_Project (For_Project); end Process_Imported_Non_Libraries; -------------------- -- Record_Failure -- -------------------- procedure Record_Failure (Main : Main_Info) is begin Bad_Processes.Append (Main); if not Opt.Keep_Going then Stop_Spawning := True; end if; if Exit_Code = E_Success then Exit_Code := Osint.E_Fatal; end if; end Record_Failure; ------------------------ -- Sigint_Intercepted -- ------------------------ procedure Sigint_Intercepted is begin Put_Line ("*** Interrupted ***"); Delete_All_Temp_Files (Project_Tree.Shared); GPR.Jobserver.Unregister_All_Token_Id; if Distributed_Mode then Unregister_Remote_Slaves (From_Signal => True); end if; OS_Exit (2); end Sigint_Intercepted; ----------------------------- -- String_Vector_To_String -- ----------------------------- function String_Vector_To_String (SV : String_Vectors.Vector) return String is begin Name_Len := 0; for S of SV loop Add_Str_To_Name_Buffer (S & " "); end loop; return Name_Buffer (1 .. Name_Len); end String_Vector_To_String; --------------------------- -- Test_If_Relative_Path -- --------------------------- -- ??? TODO: this is so wrong: procedure with a name Test_Something that -- changes the value of what it tests... Shroedinger, please help me, the -- cat doesn't have to die! procedure Test_If_Relative_Path (Switch : in out String_Access; Parent : String; Including_Switch : Name_Id) is Original : constant String (1 .. Switch'Length) := Switch.all; begin if Original (1) = '-' and then Including_Switch /= No_Name then declare Inc_Switch : constant String := Get_Name_String (Including_Switch); begin if Original'Last > Inc_Switch'Last and then Original (1 .. Inc_Switch'Last) = Inc_Switch and then not Is_Absolute_Path (Original (Inc_Switch'Last + 1 .. Original'Last)) then declare Dir : constant String := Parent & Directory_Separator & Original (Inc_Switch'Last + 1 .. Original'Last); begin if Is_Directory (Dir) then Free (Switch); Switch := new String'(Inc_Switch & Dir); end if; end; end if; end; end if; if Original (1) /= '-' and then not Is_Absolute_Path (Original) then declare File : constant String := Parent & Directory_Separator & Original; begin if Is_Regular_File (File) then Free (Switch); Switch := new String'(File); end if; end; end if; end Test_If_Relative_Path; end Gprbuild; gprbuild-25.0.0/src/gprbuild.ads000066400000000000000000000404041470075373400165120ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2004-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ -- The following package implements the facilities to compile, bind and/or -- link a set of Ada and non Ada sources, specified in Project Files. private with Ada.Containers.Hashed_Maps; private with Ada.Containers.Indefinite_Vectors; private with Ada.Containers.Vectors; with GPR; use GPR; with GPR.Osint; use GPR.Osint; private with GNAT.HTable; private with GNAT.OS_Lib; private with Gpr_Build_Util; private with GPR.ALI; private with GPR.Opt; private with GPR.Util; package Gprbuild is -- Everything is private so only accessible to child packages private use Ada.Containers; use Gpr_Build_Util; use GNAT.OS_Lib; use GPR.Util; pragma Warnings (Off); -- Used by children use Stamps; use type ALI.ALI_Id, Opt.Verbosity_Level_Type, Opt.Warning_Mode_Type; pragma Warnings (On); Exit_Code : Osint.Exit_Code_Type := Osint.E_Success; -- Exit code for gprbuild Object_Suffix : constant String := Get_Target_Object_Suffix.all; -- The suffix of object files on this platform Dash_L : Name_Id; -- "-L", initialized in procedure Initialize Main_Project_Dir : String_Access; -- The absolute path of the project directory of the main project, -- initialized in procedure Initialize. Executable_Suffix : constant String_Access := Get_Executable_Suffix; -- The suffix of executables on this platforms Main_Index : Int := 0; Project_Tree : constant Project_Tree_Ref := new Project_Tree_Data (Is_Root_Tree => True); -- The project tree Copyright_Output : Boolean := False; Usage_Output : Boolean := False; -- Flags to avoid multiple displays of Copyright notice and of Usage Usage_Needed : Boolean := False; -- Set by swith -h: usage will be displayed after all command line -- switches have been scanned. Display_Paths : Boolean := False; -- Set by switch --display-paths: config project path and user project path -- will be displayed after all command lines witches have been scanned. Output_File_Name : String_Access := null; -- The name given after a switch -o Output_File_Name_Expected : Boolean := False; -- True when last switch was -o Project_File_Name_Expected : Boolean := False; -- True when last switch was -P Search_Project_Dir_Expected : Boolean := False; -- True when last switch was -aP Object_Checked : Boolean := True; -- False when switch --no-object-check is used. When True, presence of -- the object file and its time stamp are checked to decide if a file needs -- to be compiled. Also set to False when switch --codepeer is used. Map_File : String_Access := null; -- Value of switch --create-map-file Indirect_Imports : Boolean := True; -- False when switch --no-indirect-imports is used. Sources are only -- allowed to import from the projects that are directly withed. Recursive : Boolean := False; Unique_Compile : Boolean := False; -- Set to True if -u or -U or a project file with no main is used Unique_Compile_All_Projects : Boolean := False; -- Set to True if -U is used Always_Compile : Boolean := False; -- Set to True when gprbuid is called with -f -u and at least one source -- on the command line. Builder_Switches_Lang : Name_Id := No_Name; -- Used to decide to what compiler the Builder'Default_Switches that -- are not recognized by gprbuild should be given. No_SAL_Binding : Boolean := False; -- Set to True with gprbuild switch --no-sal-binding All_Language_Builder_Compiling_Options : String_Vectors.Vector; -- Table to store the options for all compilers, that is those that -- follow the switch "-cargs" without any mention of language in the -- Builder switches. All_Language_Compiling_Options : String_Vectors.Vector; -- Table to store the options for all compilers, that is those that -- follow the switch "-cargs" without any mention of language on the -- command line. Builder_Compiling_Options : String_Vectors.Vector; -- Table to store the options for the compilers of the different -- languages, that is those after switch "-cargs:", in the Builder -- switches. Compiling_Options : String_Vectors.Vector; -- Table to store the options for the compilers of the different -- languages, that is those after switch "-cargs:", on the command -- line. Initial_Number_Of_Options : constant Natural := 10; type Option_Type (Name_Len : Natural) is record Name : String (1 .. Name_Len); -- Used to store the argument to be used when spawning a process Displayed : Boolean; -- Indicate if the argument should be displayed when procedure -- Display_Command is called. Simple_Name : Boolean; -- Indicate that the argument is a path name and that only the simple -- name should be displayed. end record; package Option_Vectors is new Ada.Containers.Indefinite_Vectors (Positive, Option_Type); subtype Options_Data is Option_Vectors.Vector; -- Keeps the options of a tool with a boolean for each that -- indicates if it should be displayed. function Options_List (Options : Options_Data) return String_Vectors.Vector; -- Extract all Switches from Option data and return them as a list Compilation_Options : Options_Data; -- The compilation options coming from package Compiler No_Comp_Option_Table : constant String_Vector_Access := null; Current_Comp_Option_Table : String_Vector_Access := No_Comp_Option_Table; No_Builder_Comp_Option_Table : constant String_Vector_Access := null; Cmd_Line_Adc_Files : Name_Id_Maps.Map; -- -gnatec command line option values Cmd_Line_Target_Dep_Info_Files : Name_Id_Maps.Map; -- -gnateT command line option values package Compiling_Options_HTable is new GNAT.HTable.Simple_HTable (Header_Num => GPR.Header_Num, Element => String_Vector_Access, No_Element => No_Comp_Option_Table, Key => Name_Id, Hash => GPR.Hash, Equal => "="); -- A hash table to get the command line compilation option table from the -- language name. package Builder_Compiling_Options_HTable is new GNAT.HTable.Simple_HTable (Header_Num => GPR.Header_Num, Element => String_Vector_Access, No_Element => No_Builder_Comp_Option_Table, Key => Name_Id, Hash => GPR.Hash, Equal => "="); -- A hash table to get the builder compilation option table from the -- language name. All_Language_Binder_Options : String_Vectors.Vector; -- Table to store the options for all binders, that is those that -- follow the switch "-bargs" without any mention of language. Binder_Options : String_Vectors.Vector; -- Tables to store the options for the binders of the different -- languages, that is those after switch "-bargs:". type Bind_Option_Table_Ref is access String_Vectors.Vector; No_Bind_Option_Table : constant Bind_Option_Table_Ref := null; Current_Bind_Option_Table : Bind_Option_Table_Ref := No_Bind_Option_Table; package Binder_Options_HTable is new GNAT.HTable.Simple_HTable (Header_Num => GPR.Header_Num, Element => Bind_Option_Table_Ref, No_Element => No_Bind_Option_Table, Key => Name_Id, Hash => GPR.Hash, Equal => "="); -- A hash table to get the binder option table from the language name Command_Line_Linker_Options : String_Vectors.Vector; -- Table to store the linking options Command_Line_Gprconfig_Options : String_Vectors.Vector; -- Table to store the gprconfig options Project_Of_Current_Object_Directory : Project_Id := No_Project; -- The object directory of the project for the last binding. Avoid -- calling Change_Dir if the current working directory is already this -- directory. -- Archive builder name, path and options Archive_Builder_Name : String_Access := null; Empty_Archive_Builder : Boolean := False; Archive_Builder_Path : String_Access := null; Archive_Builder_Opts : Options_Data; Archive_Builder_Append_Opts : Options_Data; -- Archive indexer name, path and options Archive_Indexer_Name : String_Access := null; Archive_Indexer_Path : String_Access := null; Archive_Indexer_Opts : Options_Data; -- Object lister name and options Object_Lister_Name : String_Access := null; Object_Lister_Path : String_Access := null; Object_Lister_Opts : Options_Data; Object_Lister_Matcher : String_Access; Library_Symbol_File : String_Access; -- Export file Export_File_Switch : String_Access := null; Export_File_Format : GPR.Export_File_Format := GPR.None; -- Rust Linker Helper package Rust_Linker_Helper_Switch_Proj_Map is new Ada.Containers.Hashed_Maps (Key_Type => Name_Id, Element_Type => String_Access, Hash => To_Hash, Equivalent_Keys => "="); Rust_Linker_Helper_Path : String_Access := null; Rust_Linker_Helper_Switch_Map : Rust_Linker_Helper_Switch_Proj_Map.Map; -- Libraries type Library_Project is record Proj : Project_Id; Is_Aggregated : Boolean; end record; package Library_Proj_Vectors is new Ada.Containers.Vectors (Positive, Library_Project); Library_Projs : Library_Proj_Vectors.Vector; -- Library projects imported directly or indirectly Non_Library_Projs : Project_Vectors.Vector; -- Non library projects imported directly or indirectly procedure Add_Option (Value : String; To : in out Options_Data; Display : Boolean; Simple_Name : Boolean := False); procedure Add_Option (Value : Name_Id; To : in out Options_Data; Display : Boolean; Simple_Name : Boolean := False); procedure Add_Options (Value : String_List_Id; To : in out Options_Data; Display_All : Boolean; Display_First : Boolean; Simple_Name : Boolean := False); -- Add one or several options to a list of options. Increase the size -- of the list, if necessary. function Get_Option (Option : Name_Id) return String; -- Get a string access corresponding to Option. Either find the string -- access in the All_Options cache, or create a new entry in All_Options. procedure Test_If_Relative_Path (Switch : in out String_Access; Parent : String; Including_Switch : Name_Id); -- Changes relative paths to absolute paths. When Switch is not a -- switch (it does not start with '-'), then if it is a relative path -- and Parent/Switch is a regular file, then Switch is modified to -- be Parent/Switch. If Switch is a switch (it starts with '-'), -- Including_Switch is not null, Switch starts with Including_Switch -- and the remainder is a relative path, then if Parent/remainder is -- an existing directory, then Switch is modified to have an absolute -- path following Including_Switch. -- Whenever Switch is modified, its previous value is deallocated. procedure Add_Option_Internal (Value : String; To : in out Options_Data; Display : Boolean; Simple_Name : Boolean := False) renames Add_Option; -- Add an option in a specific list of options procedure Add_Option_Internal_Codepeer (Value : String; To : in out Options_Data; Display : Boolean; Simple_Name : Boolean := False); -- Similar to procedure Add_Option_Internal, except that in CodePeer -- mode, options -mxxx are not added. procedure Process_Imported_Libraries (For_Project : Project_Id; There_Are_SALs : out Boolean; And_Project_Itself : Boolean := False); -- Get the imported library project ids in table Library_Projs procedure Process_Imported_Non_Libraries (For_Project : Project_Id); -- Get the imported non library project ids in table Non_Library_Projs function Create_Path_From_Dirs return String_Access; -- Concatenate all directories in the Directories table into a path. -- Caller is responsible for freeing the result procedure Check_Archive_Builder; -- Check if the archive builder (ar) is there procedure Check_Object_Lister; -- Check object lister (nm) is there procedure Check_Export_File; -- Check for export file option and format procedure Check_Library_Symbol_File; -- Check for the library symbol file function Archive_Suffix (For_Project : Project_Id) return String; -- Return the archive suffix for the project, if defined, otherwise -- return ".a". procedure Change_To_Object_Directory (Project : Project_Id; Must_Be_Writable : Boolean := False); -- Change to the object directory of project Project, if this is not -- already the current working directory. If Must_Be_Writable is True and -- the object directory is not writable, fail with an error message. Bad_Processes : Main_Info_Vectors.Vector; -- Info for all the mains where binding fails function String_Vector_To_String (SV : String_Vectors.Vector) return String; -- Use Name_Buffer to return a whitespace-separated string -- from a string vector. Outstanding_Processes : Natural := 0; -- The number of bind jobs currently spawned Stop_Spawning : Boolean := False; -- True when one bind process failed and switch -k was not used procedure Record_Failure (Main : Main_Info); -- Add Main to table Bad_Processes and set Stop_Binding to True if switch -- -k is not used. type Process_Kind is (None, Binding, Linking); type Process_Data is record Kind : Process_Kind := None; Main : Main_Info := No_Main_Info; end record; No_Process_Data : constant Process_Data := (None, No_Main_Info); function Hash (Pid : Process_Id) return Ada.Containers.Hash_Type; -- Used for Process_Htable below package Process_Maps is new Ada.Containers.Hashed_Maps (Key_Type => Process_Id, Element_Type => Process_Data, Hash => Hash, Equivalent_Keys => "="); Processes : Process_Maps.Map; -- Hash table to keep data for all spawned jobs procedure Add_Process (Process : Process_Id; Data : Process_Data); -- Add process in the Process_Htable procedure Await_Process (Data : out Process_Data; OK : out Boolean); -- Wait for the end of a bind job procedure Display_Processes (Name : String); -- When -jnn, -v and -vP2 are used, display the number of currently spawned -- processes. procedure Sigint_Intercepted; pragma Convention (C, Sigint_Intercepted); -- Called when the program is interrupted by Ctrl-C to delete the -- temporary mapping files and configuration pragmas files. function No_Link_Target (Name : String) return Boolean is (Name in "c" | "ccg" | "jvm"); -- Target with this name does not allow linking end Gprbuild; gprbuild-25.0.0/src/gprclean-main.adb000066400000000000000000001036731470075373400174060ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2011-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ -- This package contains the implementation of gprclean. -- See gprclean.adb with Ada.Command_Line; use Ada.Command_Line; with Ada.Exceptions; use Ada.Exceptions; with Ada.Text_IO; use Ada.Text_IO; with GNAT.Case_Util; use GNAT.Case_Util; with GNAT.Command_Line; use GNAT.Command_Line; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.OS_Lib; use GNAT.OS_Lib; with Gpr_Build_Util; use Gpr_Build_Util; with GPR; use GPR; with GPR.Compilation.Slave; use GPR.Compilation; with GPR.Conf; use GPR.Conf; with GPR.Env; with GPR.Err; with GPR.Ext; with GPR.Names; use GPR.Names; with GPR.Opt; use GPR.Opt; with GPR.Osint; with GPR.Proc; use GPR.Proc; with GPR.Snames; with GPR.Tree; use GPR.Tree; with GPR.Util.Aux; use GPR.Util; procedure Gprclean.Main is Project_File_Name_Expected : Boolean := False; Search_Project_Dir_Expected : Boolean := False; User_Project_Node : Project_Node_Id; In_Package_Clean : Boolean := False; -- True when processing switches from package Clean of the main project procedure Usage; -- Display the usage. -- If called several times, the usage is displayed only the first time. procedure Parse_Cmd_Line; -- Parse the command line procedure Process_Switch (Switch : String); -- Process a switch procedure Compute_Clean_Switches; -- Get the switches from package Clean of main project, if any procedure Display_Copyright; -- Display the Copyright notice. If called several times, display the -- Copyright notice only the first time. procedure Initialize; -- Call the necessary package initializations procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage); ----------------------- -- Display_Copyright -- ----------------------- procedure Display_Copyright is begin if not Copyright_Displayed then Copyright_Displayed := True; Display_Version ("GPRCLEAN", "2006"); end if; end Display_Copyright; ---------------------------- -- Compute_Clean_Switches -- ---------------------------- procedure Compute_Clean_Switches is Clean_Package : constant Package_Id := Value_Of (Snames.Name_Clean, Main_Project.Decl.Packages, Project_Tree.Shared); Switches : Variable_Value; List : String_List_Id; Elem : String_Element; begin if Clean_Package /= No_Package then In_Package_Clean := True; Switches := Value_Of (Variable_Name => Snames.Name_Switches, In_Variables => Project_Tree.Shared.Packages.Table (Clean_Package).Decl.Attributes, Shared => Project_Tree.Shared); List := Switches.Values; while List /= Nil_String loop Elem := Project_Tree.Shared.String_Elements.Table (List); Get_Name_String (Elem.Value); Process_Switch (Switch => Name_Buffer (1 .. Name_Len)); List := Elem.Next; end loop; end if; end Compute_Clean_Switches; ---------------- -- Initialize -- ---------------- procedure Initialize is begin if not Initialized then Initialized := True; -- Initialize some packages Snames.Initialize; Set_Program_Name ("gprclean"); GPR.Tree.Initialize (Root_Environment, Gprclean_Flags); GPR.Tree.Initialize (Project_Node_Tree); end if; -- Reset global variables Do_Nothing := False; File_Deleted := False; Copyright_Displayed := False; Usage_Displayed := False; Free (Project_File_Name); Main_Project := GPR.No_Project; All_Projects := False; Mains.Delete; end Initialize; -------------------- -- Parse_Cmd_Line -- -------------------- procedure Parse_Cmd_Line is Last : constant Natural := Argument_Count; Index : Positive := 1; begin -- First deal with --version and --help Check_Version_And_Help ("GPRCLEAN", "2006"); -- Now deal with the other options while Index <= Last loop declare Arg : constant String := Argument (Index); begin if Db_Directory_Expected then Db_Directory_Expected := False; Knowledge.Parse_Knowledge_Base (Project_Tree, Arg); Set_Name_Buffer (Arg); Add_Db_Switch_Arg (Name_Find); elsif Arg'Length /= 0 then if Arg (1) = '-' then Process_Switch (Arg); if Project_File_Name_Expected then if Index = Last then Fail_Program (Project_Tree, "no project specified after -P"); end if; Index := Index + 1; Project_File_Name := new String'(Argument (Index)); Project_File_Name_Expected := False; elsif Search_Project_Dir_Expected then if Index = Last then Fail_Program (Project_Tree, "directory name missing after -aP"); end if; Index := Index + 1; GPR.Env.Add_Directories (Root_Environment.Project_Path, Argument (Index)); Search_Project_Dir_Expected := False; end if; else -- The file name of a main or a project file declare File_Name : String := Arg; begin Osint.Canonical_Case_File_Name (File_Name); if File_Name'Length > Project_File_Extension'Length and then File_Name (File_Name'Last - Project_File_Extension'Length + 1 .. File_Name'Last) = Project_File_Extension then if No_Project_File then Fail_Program (Project_Tree, "cannot specify --no-project" & " with a project file"); elsif Project_File_Name /= null then Fail_Program (Project_Tree, "cannot have several project files specified"); else Project_File_Name := new String'(File_Name); end if; else -- Not a project file, then it is a main Mains.Add_Main (Arg); end if; end; end if; end if; end; Index := Index + 1; end loop; end Parse_Cmd_Line; -------------------- -- Process_Switch -- -------------------- procedure Process_Switch (Switch : String) is pragma Assert (Switch'First = 1); procedure Bad_Switch; -- Signal bad switch and fail ---------------- -- Bad_Switch -- ---------------- procedure Bad_Switch is begin if In_Package_Clean then Fail_Program (Project_Tree, "invalid switch """ & Switch & """ in package Clean"); else Fail_Program (Project_Tree, "invalid switch """ & Switch & '"'); end if; end Bad_Switch; begin if Switch'Length = 1 then Bad_Switch; end if; case Switch (2) is when '-' => if In_Package_Clean then Bad_Switch; elsif Switch = "--db-" then Load_Standard_Base := False; elsif Switch = "--db" then Db_Directory_Expected := True; elsif Switch = No_Project_Option then No_Project_File := True; if Project_File_Name /= null then Fail_Program (Project_Tree, "cannot specify --no-project with a project file"); end if; elsif Switch'Length > Config_Project_Option'Length and then Switch (1 .. Config_Project_Option'Length) = Config_Project_Option then if Config_Project_File_Name /= null and then (Autoconf_Specified or else Config_Project_File_Name.all /= Switch (Config_Project_Option'Length + 1 .. Switch'Last)) then Fail_Program (Project_Tree, "several configuration switches cannot " & "be specified"); else Autoconfiguration := False; Config_Project_File_Name := new String' (Switch (Config_Project_Option'Length + 1 .. Switch'Last)); end if; elsif Switch'Length >= Distributed_Option'Length and then Switch (1 .. Distributed_Option'Length) = Distributed_Option then Distributed_Mode := True; declare Hosts : constant String := Aux.Get_Slaves_Hosts (Project_Tree, Switch); begin if Hosts = "" then Fail_Program (Project_Tree, "missing hosts for distributed" & " mode compilation"); else GPR.Compilation.Slave.Record_Slaves (Hosts); end if; end; elsif Switch'Length >= Slave_Env_Option'Length and then Switch (1 .. Slave_Env_Option'Length) = Slave_Env_Option then if Switch = Slave_Env_Option then -- Just --slave-env, it is up to gprbuild to -- build a sensible slave environment value. Slave_Env_Auto := True; else Slave_Env := new String' (Switch (Slave_Env_Option'Length + 2 .. Switch'Last)); end if; elsif Switch'Length > Autoconf_Project_Option'Length and then Switch (1 .. Autoconf_Project_Option'Length) = Autoconf_Project_Option then if Config_Project_File_Name /= null and then (not Autoconf_Specified or else Config_Project_File_Name.all /= Switch (Autoconf_Project_Option'Length + 1 .. Switch'Last)) then Fail_Program (Project_Tree, "several configuration switches cannot " & "be specified"); else Config_Project_File_Name := new String' (Switch (Autoconf_Project_Option'Length + 1 .. Switch'Last)); Autoconf_Specified := True; end if; elsif Switch'Length > Target_Project_Option'Length and then Switch (1 .. Target_Project_Option'Length) = Target_Project_Option then if Target_Name /= null then if Target_Name.all /= Switch (Target_Project_Option'Length + 1 .. Switch'Last) then Fail_Program (Project_Tree, "several target switches " & "cannot be specified"); end if; else Target_Name := new String' (Switch (Target_Project_Option'Length + 1 .. Switch'Last)); end if; elsif Switch'Length > RTS_Option'Length and then Switch (1 .. RTS_Option'Length) = RTS_Option then declare Set : constant Boolean := Runtime_Name_Set_For (Snames.Name_Ada); Old : constant String := Runtime_Name_For (Snames.Name_Ada); RTS : constant String := Switch (RTS_Option'Length + 1 .. Switch'Last); begin if Set and then Old /= RTS then Fail_Program (Project_Tree, "several different run-times " & "cannot be specified"); end if; Set_Runtime_For (Snames.Name_Ada, RTS); Set_Default_Runtime_For (Snames.Name_Ada, RTS); end; elsif Switch'Length > RTS_Language_Option'Length and then Switch (1 .. RTS_Language_Option'Length) = RTS_Language_Option then declare Language_Name : Name_Id := No_Name; RTS_Start : Natural := Switch'Last + 1; begin for J in RTS_Language_Option'Length + 2 .. Switch'Last loop if Switch (J) = '=' then Set_Name_Buffer (Switch (RTS_Language_Option'Length + 1 .. J - 1)); To_Lower (Name_Buffer (1 .. Name_Len)); Language_Name := Name_Find; RTS_Start := J + 1; exit; end if; end loop; if Language_Name = No_Name then Bad_Switch; else declare RTS : constant String := Switch (RTS_Start .. Switch'Last); Set : constant Boolean := Runtime_Name_Set_For (Language_Name); Old : constant String := Runtime_Name_For (Language_Name); begin if Set and then Old /= RTS then Fail_Program (Project_Tree, "several different run-times cannot" & " be specified for the same language"); else Set_Runtime_For (Language_Name, RTS); Set_Default_Runtime_For (Language_Name, RTS); end if; end; end if; end; elsif Switch'Length > Implicit_With_Option'Length and then Switch (Implicit_With_Option'Range) = Implicit_With_Option then if Implicit_With /= null then Fail_Program (Project_Tree, "several " & Implicit_With_Option & " options cannot be specified"); end if; Implicit_With := new String' (Ensure_Suffix (Switch (Implicit_With_Option'Last + 1 .. Switch'Last), Project_File_Extension)); elsif Switch'Length > Subdirs_Option'Length and then Switch (1 .. Subdirs_Option'Length) = Subdirs_Option then Subdirs := new String' (Switch (Subdirs_Option'Length + 1 .. Switch'Last)); elsif Switch'Length > Src_Subdirs_Option'Length and then Switch (1 .. Src_Subdirs_Option'Length) = Src_Subdirs_Option then Src_Subdirs := new String' (Switch (Src_Subdirs_Option'Length + 1 .. Switch'Last)); elsif Switch'Length >= Relocate_Build_Tree_Option'Length and then Switch (1 .. Relocate_Build_Tree_Option'Length) = Relocate_Build_Tree_Option then if Switch'Length = Relocate_Build_Tree_Option'Length then Build_Tree_Dir := new String'(Get_Current_Dir); else declare Dir : constant String := Ensure_Directory (Switch (Relocate_Build_Tree_Option'Length + 2 .. Switch'Last)); begin if Is_Absolute_Path (Dir) then Build_Tree_Dir := new String'(Dir); else Build_Tree_Dir := new String'(Get_Current_Dir & Dir); end if; end; end if; elsif Switch'Length >= Root_Dir_Option'Length and then Switch (1 .. Root_Dir_Option'Length) = Root_Dir_Option then Root_Dir := new String' (Normalize_Pathname (Switch (Root_Dir_Option'Length + 2 .. Switch'Last), Get_Current_Dir, Resolve_Links => Opt.Follow_Links_For_Dirs) & Dir_Separator); elsif Switch = Gpr_Build_Util.Unchecked_Shared_Lib_Imports then Opt.Unchecked_Shared_Lib_Imports := True; else Bad_Switch; end if; when 'a' => if In_Package_Clean or else Switch'Length < 3 or else Switch (3) /= 'P' then Bad_Switch; end if; if Switch'Length > 3 then GPR.Env.Add_Directories (Root_Environment.Project_Path, Switch (4 .. Switch'Last)); else Search_Project_Dir_Expected := True; end if; when 'c' => if Switch'Length /= 2 then Bad_Switch; end if; Compile_Only := True; when 'e' => if Switch = "-eL" then Follow_Links_For_Files := True; Follow_Links_For_Dirs := True; else Bad_Switch; end if; when 'f' => if Switch'Length /= 2 then Bad_Switch; end if; Force_Deletions := True; Opt.Directories_Must_Exist_In_Projects := False; when 'F' => if Switch'Length /= 2 then Bad_Switch; end if; Full_Path_Name_For_Brief_Errors := True; when 'h' => if Switch'Length /= 2 then Bad_Switch; end if; Display_Copyright; Usage; when 'n' => if Switch'Length /= 2 then Bad_Switch; end if; Do_Nothing := True; when 'p' => if Switch'Length /= 2 then Bad_Switch; end if; Remove_Empty_Dir := True; Opt.Directories_Must_Exist_In_Projects := False; when 'P' => if In_Package_Clean then Bad_Switch; end if; if No_Project_File then Fail_Program (Project_Tree, "cannot specify --no-project with a project file"); elsif Project_File_Name /= null then Fail_Program (Project_Tree, "multiple -P switches"); end if; if Switch'Length > 2 then declare Prj : constant String := Switch (3 .. Switch'Last); begin if Prj'Length > 1 and then Prj (Prj'First) = '=' then Project_File_Name := new String' (Prj (Prj'First + 1 .. Prj'Last)); else Project_File_Name := new String'(Prj); end if; end; else Project_File_Name_Expected := True; end if; when 'q' => if Switch'Length /= 2 then Bad_Switch; end if; if not In_Package_Clean or else not Verbose_Mode then Quiet_Output := True; end if; when 'r' => if Switch'Length /= 2 then Bad_Switch; end if; All_Projects := True; when 'v' => if Switch = "-v" then if not In_Package_Clean or else not Quiet_Output then Verbose_Mode := True; Verbosity_Level := Opt.High; end if; elsif In_Package_Clean then Bad_Switch; elsif Switch = "-vP0" then Current_Verbosity := GPR.Default; elsif Switch = "-vP1" then Current_Verbosity := GPR.Medium; elsif Switch = "-vP2" then Current_Verbosity := GPR.High; else Bad_Switch; end if; when 'X' => if In_Package_Clean then Bad_Switch; end if; if Switch'Length = 2 then Bad_Switch; end if; declare Ext_Asgn : constant String := Switch (3 .. Switch'Last); Start : Positive := Ext_Asgn'First; Stop : Natural := Ext_Asgn'Last; OK : Boolean := True; begin if Ext_Asgn (Start) = '"' then if Ext_Asgn (Stop) = '"' then Start := Start + 1; Stop := Stop - 1; else OK := False; end if; end if; if not OK or else not GPR.Ext.Check (Root_Environment.External, Declaration => Ext_Asgn (Start .. Stop)) then Fail_Program (Project_Tree, "illegal external assignment '" & Ext_Asgn & '''); end if; end; when others => Bad_Switch; end case; end Process_Switch; ----------- -- Usage -- ----------- procedure Usage is begin if not Usage_Displayed then Usage_Displayed := True; Put_Line ("Usage: gprclean [switches] -P {name}"); New_Line; Put_Line (" {name} is zero or more file names"); New_Line; Display_Usage_Version_And_Help; -- Line for --no-project Put_Line (" --no-project"); Put_Line (" Do not use project file"); Put_Line (" --distributed=slave1[,slave2]"); Put_Line (" Activate the remote clean-up"); Put_Line (" --slave-env[=name]"); Put_Line (" Use a specific slave's environment"); Put_Line (" --config=file.cgpr"); Put_Line (" Specify the configuration project file name"); Put_Line (" --autoconf=file.cgpr"); Put_Line (" Specify/create the main config project file name"); Put_Line (" --target=targetname"); Put_Line (" Specify a target for cross platforms"); Put_Line (" --db dir Parse dir as an additional knowledge base"); Put_Line (" --db- Do not load the standard knowledge base"); Put_Line (" --RTS="); Put_Line (" Use runtime for language Ada"); Put_Line (" --RTS:="); Put_Line (" Use runtime for language "); Put_Line (" --relocate-build-tree[=dir]"); Put_Line (" Root obj/lib/exec dirs are current-directory" & " or dir"); Put_Line (" --root-dir=dir"); Put_Line (" Root directory of obj/lib/exec to relocate"); Put_Line (" --src-subdirs=dir"); Put_Line (" Prepend /dir to the list of source dirs" & " for each project"); Put_Line (" --subdirs=dir"); Put_Line (" Use dir as suffix to obj/lib/exec directories"); Put_Line (" " & Gpr_Build_Util.Unchecked_Shared_Lib_Imports); Put_Line (" Shared lib projects may import any project"); New_Line; Put_Line (" -aP dir Add directory dir to project search path"); Put_Line (" -c Only delete compiler generated files"); Put_Line (" -eL Follow symbolic links when processing " & "project files"); Put_Line (" -f Force deletions of unwritable files"); Put_Line (" -F Full project path name " & "in brief error messages"); Put_Line (" -h Display this message"); Put_Line (" -n Nothing to do: only list files to delete"); Put_Line (" -p Remove empty build directories"); Put_Line (" -P Use Project File "); Put_Line (" -q Be quiet/terse"); Put_Line (" -r Clean all projects recursively"); Put_Line (" -v Verbose mode"); Put_Line (" -vPx Specify verbosity when parsing Project Files"); Put_Line (" -Xnm=val Specify an external reference " & "for Project Files"); New_Line; end if; end Usage; begin -- Do the necessary initializations Initialize; -- Add the external variable GPR_TOOL (default value "gprbuild") Add_Gpr_Tool_External; -- Parse the command line, getting the switches and the executable names In_Package_Clean := False; Parse_Cmd_Line; GPR.Env.Initialize_Default_Project_Path (Root_Environment.Project_Path, Target_Name => "-"); if Load_Standard_Base then Knowledge.Parse_Knowledge_Base (Project_Tree); end if; -- If no project file was specified, look first for a default if Project_File_Name = null then Look_For_Default_Project; end if; -- Check that a project file was specified and get the configuration if Project_File_Name = null then Try_Help; Fail_Program (Project_Tree, "no project file specified and no default project file"); end if; -- Check consistency of out-of-tree build options if Root_Dir /= null and then Build_Tree_Dir = null then Fail_Program (Project_Tree, "cannot use --root-dir without --relocate-build-tree option"); end if; if Verbose_Mode then Display_Copyright; end if; if Opt.Verbose_Mode then New_Line; Put ("Parsing Project File """); Put (Project_File_Name.all); Put_Line ("""."); New_Line; end if; -- Check command line arguments. These will be overridden when looking -- for the configuration file if Target_Name = null then Target_Name := new String'(""); end if; if Config_Project_File_Name = null then Config_Project_File_Name := new String'(""); end if; begin Main_Project := No_Project; Parse_Project_And_Apply_Config (Main_Project => Main_Project, User_Project_Node => User_Project_Node, Config_File_Name => Config_Project_File_Name.all, Autoconf_Specified => Autoconf_Specified, Project_File_Name => Project_File_Name.all, Project_Tree => Project_Tree, Project_Node_Tree => Project_Node_Tree, Packages_To_Check => Packages_To_Check, Env => Root_Environment, Allow_Automatic_Generation => Autoconfiguration, Automatically_Generated => Delete_Autoconf_File, Config_File_Path => Configuration_Project_Path, Target_Name => Target_Name.all, Normalized_Hostname => Knowledge.Normalized_Hostname, Implicit_Project => No_Project_File_Found); -- Print warnings that might have occurred while parsing the project GPR.Err.Finalize; -- But avoid duplicate warnings later on GPR.Err.Initialize; exception when E : GPR.Conf.Invalid_Config => Fail_Program (Project_Tree, Exception_Message (E)); end; if Main_Project = No_Project then -- Don't flush messages in case of parsing error. This has already -- been taken care when parsing the tree. Otherwise, it results in -- the same message being displayed twice. Fail_Program (Project_Tree, """" & Project_File_Name.all & """ processing failed", Flush_Messages => Present (User_Project_Node)); end if; -- Get the switches from package Clean of main project, if any Compute_Clean_Switches; -- Even if the config project file has not been automatically -- generated, gprclean will delete it if it was specified using -- --autoconf=. Delete_Autoconf_File := Delete_Autoconf_File or Autoconf_Specified; if Configuration_Project_Path /= null then Free (Config_Project_File_Name); Config_Project_File_Name := new String' (Base_Name (Configuration_Project_Path.all)); end if; if Opt.Verbose_Mode then New_Line; Put ("Parsing of Project File """); Put (Project_File_Name.all); Put (""" is finished."); New_Line; end if; if Main_Project.Qualifier /= Aggregate_Library then Mains.Fill_From_Project (Main_Project, Project_Tree); Mains.Complete_Mains (Root_Environment.Flags, Main_Project, Project_Tree); end if; if Verbose_Mode then New_Line; end if; Processed_Projects.Clear; if Slave_Env = null and then Distributed_Mode then Slave_Env := new String'(Aux.Compute_Slave_Env (Project_Tree, Slave_Env_Auto)); if Slave_Env_Auto and not Opt.Quiet_Output then Put_Line ("slave environment is " & Slave_Env.all); end if; end if; -- Clean-up local build declare procedure Do_Clean (Prj : Project_Id; Tree : Project_Tree_Ref); -- Update sources info and cleanup project tree -------------- -- Do_Clean -- -------------- procedure Do_Clean (Prj : Project_Id; Tree : Project_Tree_Ref) is Iter : Source_Iterator := For_Each_Source (Tree, (if All_Projects then No_Project else Prj)); begin -- Update info on all sources in Tree while GPR.Element (Iter) /= No_Source loop Initialize_Source_Record (GPR.Element (Iter)); Next (Iter); end loop; -- For the main project and all aggregated projects, remove the -- binder and linker generated files. Clean_Project (Prj, Tree, Main => True, Remove_Executables => not Compile_Only); -- Clean-up remote slaves if Distributed_Mode then Slave.Clean_Up_Remote_Slaves (Tree, Prj); end if; end Do_Clean; procedure For_All is new For_Project_And_Aggregated (Do_Clean); begin -- For an aggregate project, we always cleanup all aggregated -- projects, whether "-r" was specified or not. But for those -- projects, we might not clean their imported projects. For_All (Main_Project, Project_Tree); end; if Delete_Autoconf_File and then not Do_Nothing then Delete_Temporary_File (Project_Tree.Shared, Configuration_Project_Path.all); Delete_All_Temp_Files (Project_Tree.Shared); end if; -- Warn if auto-configuration returns a failure status if Problem_During_Auto_Configuration then New_Line; Put_Line ("Cleaning may be incomplete, " & "as there were problems during auto-configuration"); end if; -- In verbose mode, if Delete has not been called, indicate that -- no file needs to be deleted. if Verbose_Mode and not File_Deleted then New_Line; if Do_Nothing then Put_Line ("No file needs to be deleted"); else Put_Line ("No file has been deleted"); end if; end if; end Gprclean.Main; gprbuild-25.0.0/src/gprclean.adb000066400000000000000000001311031470075373400164510ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2006-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ with Ada.Directories; use Ada.Directories; with Ada.Text_IO; use Ada.Text_IO; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.Regexp; use GNAT.Regexp; with Gprexch; use Gprexch; with GPR.Opt; use GPR.Opt; with GPR.Osint; with GPR.Names; use GPR.Names; with GPR.Util; use GPR.Util; package body Gprclean is ----------------------------- -- Other local subprograms -- ----------------------------- procedure Clean_Object_Artifacts (Object : String; Directory : String; Language : Language_Ptr); -- Clean the object artifacts, if any, for object file Object, in directory -- Directory, for the language Language. The current working directory must -- be Directory. procedure Clean_Archive (Project : Project_Id); -- Delete a global archive and its dependency file, if they exist procedure Clean_Temp_Source_Directory (Project : Project_Id; Project_Tree : Project_Tree_Ref; Dir : String); -- Delete files in a given temporary source directory (e.g. interface copy -- directory or specified via --src-subdirs): any file that is a copy of -- a source of the project is delete. procedure Clean_Library_Directory (Project : Project_Id; Project_Tree : Project_Tree_Ref); -- Delete the library file in a library directory and any ALI file -- of a source of the project in a library ALI directory. procedure Delete_Directory (Dir : String); -- Remove directory if it is not empty. -- Issue warning if directoty is not empty or can't be removed in some -- other reason. procedure Delete_Directory (Dir : Path_Information); -- Remove directory if it is defined and not empty. -- If --subdirs parameter is defined and the Dir simple name is equal to -- --subdirs parameter, try to remove the upper level directory too. procedure Delete_Binder_Generated_Files (Main_Project : Project_Id; Project_Tree : Project_Tree_Ref; Dir : String; Source : Source_Id); -- Delete the binder generated file in directory Dir for Source function Ultimate_Extension_Of (Project : Project_Id) return Project_Id; -- Returns either Project, if it is not extended by another project, or -- the project that extends Project, directly or indirectly, and that is -- not itself extended. Returns No_Project if Project is No_Project. ------------------- -- Clean_Archive -- ------------------- procedure Clean_Archive (Project : Project_Id) is Current_Dir : constant Dir_Name_Str := Get_Current_Dir; Archive_Name : constant String := "lib" & Get_Name_String (Project.Name) & Get_Name_String (Project.Config.Archive_Suffix); -- The name of the archive file for this project Archive_Dep_Name : constant String := "lib" & Get_Name_String (Project.Name) & ".deps"; -- The name of the archive dependency file for this project Obj_Dir : constant String := Get_Name_String (Project.Object_Directory.Display_Name); begin if Is_Directory (Obj_Dir) then Change_Dir (Obj_Dir); if Is_Regular_File (Archive_Name) then Delete (Obj_Dir, Archive_Name); end if; if Is_Regular_File (Archive_Dep_Name) then Delete (Obj_Dir, Archive_Dep_Name); end if; Change_Dir (Current_Dir); end if; end Clean_Archive; --------------------------------- -- Clean_Temp_Source_Directory -- --------------------------------- procedure Clean_Temp_Source_Directory (Project : Project_Id; Project_Tree : Project_Tree_Ref; Dir : String) is Current : constant String := Get_Current_Dir; Direc : Dir_Type; Name : String (1 .. 200); Last : Natural; Delete_File : Boolean; Source : GPR.Source_Id; File_Name : File_Name_Type; Iter : Source_Iterator; begin if not Is_Directory (Dir) then return; end if; Change_Dir (Dir); Open (Direc, "."); -- For each regular file in the directory, if switch -n has not -- been specified, make it writable and delete the file if it -- is a copy of a source of the project. loop Read (Direc, Name, Last); exit when Last = 0; if Is_Regular_File (Name (1 .. Last)) then Osint.Canonical_Case_File_Name (Name (1 .. Last)); Name_Len := Last; Name_Buffer (1 .. Name_Len) := Name (1 .. Last); File_Name := Name_Find; Delete_File := False; Iter := For_Each_Source (Project_Tree); loop Source := GPR.Element (Iter); exit when Source = No_Source; if Ultimate_Extension_Of (Source.Project) = Project and then Source.File = File_Name then Delete_File := True; exit; end if; Next (Iter); end loop; if Delete_File then Delete (Dir, Name (1 .. Last)); end if; end if; end loop; Close (Direc); -- Restore the initial working directory Change_Dir (Current); end Clean_Temp_Source_Directory; ----------------------------- -- Clean_Library_Directory -- ----------------------------- procedure Clean_Library_Directory (Project : Project_Id; Project_Tree : Project_Tree_Ref) is Current : constant String := Get_Current_Dir; Lib_Filename : constant String := Get_Name_String (Project.Library_Name); DLL_Name : String := Get_Name_String (Project.Config.Shared_Lib_Prefix) & Lib_Filename & Get_Name_String (Project.Config.Shared_Lib_Suffix); Archive_Name : String := "lib" & Lib_Filename & Get_Name_String (Project.Config.Archive_Suffix); Library_Exchange_File_Name : String := Lib_Filename & Library_Exchange_Suffix; Direc : Dir_Type; Name : String (1 .. 200); Last : Natural; Delete_File : Boolean; begin if Project.Library then Osint.Canonical_Case_File_Name (DLL_Name); Osint.Canonical_Case_File_Name (Archive_Name); Osint.Canonical_Case_File_Name (Library_Exchange_File_Name); declare Obj_Directory : String_Access := null; Lib_Directory : constant String := Get_Name_String (Project.Library_Dir.Display_Name); Lib_ALI_Directory : constant String := Get_Name_String (Project.Library_ALI_Dir.Display_Name); Exchange_File : Ada.Text_IO.File_Type; In_Generated : Boolean; Obj_Proj : constant Project_Id := Object_Project (Project); begin if Obj_Proj /= No_Project and then Obj_Proj.Object_Directory.Display_Name /= No_Path then Obj_Directory := new String' (Get_Name_String (Obj_Proj.Object_Directory.Display_Name)); if Is_Directory (Obj_Directory.all) then Change_Dir (Obj_Directory.all); Open (Direc, "."); -- Look for the library exchange file in the object -- directory. loop Read (Direc, Name, Last); exit when Last = 0; if Is_Regular_File (Name (1 .. Last)) then Osint.Canonical_Case_File_Name (Name (1 .. Last)); exit when Name (1 .. Last) = Library_Exchange_File_Name; end if; end loop; Close (Direc); -- If there is a library exchange file then get the -- generated file names and delete them, then delete -- the library exchange file. if Last > 0 then Ada.Text_IO.Open (Exchange_File, Ada.Text_IO.In_File, Library_Exchange_File_Name); In_Generated := False; while not Ada.Text_IO.End_Of_File (Exchange_File) loop Ada.Text_IO.Get_Line (Exchange_File, Name, Last); if Last > 0 then if Name (1) = '[' then In_Generated := Name (1 .. Last) = Library_Label (Generated_Object_Files) or else Name (1 .. Last) = Library_Label (Generated_Source_Files); elsif In_Generated then if Is_Regular_File (Name (1 .. Last)) then Delete (Obj_Directory.all, Name (1 .. Last)); end if; end if; end if; end loop; Ada.Text_IO.Close (Exchange_File); Delete (Obj_Directory.all, Library_Exchange_File_Name); end if; Change_Dir (Current); end if; end if; if Is_Directory (Lib_Directory) then Change_Dir (Lib_Directory); Open (Direc, "."); -- For each regular file in the directory, if switch -n has not -- been specified, make it writable and delete the file if it -- is the library file. loop Read (Direc, Name, Last); exit when Last = 0; if Is_Regular_File (Name (1 .. Last)) or else Is_Symbolic_Link (Name (1 .. Last)) then Osint.Canonical_Case_File_Name (Name (1 .. Last)); if (Is_Static (Project) and then Name (1 .. Last) = Archive_Name) or else ((Project.Library_Kind = Dynamic or else Project.Library_Kind = Relocatable) and then Name (1 .. Last) = DLL_Name) then Delete (Lib_Directory, Name (1 .. Last)); end if; end if; end loop; Close (Direc); if Project.Config.Symbolic_Link_Supported then if (Project.Library_Kind = Dynamic or else Project.Library_Kind = Relocatable) and then Project.Lib_Internal_Name /= No_Name then declare Lib_Version : String := Get_Name_String (Project.Lib_Internal_Name); begin Osint.Canonical_Case_File_Name (Lib_Version); if Project.Config.Lib_Maj_Min_Id_Supported then declare Maj_Version : String := Major_Id_Name (DLL_Name, Lib_Version); begin if Maj_Version /= "" then Osint.Canonical_Case_File_Name (Maj_Version); Open (Direc, "."); -- For each regular file in the directory, if -- switch -n has not been specified, make it -- writable and delete the file if it is the -- library major version file. loop Read (Direc, Name, Last); exit when Last = 0; if (Is_Regular_File (Name (1 .. Last)) or else Is_Symbolic_Link (Name (1 .. Last))) and then Name (1 .. Last) = Maj_Version then Delete (Lib_Directory, Name (1 .. Last)); end if; end loop; Close (Direc); end if; end; end if; Open (Direc, "."); -- For each regular file in the directory, if switch -- -n has not been specified, make it writable and -- delete the file if it is the library version file. loop Read (Direc, Name, Last); exit when Last = 0; if Is_Regular_File (Name (1 .. Last)) and then Name (1 .. Last) = Lib_Version then Delete (Lib_Directory, Name (1 .. Last)); end if; end loop; Close (Direc); end; end if; end if; Change_Dir (Current); end if; if Is_Directory (Lib_ALI_Directory) then Change_Dir (Lib_ALI_Directory); Open (Direc, "."); -- For each regular file in the directory, if switch -n has not -- been specified, make it writable and delete the file if it -- is any dependency file of a source of the project. loop Read (Direc, Name, Last); exit when Last = 0; if Is_Regular_File (Name (1 .. Last)) then Osint.Canonical_Case_File_Name (Name (1 .. Last)); Delete_File := False; if Last > 4 and then Name (Last - 3 .. Last) = ".ali" then declare Source : GPR.Source_Id; Iter : Source_Iterator; Proj : Project_Id := Project; begin Project_Loop : loop if Proj.Qualifier = Aggregate_Library then Iter := For_Each_Source (Project_Tree); else Iter := For_Each_Source (Project_Tree, Proj); end if; loop Source := GPR.Element (Iter); exit when Source = No_Source; if Source.Dep_Name /= No_File and then Get_Name_String (Source.Dep_Name) = Name (1 .. Last) then Delete_File := True; exit Project_Loop; end if; Next (Iter); end loop; exit Project_Loop when Proj.Extends = No_Project; Proj := Proj.Extends; end loop Project_Loop; end; end if; if Delete_File then Delete (Lib_ALI_Directory, Name (1 .. Last)); end if; end if; end loop; Close (Direc); -- Restore the initial working directory Change_Dir (Current); end if; end; end if; end Clean_Library_Directory; ---------------------------- -- Clean_Object_Artifacts -- ---------------------------- procedure Clean_Object_Artifacts (Object : String; Directory : String; Language : Language_Ptr) is Last : Natural := Object'Last; List : Name_List_Index := Language.Config.Clean_Object_Artifacts; Node : Name_Node; begin while Last > 0 and then Object (Last) /= '.' loop Last := Last - 1; end loop; if Last = 0 then Last := Object'Last + 1; end if; while List /= No_Name_List loop Node := Project_Tree.Shared.Name_Lists.Table (List); declare Artifact : constant String := Object (Object'First .. Last - 1) & Get_Name_String (Node.Name); begin if Is_Regular_File (Artifact) then Delete (Directory, Artifact); end if; end; List := Node.Next; end loop; end Clean_Object_Artifacts; -- Artifacts type Artifact_Array_Type is array (Positive range <>) of GNAT.Regexp.Regexp; type Artifact_Array_Ptr is access Artifact_Array_Type; Artifacts : Artifact_Array_Ptr := new Artifact_Array_Type (1 .. 4); -- List of regular expression file names to be deleted in procedure -- Clean_Artifacts below. Size 4 is arbitrary. Artifact_Last : Natural := 0; -- Last index of the valid artifacts in array Artifacts. ------------------- -- Clean_Project -- ------------------- procedure Clean_Project (Project : Project_Id; Project_Tree : Project_Tree_Ref; Main : Boolean; Remove_Executables : Boolean) is Executable : File_Name_Type; -- Name of the executable file Current_Dir : constant Dir_Name_Str := Get_Current_Dir; Project2 : Project_Id; Source_Id : GPR.Source_Id; Partial_Number : Natural; List : Name_List_Index := No_Name_List; Node : Name_Node; procedure Clean_Artifacts (Dir : String; List : Name_List_Index); -- Clean the artifacts specified by List in directory Dir. -- The current directory is Dir. function Is_Regexp (Name : String) return Boolean; -- Return True iff Name is a glob regexp. --------------------- -- Clean_Artifacts -- --------------------- procedure Clean_Artifacts (Dir : String; List : Name_List_Index) is Lst : Name_List_Index := List; Nod : Name_Node; begin Artifact_Last := 0; while Lst /= No_Name_List loop Nod := Project_Tree.Shared.Name_Lists.Table (Lst); declare Name : constant String := Get_Name_String (Nod.Name); begin if Is_Regexp (Name) then if Artifact_Last = Artifacts'Length then declare New_Artifacts : constant Artifact_Array_Ptr := new Artifact_Array_Type (1 .. 2 * Artifact_Last); begin New_Artifacts (1 .. Artifact_Last) := Artifacts (1 .. Artifact_Last); Artifacts := New_Artifacts; end; end if; Artifact_Last := Artifact_Last + 1; Artifacts (Artifact_Last) := Compile (Name, Glob => True); elsif Is_Regular_File (Name) then Delete (Dir, Name); end if; end; Lst := Nod.Next; end loop; if Artifact_Last > 0 then declare Directory : Dir_Type; File_Name : Dir_Name_Str (1 .. 1_000); Last : Natural; begin Open (Directory, Dir); Directory_Loop : loop Read (Directory, File_Name, Last); exit Directory_Loop when Last = 0; if Is_Regular_File (File_Name (1 .. Last)) then Artifact_Loop : for J in 1 .. Artifact_Last loop if Match (File_Name (1 .. Last), Artifacts (J)) then Delete (Dir, File_Name (1 .. Last)); exit Artifact_Loop; end if; end loop Artifact_Loop; end if; end loop Directory_Loop; Close (Directory); end; end if; end Clean_Artifacts; --------------- -- Is_Regexp -- --------------- function Is_Regexp (Name : String) return Boolean is begin for J in Name'Range loop case Name (J) is when '?' | '*' | '[' | '{' => return True; when others => null; end case; end loop; return False; end Is_Regexp; begin -- Check that we don't specify executable on the command line for -- a main library project. if Project = Main_Project and then Mains.Number_Of_Mains (null) /= 0 and then Project.Library then Fail_Program (Project_Tree, "Cannot specify executable(s) for a Library Project File"); end if; -- Add project to the list of processed projects Processed_Projects.Append (Project); -- Nothing to clean in an externally built project if Project.Externally_Built then if Verbose_Mode then Put ("Nothing to do to clean externally built project """); Put (Get_Name_String (Project.Name)); Put_Line (""""); end if; return; else if Verbose_Mode then Put ("Cleaning project """); Put (Get_Name_String (Project.Name)); Put_Line (""""); end if; if Project.Object_Directory /= No_Path_Information and then Is_Directory (Get_Name_String (Project.Object_Directory.Display_Name)) then declare Obj_Dir : constant String := Get_Name_String (Project.Object_Directory.Display_Name); Iter : Source_Iterator; begin Change_Dir (Obj_Dir); -- For non library project, clean the global archive and its -- dependency file if they exist. -- Also, if the project hierarchy includes static SALs, clean -- the artifacts related to linker options extraction. if not Project.Library then Clean_Archive (Project); -- Also clean artifacts declare Imported : Project_List := Project.All_Imported_Projects; begin while Imported /= null loop if Imported.Project /= No_Project and then Imported.Project.Standalone_Library /= No then declare Lib_Name : constant String := Get_Name_String (Imported.Project.Library_Name); Link_Opt : constant String := Lib_Name & ".linker_options"; Partial : constant String := Partial_Name (Lib_Name, 0, Object_Suffix); Binder : constant String := "b__" & Lib_Name & Object_Suffix; begin if Is_Regular_File (Link_Opt) then Delete (Obj_Dir, Link_Opt); end if; if Is_Regular_File (Partial) then Delete (Obj_Dir, Partial); end if; if Is_Regular_File (Binder) then Delete (Obj_Dir, Binder); end if; end; end if; Imported := Imported.Next; end loop; end; end if; -- For a library project, clean the partially link objects, if -- there are some. if Project.Library then Partial_Number := 0; loop declare Partial : constant String := Partial_Name (Get_Name_String (Project.Library_Name), Partial_Number, Object_Suffix); begin if Is_Regular_File (Partial) then Delete (Obj_Dir, Partial); Partial_Number := Partial_Number + 1; else exit; end if; end; end loop; -- For a static SAL, clean the .linker_options file which -- exists if the latest build was done in "keep temp files" -- mode. if Project.Standalone_Library /= No and then Project.Library_Kind = Static then declare Link_Opt_File : constant String := Get_Name_String (Project.Library_Name) & ".linker_options"; begin if Is_Regular_File (Link_Opt_File) then Delete (Obj_Dir, Link_Opt_File); end if; end; end if; end if; -- Check all the object file for the sources of the current -- project and all the projects it extends. Project2 := Project; while Project2 /= No_Project loop -- Delete the object files, the dependency files, the -- switches files if they exist. Also additional artifacts -- if they are any. Iter := For_Each_Source (Project_Tree, Project2); loop Source_Id := GPR.Element (Iter); exit when Source_Id = No_Source; if Source_Id.Object /= No_File and then Is_Regular_File (Get_Name_String (Source_Id.Object)) then Delete (Obj_Dir, Get_Name_String (Source_Id.Object)); -- Clean object artifacts, if any Clean_Object_Artifacts (Object => Get_Name_String (Source_Id.Object), Directory => Obj_Dir, Language => Source_Id.Language); end if; if Source_Id.Dep_Name /= No_File and then Is_Regular_File (Get_Name_String (Source_Id.Dep_Name)) then Delete (Obj_Dir, Get_Name_String (Source_Id.Dep_Name)); end if; if Source_Id.Switches /= No_File and then Is_Regular_File (Get_Name_String (Source_Id.Switches)) then Delete (Obj_Dir, Get_Name_String (Source_Id.Switches)); end if; -- Clean .stdout declare Artifact : constant String := Get_Name_String (Source_Id.File) & ".stdout"; begin if Is_Regular_File (Artifact) then Delete (Obj_Dir, Artifact); end if; end; -- Clean .stderr declare Artifact : constant String := Get_Name_String (Source_Id.File) & ".stderr"; begin if Is_Regular_File (Artifact) then Delete (Obj_Dir, Artifact); end if; end; -- Clean tree files declare Artifact : constant String := Get_Name_String (Extend_Name (Source_Id.File, ".adt")); begin if Is_Regular_File (Artifact) then Delete (Obj_Dir, Artifact); end if; end; -- Clean source artifacts, if any List := Source_Id.Language.Config.Clean_Source_Artifacts; while List /= No_Name_List loop Node := Project_Tree.Shared.Name_Lists.Table (List); declare Artifact : constant String := Get_Name_String (Source_Id.File) & Get_Name_String (Node.Name); begin if Is_Regular_File (Artifact) then Delete (Obj_Dir, Artifact); end if; end; List := Node.Next; end loop; Next (Iter); end loop; Project2 := Project2.Extends; end loop; -- Clean the artifacts in object directory, if any. Do this -- after cleaning the object files, to avoid checking every -- object file when the artifacts are given as a regexp. Clean_Artifacts (Obj_Dir, Project.Config.Artifacts_In_Object_Dir); -- Also clean source files under Src_Subdirs if set, unless -- -c was specified. if Src_Subdirs /= null and then not Compile_Only then Clean_Temp_Source_Directory (Project, Project_Tree, Obj_Dir & Src_Subdirs.all); end if; end; end if; -- If this is a library project, clean the library directory, the -- interface copy dir and, for a Stand-Alone Library, the binder -- generated files of the library. -- The directories are cleaned only if switch -c is not specified if Project.Library and then not Compile_Only then Clean_Library_Directory (Project, Project_Tree); if Project.Library_Src_Dir /= No_Path_Information then Clean_Temp_Source_Directory (Project, Project_Tree, Get_Name_String (Project.Library_Src_Dir.Name)); end if; end if; if Verbose_Mode then New_Line; end if; end if; -- If switch -r is specified, call Clean_Project recursively for the -- imported projects and the project being extended. if All_Projects then declare Imported : Project_List := Project.Imported_Projects; begin -- For each imported project, call Clean_Project if the project -- has not been processed already. while Imported /= null loop if not Processed_Projects.Contains (Imported.Project) then Clean_Project (Imported.Project, Project_Tree, False, False); end if; Imported := Imported.Next; end loop; -- If this project extends another project, call Clean_Project for -- the project being extended. It is guaranteed that it has not -- called before, because no other project may import or extend -- this project. if Project.Extends /= No_Project then Clean_Project (Project.Extends, Project_Tree, False, False); end if; end; end if; -- For the main project, delete the executables and the binder generated -- files. -- The executables are deleted only if switch -c is not specified if Main and then Project.Exec_Directory /= No_Path_Information and then Is_Directory (Get_Name_String (Project.Exec_Directory.Display_Name)) then declare Exec_Dir : constant String := Get_Name_String (Project.Exec_Directory.Display_Name); Main_File : Main_Info; begin Change_Dir (Exec_Dir); -- Clean the artifacts in the exec dir, if any Clean_Artifacts (Exec_Dir, Project.Config.Artifacts_In_Exec_Dir); Mains.Reset; loop Main_File := Mains.Next_Main; exit when Main_File = No_Main_Info; if Main_File.Tree = Project_Tree then if Remove_Executables and then Main_File.Source /= No_Source then Executable := Executable_Of (Project => Project, Shared => Project_Tree.Shared, Main => Main_File.File, Index => Main_File.Index, Language => Get_Name_String (Main_File.Source.Language.Name)); declare Exec_File_Name : constant String := Get_Name_String (Executable); begin if Is_Absolute_Path (Name => Exec_File_Name) then if Is_Regular_File (Exec_File_Name) then Delete ("", Exec_File_Name); end if; else if Is_Regular_File (Exec_File_Name) then Delete (Exec_Dir, Exec_File_Name); end if; end if; end; end if; -- Delete the binder generated files only if the main source -- has been found and if there is an object directory. if Main_File.Source /= No_Source and then Project.Object_Directory /= No_Path_Information and then Is_Directory (Get_Name_String (Project.Object_Directory.Display_Name)) then Delete_Binder_Generated_Files (Project, Project_Tree, Get_Name_String (Project.Object_Directory.Display_Name), Main_File.Source); end if; end if; end loop; end; end if; -- Change back to previous directory Change_Dir (Current_Dir); if Remove_Empty_Dir then declare procedure Delete_If_Not_Project (Dir : Path_Information); -- Delete the directory if it is not the directory where the -- project is resided. procedure Delete_If_Not_Project (Dir : Path_Information) is begin if Dir /= Project.Directory then Delete_Directory (Dir); end if; end Delete_If_Not_Project; begin Delete_If_Not_Project (Project.Object_Directory); if Project.Exec_Directory /= Project.Object_Directory then Delete_If_Not_Project (Project.Exec_Directory); end if; Delete_If_Not_Project (Project.Library_Dir); if Project.Library_Dir /= Project.Library_ALI_Dir then Delete_If_Not_Project (Project.Library_ALI_Dir); end if; Delete_If_Not_Project (Project.Library_Src_Dir); end; end if; end Clean_Project; ------------ -- Delete -- ------------ procedure Delete (In_Directory : String; File : String) is Full_Name : String (1 .. In_Directory'Length + File'Length + 1); Last : Natural := 0; Success : Boolean; begin -- Indicate that at least one file is deleted or is to be deleted File_Deleted := True; -- Build the path name of the file to delete Last := In_Directory'Length; Full_Name (1 .. Last) := In_Directory; if Last > 0 and then Full_Name (Last) /= Directory_Separator then Last := Last + 1; Full_Name (Last) := Directory_Separator; end if; Full_Name (Last + 1 .. Last + File'Length) := File; Last := Last + File'Length; -- If switch -n was used, simply output the path name if Do_Nothing then Put_Line (Full_Name (1 .. Last)); return; end if; -- Otherwise, delete the file if it is writable or after making it -- writable if forced deletions are requested. if Is_Writable_File (Full_Name (1 .. Last)) then Delete_File (Full_Name (1 .. Last), Success); elsif Force_Deletions then Set_Writable (Full_Name (1 .. Last)); Delete_File (Full_Name (1 .. Last), Success); else Success := False; end if; if not Success then if not Quiet_Output then Put ("Warning: """); Put (Full_Name (1 .. Last)); Put_Line (""" could not be deleted"); end if; elsif Verbose_Mode then Put (""""); Put (Full_Name (1 .. Last)); Put_Line (""" has been deleted"); end if; end Delete; ---------------------- -- Delete_Directory -- ---------------------- procedure Delete_Directory (Dir : Path_Information) is begin if Dir /= No_Path_Information then declare Folder : constant String := Get_Name_String (Dir.Display_Name); Last : Natural := Folder'Last; begin Delete_Directory (Folder); if Subdirs /= null then -- If subdirs is defined try to remove the parent one if GPR.Osint.Is_Directory_Separator (Folder (Last)) then Last := Last - 1; end if; if Simple_Name (Folder (1 .. Last)) = Subdirs.all then Delete_Directory (Containing_Directory (Folder (1 .. Last))); end if; end if; end; end if; end Delete_Directory; procedure Delete_Directory (Dir : String) is Search : Search_Type; begin if Is_Directory (Dir) then Remove_Dir (Dir); end if; exception when Directory_Error => if not Quiet_Output then Start_Search (Search, Dir, ""); Put_Line ("warning: Directory """ & Dir & """ could not be removed" & (if More_Entries (Search) then " because it is not empty" else "") & '.'); end if; end Delete_Directory; ----------------------------------- -- Delete_Binder_Generated_Files -- ----------------------------------- procedure Delete_Binder_Generated_Files (Main_Project : Project_Id; Project_Tree : Project_Tree_Ref; Dir : String; Source : Source_Id) is Data : constant Builder_Data_Access := Builder_Data (Project_Tree); Current : constant String := Get_Current_Dir; B_Data : Binding_Data; Base_Name : File_Name_Type; begin Find_Binding_Languages (Project_Tree, Main_Project); if Data.There_Are_Binder_Drivers then -- Get the main base name Base_Name := Base_Name_Index_For (Get_Name_String (Source.File), Source.Index, '~'); -- Work in the object directory Change_Dir (Dir); B_Data := Data.Binding; while B_Data /= null loop declare File_Name : constant String := Binder_Exchange_File_Name (Base_Name, B_Data.Binder_Prefix).all; File : Ada.Text_IO.File_Type; Line : String (1 .. 1_000); Last : Natural; Section : Binding_Section := No_Binding_Section; begin if Is_Regular_File (File_Name) then Ada.Text_IO.Open (File, Ada.Text_IO.In_File, File_Name); while not Ada.Text_IO.End_Of_File (File) loop Ada.Text_IO.Get_Line (File, Line, Last); if Last > 0 then if Line (1) = '[' then Section := Get_Binding_Section (Line (1 .. Last)); else case Section is when Generated_Object_File | Generated_Source_Files => if Is_Regular_File (Line (1 .. Last)) then Delete (Dir, Line (1 .. Last)); if Section = Generated_Object_File then Clean_Object_Artifacts (Object => Line (1 .. Last), Directory => Dir, Language => B_Data.Language); end if; end if; when others => null; end case; end if; end if; end loop; Ada.Text_IO.Close (File); Delete (Dir, File_Name); end if; end; B_Data := B_Data.Next; end loop; -- Change back to previous directory Change_Dir (Current); end if; end Delete_Binder_Generated_Files; --------------------------- -- Ultimate_Extension_Of -- --------------------------- function Ultimate_Extension_Of (Project : Project_Id) return Project_Id is Result : Project_Id := Project; begin if Project /= No_Project then loop exit when Result.Extended_By = No_Project; Result := Result.Extended_By; end loop; end if; return Result; end Ultimate_Extension_Of; end Gprclean; gprbuild-25.0.0/src/gprclean.ads000066400000000000000000000074241470075373400165020ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2006-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ -- This package contains the implementation of gprclean. -- See gprclean.adb with GNAT.OS_Lib; use GNAT.OS_Lib; with GPR; use GPR; with Gpr_Build_Util; use Gpr_Build_Util; package Gprclean is -- Everything is private so only accessible to child packages private Object_Suffix : constant String := Get_Target_Object_Suffix.all; -- The suffix of object files on this platform Initialized : Boolean := False; -- Set to True by the first call to Initialize. -- To avoid reinitialization of some packages. Project_Tree : constant Project_Tree_Ref := new Project_Tree_Data (Is_Root_Tree => True); -- The project tree Force_Deletions : Boolean := False; -- Set to True by switch -f. When True, attempts to delete non writable -- files will be done. Do_Nothing : Boolean := False; -- Set to True when switch -n is specified. When True, no file is deleted. -- gnatclean only lists the files that would have been deleted if the -- switch -n had not been specified. Remove_Empty_Dir : Boolean := False; -- Set to True when switch -p is specified. When True, the empty directory -- where the artefact files was deleted will be deleted too. File_Deleted : Boolean := False; -- Set to True if at least one file has been deleted Copyright_Displayed : Boolean := False; Usage_Displayed : Boolean := False; -- Flags set to True when the action is performed, to avoid duplicate -- displays. All_Projects : Boolean := False; -- Set to True when option -r is used, so that all projects in the project -- tree are cleaned. Processed_Projects : Project_Vectors.Vector; -- Table to keep track of what project files have been processed, when -- switch -r is specified. procedure Clean_Project (Project : Project_Id; Project_Tree : Project_Tree_Ref; Main : Boolean; Remove_Executables : Boolean); -- Do the cleaning work for Project. -- This procedure calls itself recursively when there are several -- project files in the tree rooted at the main project file and switch -r -- has been specified. -- Main is True iff Project is a main project. -- If Remove_Executables is true, the binder files and results of the -- linker are also removed. procedure Delete (In_Directory : String; File : String); -- Delete one file, or list the file name if switch -n is specified end Gprclean; gprbuild-25.0.0/src/gprconfig-main.adb000066400000000000000000000532771470075373400175750ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2006-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; with Ada.Containers; use Ada.Containers; with Ada.Exceptions; use Ada.Exceptions; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with Ada.Text_IO; use Ada.Text_IO; with GNAT.Command_Line; use GNAT.Command_Line; with GNAT.OS_Lib; use GNAT.OS_Lib; with GPR.Knowledge; use GPR.Knowledge; with GPR; use GPR; with GPR.Names; use GPR.Names; with GPR.Opt; with GPR.Sdefault; with GPR.Util; procedure GprConfig.Main is Output_File : Unbounded_String := To_Unbounded_String (GPR.Util.Default_Config_Name); -- Init with name of the configuration file used by gprbuild by default Selected_Targets_Set : Targets_Set_Id; -- Targets set id for the selected target Opt_Validate : Boolean := False; -- Whether we should validate the contents of the knowledge base use Compiler_Lists; procedure Help (Base : Knowledge_Base); -- Display list of switches procedure Usage; -- Display list of options, no specific to current invocation, to be used -- when switch --help is used. procedure Check_Version_And_Help is new Util.Check_Version_And_Help_G (Usage); procedure Display_Compilers_For_Parser (Base : in out Knowledge_Base; Compilers : in out Compiler_Lists.List); -- Display the list of found compilers for use by an external parser procedure Select_Compilers_Interactively (Base : in out Knowledge_Base; Compilers : in out Compiler_Lists.List); -- Ask the user for compilers to be selected procedure Show_Command_Line_Config (Compilers : Compiler_Lists.List); -- Display the batch command line that would have the same effect as the -- current selection of compilers. type Boolean_Array is array (Count_Type range <>) of Boolean; type All_Iterator (Count : Count_Type) is new Compiler_Iterator with record Filter_Matched : Boolean_Array (1 .. Count) := (others => False); Filters : Compiler_Lists.List; Compilers : Compiler_Lists.List; end record; procedure Callback (Iterator : in out All_Iterator; Base : in out Knowledge_Base; Comp : Compiler; Runtime_Specified : Boolean; From_Extra_Dir : Boolean; Continue : out Boolean); -- Search all compilers on path, preselecting the first one matching each -- of the filters. Base : Knowledge_Base; Filters : Compiler_Lists.List; Load_Standard_Base : Boolean := True; Batch : Boolean := False; Show_Targets : Boolean := False; Show_Compilers : Boolean := False; Compilers : Compiler_Lists.List; package Compiler_Sort is new Compiler_Lists.Generic_Sorting (Display_Before); Valid_Switches : constant String := "-batch -config= -db: h o: v q -show-targets" & " -validate -mi-show-compilers -target= " & "-fallback-targets"; -------------- -- Callback -- -------------- procedure Callback (Iterator : in out All_Iterator; Base : in out Knowledge_Base; Comp : Compiler; Runtime_Specified : Boolean; From_Extra_Dir : Boolean; Continue : out Boolean) is New_Comp : Compiler := Comp; C : Compiler_Lists.Cursor; Index : Count_Type := 1; begin -- Do nothing if a runtime needs to be specified, as this is only for -- interactive use. if not Runtime_Specified then if Iterator.Filter_Matched /= (Iterator.Filter_Matched'Range => True) then C := First (Iterator.Filters); while Has_Element (C) loop if not Iterator.Filter_Matched (Index) and then Filter_Match (Base, Comp => Comp, Filter => Element (C).all) then Set_Selection (New_Comp, True); Iterator.Filter_Matched (Index) := True; exit; end if; Index := Index + 1; Next (C); end loop; end if; -- Ignore compilers from extra directories, unless they have been -- selected because of a --config argument if Is_Selected (New_Comp) or else not From_Extra_Dir then Put_Verbose ("Adding compiler to interactive menu " & To_String (Base, Comp, True) & " selected=" & Is_Selected (New_Comp)'Img); Append (Iterator.Compilers, new Compiler'(New_Comp)); end if; end if; Continue := True; end Callback; ---------- -- Help -- ---------- procedure Help (Base : Knowledge_Base) is Known : Unbounded_String; begin Known_Compiler_Names (Base, Known); Usage; Put_Line (" The known compilers are: " & To_String (Known)); end Help; ---------------------------------- -- Display_Compilers_For_Parser -- ---------------------------------- procedure Display_Compilers_For_Parser (Base : in out Knowledge_Base; Compilers : in out Compiler_Lists.List) is Comp : Compiler_Lists.Cursor := First (Compilers); Count : constant Integer := Integer (Length (Compilers)); Choices : array (1 .. Count) of Compiler_Lists.Cursor; begin for C in Choices'Range loop Choices (C) := Comp; Next (Comp); end loop; Filter_Compilers_List (Base, Compilers, Selected_Targets_Set); Put (To_String (Base, Compilers, Selected_Only => False, Show_Target => True, Parser_Friendly => True)); end Display_Compilers_For_Parser; ------------------------------------ -- Select_Compilers_Interactively -- ------------------------------------ procedure Select_Compilers_Interactively (Base : in out Knowledge_Base; Compilers : in out Compiler_Lists.List) is Comp : Compiler_Lists.Cursor := First (Compilers); Tmp : Natural; Choice : Natural; Line : String (1 .. 1024); Count : constant Integer := Integer (Length (Compilers)); Choices : array (1 .. Count) of Compiler_Lists.Cursor; begin for C in Choices'Range loop Choices (C) := Comp; Next (Comp); end loop; loop Filter_Compilers_List (Base, Compilers, Selected_Targets_Set); Put_Line ("--------------------------------------------------"); Put_Line ("gprconfig has found the following compilers on your PATH."); Put_Line ("Only those matching the target and the selected compilers" & " are displayed."); Put (To_String (Base, Compilers, Selected_Only => False, Show_Target => Selected_Targets_Set = All_Target_Sets)); Put ("Select or unselect the following compiler (or ""s"" to save): "); Get_Line (Line, Tmp); exit when Tmp = 1 and then Line (1) = 's'; if Tmp = 0 then Choice := 0; else begin Choice := Natural'Value (Line (1 .. Tmp)); if Choice > Choices'Last then Choice := 0; end if; exception when Constraint_Error => Choice := 0; end; end if; if Choice = 0 then Put_Line ("Unrecognized choice"); else Set_Selection (Compilers, Choices (Choice), not Is_Selected (Element (Choices (Choice)).all)); end if; end loop; end Select_Compilers_Interactively; ------------------------------ -- Show_Command_Line_Config -- ------------------------------ procedure Show_Command_Line_Config (Compilers : Compiler_Lists.List) is C : Compiler_Lists.Cursor; begin if not Is_Empty (Compilers) then New_Line; Put_Line ("You can regenerate the same config file in batch mode"); Put_Line (" with the following command line:"); Put ("gprconfig --batch"); Put (" --target="); if Selected_Target = Null_Unbounded_String then Put ("all"); else Put (To_String (Selected_Target)); end if; C := First (Compilers); while Has_Element (C) loop if Is_Selected (Element (C).all) then Put (" --config=" & To_String (Base, Element (C).all, As_Config_Arg => True)); end if; Next (C); end loop; New_Line; New_Line; end if; end Show_Command_Line_Config; ----------- -- Usage -- ----------- procedure Usage is begin Util.Display_Usage_Version_And_Help; Put_Line (" --target=target (" & Sdefault.Hostname & " by default)"); Put_Line (" Select specified target or ""all"" for any target."); Put_Line (" --show-targets : List all compiler targets available."); Put_Line (" --mi-show-compilers : List all compilers available in a " & "parser-friendly way."); Put_Line (" --batch : batch mode, no interactive compiler selection."); Put_Line (" -v : verbose mode."); Put_Line (" -q : quiet output."); Put_Line (" -o file : Name and directory of the output file."); Put_Line (" default is " & GPR.Util.Default_Config_Name); Put_Line (" --db dir : Parse dir as an additional knowledge base."); Put_Line (" --db- : Do not load the standard knowledge base from:"); Put_Line (" " & Default_Knowledge_Base_Directory); Put_Line (" --validate : Validate the contents of the knowledge base"); Put_Line (" before loading."); Put_Line (" --config=language[,version[,runtime[,path[,name]]]]"); Put_Line (" Preselect a compiler."); Put_Line (" Name is either one of the names of the blocks"); Put_Line (" in the knowledge base ('GCC', 'GCC-28',...) or"); Put_Line (" the base name of an executable ('gcc',"); Put_Line (" 'gnatmake')."); Put_Line (" An empty string can be specified for any of the"); Put_Line (" optional parameters"); end Usage; begin Util.Set_Program_Name ("gprconfig"); Selected_Target := To_Unbounded_String (Sdefault.Hostname); -- First, check if --version or --help is used Check_Version_And_Help ("GPRCONFIG", "2006"); -- Now check whether we should parse the default knownledge base. -- This needs to be done first, since that influences --config and -h -- at least. Initialize_Option_Scan; loop case Getopt (Valid_Switches) is when '-' => if Full_Switch = "-db" then if Parameter = "-" then Load_Standard_Base := False; end if; elsif Full_Switch = "-validate" then Opt_Validate := True; elsif Full_Switch = "-target" then Target_Specified := True; if Parameter = "all" then Selected_Target := Null_Unbounded_String; else Selected_Target := To_Unbounded_String (Parameter); Output_File := To_Unbounded_String (Parameter & ".cgpr"); end if; elsif Full_Switch = "-show-targets" then -- By default, display all targets available Selected_Target := Null_Unbounded_String; elsif Full_Switch = "-fallback-targets" then Native_Target := True; end if; when 'q' => Opt.Quiet_Output := True; Current_Verbosity := Default; when 'v' => case Current_Verbosity is when Default => Current_Verbosity := Medium; when others => Current_Verbosity := High; end case; Opt.Quiet_Output := False; when ASCII.NUL => exit; when others => null; end case; end loop; if Selected_Target = Null_Unbounded_String then -- Fallback targets do not make sense in context of --target=all. Native_Target := False; end if; Pedantic_KB := True; if Load_Standard_Base then Parse_Knowledge_Base (Base, Default_Knowledge_Base_Directory, Validate => Opt_Validate); end if; -- Now check all the other command line switches Initialize_Option_Scan; loop case Getopt (Valid_Switches) is when '-' => if Full_Switch = "-config" then declare Requires_Comp : Boolean; Comp : Compiler_Access; begin Parse_Config_Parameter (Base => Base, Config => Parameter, Compiler => Comp, Requires_Compiler => Requires_Comp); if Requires_Comp then Append (Filters, Comp); else Append (Compilers, Comp); end if; end; elsif Full_Switch = "-batch" then Batch := True; elsif Full_Switch = "-mi-show-compilers" then Show_Compilers := True; elsif Full_Switch = "-show-targets" then Show_Targets := True; elsif Full_Switch = "-db" then if Parameter = "-" then null; -- already processed else Parse_Knowledge_Base (Base, Parameter, Validate => Opt_Validate); end if; end if; when 'h' => Help (Base); return; when 'o' => Output_File := To_Unbounded_String (Parameter); when 'q' | 'v' | 't' => null; -- already processed when others => exit; end case; end loop; Put_Verbose ("Only compilers matching target " & To_String (Selected_Target) & " will be preserved"); Get_Targets_Set (Base, To_String (Selected_Target), Selected_Targets_Set); if Batch then Complete_Command_Line_Compilers (Base, Selected_Targets_Set, Filters, Compilers, Target_Specified, Selected_Target); -- Selected target may have changed due to fallback, need to update -- corresponding target set. Get_Targets_Set (Base, To_String (Selected_Target), Selected_Targets_Set); else declare Iter : All_Iterator (Length (Filters)); begin Iter.Filters := Filters; Foreach_Compiler_In_Path (Iterator => Iter, Base => Base, On_Target => Selected_Targets_Set, Extra_Dirs => Extra_Dirs_From_Filters (Filters)); Splice (Target => Compilers, Before => No_Element, Source => Iter.Compilers); end; if Show_Targets or else Current_Verbosity /= Default then declare use String_Lists; All_Target : String_Lists.List; C : Compiler_Lists.Cursor := First (Compilers); begin Put_Line ("List of targets supported by a compiler:"); while Has_Element (C) loop if Target (Element (C).all) /= No_Name then declare Cur_Target : constant String := Get_Name_String (Target (Element (C).all)); T : String_Lists.Cursor := First (All_Target); Dup : Boolean := False; TS_Id : Targets_Set_Id; begin while Has_Element (T) loop if Element (T) = Cur_Target then Dup := True; exit; end if; Next (T); end loop; if not Dup then Get_Targets_Set (Base, Cur_Target, TS_Id); Put (Normalized_Target (Base, TS_Id)); if Cur_Target = Sdefault.Hostname then Put (" (native target)"); end if; New_Line; Append (All_Target, Cur_Target); end if; end; end if; Next (C); end loop; end; if Show_Targets then return; end if; end if; if Is_Empty (Compilers) then if Selected_Target /= Null_Unbounded_String then Put_Line (Standard_Error, "No compilers found for target " & To_String (Selected_Target)); else Put_Line (Standard_Error, "No compilers found"); end if; Ada.Command_Line.Set_Exit_Status (1); return; end if; Compiler_Sort.Sort (Compilers); if Show_Compilers then Display_Compilers_For_Parser (Base, Compilers); return; else Select_Compilers_Interactively (Base, Compilers); Show_Command_Line_Config (Compilers); end if; end if; if not Target_Specified then Get_Targets_Set (Base, GPR.Sdefault.Hostname, Selected_Targets_Set); Selected_Target := To_Unbounded_String (Normalized_Target (Base, Selected_Targets_Set)); end if; if Output_File /= Null_Unbounded_String then -- Look for runtime directories XML files declare Cursor : Compiler_Lists.Cursor; Comp : Compiler_Access; begin Cursor := Compiler_Lists.First (Compilers); while Compiler_Lists.Has_Element (Cursor) loop Comp := Compiler_Lists.Element (Cursor); if Is_Selected (Comp.all) and then Runtime_Dir_Of (Comp) /= No_Name then declare RTS : constant String := Get_Name_String (Runtime_Dir_Of (Comp)); Last : Natural := RTS'Last; begin if RTS (Last) = '/' or else RTS (Last) = Directory_Separator then Last := Last - 1; end if; if Last - RTS'First > 6 and then RTS (Last - 5 .. Last) = "adalib" and then (RTS (Last - 6) = Directory_Separator or else RTS (Last - 6) = '/') then Last := Last - 6; else Last := RTS'Last; end if; Parse_Knowledge_Base (Base, RTS (RTS'First .. Last)); end; end if; Compiler_Lists.Next (Cursor); end loop; end; Generate_Configuration (Base, Compilers, To_String (Output_File), To_String (Selected_Target), Selected_Targets_Set); end if; exception when Invalid_Config => Put_Line (Standard_Error, "Invalid configuration specified with --config"); Ada.Command_Line.Set_Exit_Status (1); when Generate_Error => Put_Line (Standard_Error, "Generation of configuration files failed"); Ada.Command_Line.Set_Exit_Status (3); when E : Knowledge_Base_Validation_Error => Put_Verbose (Exception_Information (E)); Ada.Command_Line.Set_Exit_Status (4); when E : Invalid_Knowledge_Base => Put_Line (Standard_Error, "Invalid setup of the gprconfig knowledge base"); Put_Verbose (Exception_Information (E)); Ada.Command_Line.Set_Exit_Status (4); when End_Error => null; when Invalid_Switch => Put_Line (Standard_Error, "Invalid command line switch: -" & Full_Switch); Try_Help; Ada.Command_Line.Set_Exit_Status (2); when Invalid_Parameter => Put_Line (Standard_Error, "Missing parameter for switch: -" & Full_Switch); Try_Help; Ada.Command_Line.Set_Exit_Status (2); end GprConfig.Main; gprbuild-25.0.0/src/gprconfig.ads000066400000000000000000000030711470075373400166570ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2006-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; package GprConfig is Selected_Target : Unbounded_String; -- Value of --target switch Target_Specified : Boolean := False; -- True if switch --target was specified end GprConfig; gprbuild-25.0.0/src/gprexch.adb000066400000000000000000000101151470075373400163150ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2006-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ package body Gprexch is type String_Ptr is access String; Binding_Labels : array (Binding_Section) of String_Ptr; -- The list of labels of the different section in a binder exchange file. -- Populated in the package body. Library_Labels : array (Library_Section) of String_Ptr; -- The list of labels of the different section in a library exchange file. -- Populated in the package body. ------------------- -- Binding_Label -- ------------------- function Binding_Label (Section : Binding_Section) return String is begin if Binding_Labels (Section) = null then return ""; else return Binding_Labels (Section).all; end if; end Binding_Label; ------------------------- -- Get_Binding_Section -- ------------------------- function Get_Binding_Section (Label : String) return Binding_Section is begin for Section in Binding_Section loop if Binding_Labels (Section) /= null and then Binding_Labels (Section).all = Label then return Section; end if; end loop; return No_Binding_Section; end Get_Binding_Section; ------------------------- -- Get_Library_Section -- ------------------------- function Get_Library_Section (Label : String) return Library_Section is begin for Section in Library_Section loop if Library_Labels (Section) /= null and then Library_Labels (Section).all = Label then return Section; end if; end loop; return No_Library_Section; end Get_Library_Section; ------------------- -- Library_Label -- ------------------- function Library_Label (Section : Library_Section) return String is begin if Library_Labels (Section) = null then return ""; else return Library_Labels (Section).all; end if; end Library_Label; -- Package elaboration code (build the lists of section labels) begin for J in Binding_Labels'Range loop if J /= No_Binding_Section then Binding_Labels (J) := new String'('[' & J'Img & ']'); for K in Binding_Labels (J)'Range loop if Binding_Labels (J) (K) = '_' then Binding_Labels (J) (K) := ' '; end if; end loop; end if; end loop; Binding_Labels (No_Binding_Section) := null; for J in Library_Labels'Range loop if J /= No_Library_Section then Library_Labels (J) := new String'('[' & J'Img & ']'); for K in Library_Labels (J)'Range loop if Library_Labels (J) (K) = '_' then Library_Labels (J) (K) := ' '; end if; end loop; end if; end loop; Library_Labels (No_Library_Section) := null; end Gprexch; gprbuild-25.0.0/src/gprexch.ads000066400000000000000000000106241470075373400163430ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2006-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ -- These package defines sections and the corresponding labels for exchange -- files between gprbuild and gprbind (binding exchange files) and gprlib -- (library exchange files). -- All labels start with '[' and end with ']' package Gprexch is -- Binding exchange file sections type Binding_Section is (No_Binding_Section, Quiet, Verbose_Low, Verbose_Higher, Nothing_To_Bind, Shared_Libs, Main_Base_Name, Mapping_File, Compiler_Path, Compiler_Leading_Switches, Compiler_Trailing_Switches, Main_Dependency_File, Dependency_Files, Binding_Options, Generated_Object_File, Bound_Object_Files, Generated_Source_Files, Resulting_Options, Run_Path_Option, Project_Files, Toolchain_Version, Delete_Temp_Files, Object_File_Suffix, There_Are_Stand_Alone_Libraries, Script_Path); function Binding_Label (Section : Binding_Section) return String; -- Return the label for a section in a binder exchange file function Get_Binding_Section (Label : String) return Binding_Section; -- Get the current section from a label in a binding exchange file -- Library exchange file sections type Library_Section is (No_Library_Section, No_Create, Quiet, Verbose_Low, Verbose_Higher, Relocatable, Static, Object_Files, Options, Object_Directory, Library_Name, Library_Directory, Library_Dependency_Directory, Library_Version, Library_Options, Library_Rpath_Options, Library_Path, Library_Version_Options, Shared_Lib_Prefix, Shared_Lib_Suffix, Shared_Lib_Minimum_Options, Symbolic_Link_Supported, Major_Minor_Id_Supported, PIC_Option, Imported_Libraries, Runtime_Library_Dir, Driver_Name, Compilers, Compiler_Leading_Switches, Compiler_Trailing_Switches, Toolchain_Version, Archive_Builder, Archive_Builder_Append_Option, Archive_Indexer, Partial_Linker, Archive_Suffix, Run_Path_Option, Run_Path_Origin, Separate_Run_Path_Options, Install_Name, Auto_Init, Interface_Dep_Files, Other_Interfaces, Interface_Obj_Files, Standalone_Mode, Dependency_Files, Binding_Options, Leading_Library_Options, Copy_Source_Dir, Sources, Generated_Object_Files, Generated_Source_Files, Max_Command_Line_Length, Response_File_Format, Response_File_Switches, Keep_Temporary_Files, Object_Lister, Object_Lister_Matcher, Export_File, Library_Symbol_File, Script_Path, No_SAL_Binding, Mapping_File, Project_Directory, CodePeer_Mode); function Library_Label (Section : Library_Section) return String; -- Return the label for a section in a library exchange file function Get_Library_Section (Label : String) return Library_Section; -- Get the current section from a label in a library exchange file end Gprexch; gprbuild-25.0.0/src/gprinstall-db.adb000066400000000000000000000130601470075373400174210ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2014-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ with Ada.Directories; use Ada.Directories; with Ada.Integer_Text_IO; use Ada.Integer_Text_IO; with Ada.Text_IO; use Ada.Text_IO; with GNAT.MD5; use GNAT.MD5; package body Gprinstall.DB is use Ada; ---------- -- List -- ---------- procedure List is type Stats is record N_Files : Natural := 0; N_Files_Not_Found : Natural := 0; Bytes : Directories.File_Size := 0; end record; function Project_Dir return String; -- Returns the install project directory function Get_Stat (Manifest : String) return Stats; -- Compute the stats for the given manifest file procedure Process (D_Entry : Directory_Entry_Type); -- Process a directory entry, this is a specific manifest file -------------- -- Get_Stat -- -------------- function Get_Stat (Manifest : String) return Stats is Dir : constant String := Containing_Directory (Manifest) & DS; File : File_Type; Line : String (1 .. 2048); Last : Natural; Result : Stats; subtype MD5_Range is Positive range Message_Digest'Range; subtype Name_Range is Positive range MD5_Range'Last + 2 .. Line'Last; begin Open (File, In_File, Manifest); while not End_Of_File (File) loop Get_Line (File, Line, Last); if Line (1 .. 2) /= Sig_Line then declare Filename : constant String := Dir & Line (Name_Range'First .. Last); begin if Exists (Filename) then Result.N_Files := Result.N_Files + 1; Result.Bytes := Result.Bytes + Size (Filename); else Result.N_Files_Not_Found := Result.N_Files_Not_Found + 1; end if; end; end if; end loop; Close (File); return Result; end Get_Stat; ----------------- -- Project_Dir -- ----------------- function Project_Dir return String is begin if Is_Absolute_Path (Global_Project_Subdir.V.all) then return Global_Project_Subdir.V.all; else return Global_Prefix_Dir.V.all & Global_Project_Subdir.V.all; end if; end Project_Dir; package File_Size_IO is new Text_IO.Integer_IO (Directories.File_Size); use File_Size_IO; ------------- -- Process -- ------------- procedure Process (D_Entry : Directory_Entry_Type) is S : Stats; Unit : String (1 .. 2) := "b "; Size : Directories.File_Size; begin Put (" " & Simple_Name (D_Entry)); Set_Col (25); if Output_Stats then -- Get stats S := Get_Stat (Full_Name (D_Entry)); -- Number of files Put (S.N_Files, Width => 5); if S.N_Files > 1 then Put (" files, "); else Put (" file, "); end if; -- Sizes Size := S.Bytes; if Size > 1024 then Size := Size / 1024; Unit := "Kb"; end if; if Size > 1024 then Size := Size / 1024; Unit := "Mb"; end if; if Size > 1024 then Size := Size / 1024; Unit := "Gb"; end if; Put (Size, Width => 5); Put (' ' & Unit); -- Files not found if any if S.N_Files_Not_Found > 0 then Put (" ("); Put (S.N_Files_Not_Found, Width => 0); Put (" files missing)"); end if; end if; New_Line; end Process; Dir : constant String := Project_Dir & "manifests"; begin New_Line; if Exists (Dir) then Put_Line ("List of installed packages"); New_Line; Search (Dir, "*", (Ordinary_File => True, others => False), Process'Access); else Put_Line ("No package installed"); New_Line; end if; end List; end Gprinstall.DB; gprbuild-25.0.0/src/gprinstall-db.ads000066400000000000000000000026011470075373400174410ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2014-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ package Gprinstall.DB is procedure List; end Gprinstall.DB; gprbuild-25.0.0/src/gprinstall-install.adb000066400000000000000000003433111470075373400205070ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2012-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Containers.Indefinite_Ordered_Sets; with Ada.Containers.Indefinite_Vectors; use Ada; with Ada.Containers.Vectors; with Ada.Directories; use Ada.Directories; with Ada.Strings.Equal_Case_Insensitive; with Ada.Strings.Fixed; use Ada.Strings; with Ada.Strings.Less_Case_Insensitive; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with Ada.Text_IO; use Ada.Text_IO; with GNAT.MD5; use GNAT.MD5; with GNAT.OS_Lib; with GNAT.String_Split; with GPR.Names; use GPR.Names; with GPR.Opt; with GPR.Osint; use GPR.Osint; with GPR.PP; use GPR.PP; with GPR.Snames; use GPR.Snames; with GPR.Tree; with GPR.Util; use GPR.Util; with GPR.Version; use GPR.Version; with Gpr_Build_Util; use Gpr_Build_Util; package body Gprinstall.Install is use GNAT; package String_Vector is new Containers.Indefinite_Vectors (Positive, String); package Seen_Set renames GPR.String_Sets; Content : String_Vector.Vector; -- The content of the project, this is used when creating the project -- and is needed to ease the project section merging when installing -- multiple builds. Initial_Buffer_Size : constant := 100; -- Arbitrary value for the initial size of the buffer below Buffer : GNAT.OS_Lib.String_Access := new String (1 .. Initial_Buffer_Size); Buffer_Last : Natural := 0; Agg_Manifest : Text_IO.File_Type; -- Manifest file for main aggregate project Line_Manifest : Text_IO.Count := 0; Line_Agg_Manifest : Text_IO.Count := 0; -- Keep lines when opening the manifest files. This is used by the rollback -- routine when an error occurs while copying the files. Objcopy_Exec : constant String := (if Target_Name = null then "objcopy" else Target_Name.all & "-objcopy"); -- Name of objcopy executable, possible a cross one Strip_Exec : constant String := (if Target_Name = null then "strip" else Target_Name.all & "-strip"); -- Name of strip executable, possible a cross one Objcopy : constant OS_Lib.String_Access := OS_Lib.Locate_Exec_On_Path (Objcopy_Exec); Strip : constant OS_Lib.String_Access := OS_Lib.Locate_Exec_On_Path (Strip_Exec); procedure Double_Buffer; -- Double the size of the Buffer procedure Write_Char (C : Character); -- Append character C to the Buffer. Double the buffer if needed procedure Write_Eol; -- Append the content of the Buffer as a line to Content and empty the -- Buffer. procedure Write_Str (S : String); -- Append S to the buffer. Double the buffer if needed Installed : Name_Id_Set.Set; -- Record already installed project Prep_Suffix : constant String := ".prep"; type Type_Node; type Type_Node_Ref is access Type_Node; type Type_Node is record String_Type : Project_Node_Id := Empty_Project_Node; Next : Type_Node_Ref; end record; ------------- -- Process -- ------------- procedure Process (Tree : GPR.Project_Tree_Ref; Node_Tree : GPR.Project_Node_Tree_Ref; Project : GPR.Project_Id) is Windows_Target : constant Boolean := Get_Name_String (Project.Config.Shared_Lib_Suffix) = ".dll"; Pcks : constant Package_Table.Table_Ptr := Tree.Shared.Packages.Table; Strs : constant String_Element_Table.Table_Ptr := Tree.Shared.String_Elements.Table; Vels : constant Variable_Element_Table.Table_Ptr := Tree.Shared.Variable_Elements.Table; -- Local values for the given project, these are initially set with the -- default values. It is updated using the Install package found in the -- project if any. Active : Boolean := True; -- Whether installation is active or not (Install package's attribute) Side_Debug : Boolean := Gprinstall.Side_Debug; -- Whether to extract debug symbols from executables and shared -- libraries. Default to global value. Prefix_Dir : Param := Dup (Global_Prefix_Dir); Exec_Subdir : Param := Dup (Global_Exec_Subdir); Lib_Subdir : Param := Dup (Global_Lib_Subdir); ALI_Subdir : Param := Dup (Global_ALI_Subdir); Link_Lib_Subdir : Param := Dup (Global_Link_Lib_Subdir); Sources_Subdir : Param := Dup (Global_Sources_Subdir); Project_Subdir : Param := Dup (Global_Project_Subdir); Install_Mode : Param := Dup (Global_Install_Mode); Install_Name : Param := Dup (Global_Install_Name); Install_Project : Boolean := Global_Install_Project; type Items is (Source, Object, Dependency, Library, Executable); Copy : array (Items) of Boolean := (others => False); -- What should be copied from a project, this depends on the actual -- project kind and the mode (usage, dev) set for the install. Man : Text_IO.File_Type; -- File where manifest for this project is kept -- Keeping track of artifacts to install type Artifacts_Data is record Destination, Filename : Name_Id; Required : Boolean; end record; package Artifacts_Set is new Containers.Vectors (Positive, Artifacts_Data); Artifacts : Artifacts_Set.Vector; Excluded_Naming : Seen_Set.Set; -- This set contains names of Ada unit to exclude from the generated -- package Naming. This is needed to avoid renaming for bodies which -- are not installed when the minimum installation (-m) is used. In -- this case there is two points to do: -- -- 1. the installed .ali must use the spec naming -- -- 2. the naming convention for the body must be excluded from the -- generated project. procedure Copy_File (From, To, File : String; From_Ver : String := ""; Sym_Link : Boolean := False; Executable : Boolean := False; Extract_Debug : Boolean := False); -- Copy file From into To, if Sym_Link is set a symbolic link is -- created. If Executable is set, the destination file exec attribute -- is set. When Extract_Debug is set to True the debug information -- for the executable is written in a side file. function Dir_Name (Suffix : Boolean := True) return String; -- Returns the name of directory where project files are to be -- installed. This name is the name of the project. If Suffix is -- True then the build name is also returned. function Cat (Dir : Path_Name_Type; File : File_Name_Type) return String; pragma Inline (Cat); -- Returns the string which is the catenation of Dir and File function Sources_Dir (Build_Name : Boolean := True) return String; -- Returns the full pathname to the sources destination directory function Exec_Dir return String; -- Returns the full pathname to the executable destination directory function Lib_Dir (Build_Name : Boolean := True) return String; -- Returns the full pathname to the library destination directory function ALI_Dir (Build_Name : Boolean := True) return String; -- Returns the full pathname to the library destination directory function Link_Lib_Dir return String; -- Returns the full pathname to the lib symlib directory function Project_Dir return String; -- Returns the full pathname to the project destination directory procedure Check_Install_Package; -- Check Project's install package and overwrite the default values of -- the corresponding variables above. procedure Copy_Files; -- Do the file copies for the project's sources, objects, library, -- executables. procedure Create_Project (Project : Project_Id); -- Create install project for the given project procedure Add_To_Manifest (Pathname : String; Aggregate_Only : Boolean := False); -- Add filename to manifest function Get_Library_Filename return File_Name_Type; -- Returns the actual file name for the library function Has_Sources (Project : Project_Id) return Boolean; pragma Inline (Has_Sources); -- Returns True if the project contains sources function Bring_Sources (Project : Project_Id) return Boolean; -- Returns True if Project gives visibility to some sources directly or -- indirectly via the with clauses. function Main_Binary (Source : Name_Id) return String; -- Give the source name found in the Main attribute, returns the actual -- binary as built by gprbuild. This routine looks into the Builder -- switches for a the Executable attribute. function Is_Install_Active (Project : Project_Id) return Boolean; -- Returns True if the Project is active, that is there is no attribute -- Active set to False in the Install package. procedure Open_Check_Manifest (File : out Text_IO.File_Type; Current_Line : out Text_IO.Count); -- Check that manifest file can be used procedure Rollback_Manifests; -- Rollback manifest files (for current project or/and aggregate one) function For_Dev return Boolean is (Install_Mode.V.all = "dev"); ------------- -- ALI_Dir -- ------------- function ALI_Dir (Build_Name : Boolean := True) return String is Install_Name_Dir : constant String := (if Install_Name.Default then "" else Install_Name.V.all & "/"); begin if Is_Absolute_Path (ALI_Subdir.V.all) then return ALI_Subdir.V.all & Install_Name_Dir; elsif not ALI_Subdir.Default or else not Build_Name then return Prefix_Dir.V.all & ALI_Subdir.V.all & Install_Name_Dir; else return Ensure_Directory (Prefix_Dir.V.all & ALI_Subdir.V.all & Install_Name_Dir & Dir_Name); end if; end ALI_Dir; --------------------- -- Add_To_Manifest -- --------------------- procedure Add_To_Manifest (Pathname : String; Aggregate_Only : Boolean := False) is begin if not Aggregate_Only and then not Is_Open (Man) then Open_Check_Manifest (Man, Line_Manifest); end if; -- Append entry into manifest declare function N (Str : String) return String is (Normalize_Pathname (Str, Case_Sensitive => False)); MD5 : constant String := File_MD5 (Pathname); Path : constant String := Containing_Directory (Pathname); File : constant String := Simple_Name (Pathname); begin if not Aggregate_Only and then Is_Open (Man) then Put_Line (Man, MD5 & ' ' & Util.Relative_Path (N (Path), Containing_Directory (N (Name (Man)))) & File); end if; if Is_Open (Agg_Manifest) then Put_Line (Agg_Manifest, MD5 & ' ' & Util.Relative_Path (N (Path), Containing_Directory (N (Name (Agg_Manifest)))) & File); end if; end; end Add_To_Manifest; ------------------- -- Bring_Sources -- ------------------- function Bring_Sources (Project : Project_Id) return Boolean is begin if Has_Sources (Project) then return True; else declare List : Project_List := Project.All_Imported_Projects; begin while List /= null loop if Has_Sources (List.Project) then return True; end if; List := List.Next; end loop; end; end if; return False; end Bring_Sources; --------------------------- -- Check_Install_Package -- --------------------------- procedure Check_Install_Package is Pck : Package_Id := Project.Decl.Packages; procedure Replace (P : in out Param; Val : Name_Id; Is_Dir : Boolean := True; Normalize : Boolean := False); pragma Inline (Replace); -- Set Var with Value, free previous pointer ------------- -- Replace -- ------------- procedure Replace (P : in out Param; Val : Name_Id; Is_Dir : Boolean := True; Normalize : Boolean := False) is V : constant String := Get_Name_String (Val); begin if V /= "" then Free (P.V); P := (new String' ((if Is_Dir then (if Normalize then Ensure_Directory (Normalize_Pathname (V)) else Ensure_Directory (V)) else V)), Default => False); end if; end Replace; begin Look_Install_Package : while Pck /= No_Package loop if Pcks (Pck).Decl /= No_Declarations and then Pcks (Pck).Name = Name_Install then -- Found Install package, check attributes declare Id : Variable_Id := Pcks (Pck).Decl.Attributes; begin while Id /= No_Variable loop declare V : constant Variable := Vels (Id); begin if V.Name = Name_Prefix then -- If Install.Prefix is a relative path, it is made -- relative to the global prefix. declare Value : constant String := Get_Name_String (V.Value.Value); Res : Name_Id; Changed : Boolean := False; begin if Is_Absolute_Path (Value) then if Global_Prefix_Dir.Default then Res := V.Value.Value; Changed := True; end if; else Set_Name_Buffer (Global_Prefix_Dir.V.all); Add_Str_To_Name_Buffer (Value); Res := Name_Find; Changed := True; end if; if Changed then Replace (Prefix_Dir, Res, Normalize => True); end if; end; elsif V.Name = Name_Exec_Subdir and then Global_Exec_Subdir.Default then Replace (Exec_Subdir, V.Value.Value); elsif V.Name = Name_Lib_Subdir and then Global_Lib_Subdir.Default then Replace (Lib_Subdir, V.Value.Value); elsif V.Name = Name_ALI_Subdir and then Global_ALI_Subdir.Default then Replace (ALI_Subdir, V.Value.Value); elsif V.Name = Name_Link_Lib_Subdir and then Global_Link_Lib_Subdir.Default then Replace (Link_Lib_Subdir, V.Value.Value); elsif V.Name = Name_Sources_Subdir and then Global_Sources_Subdir.Default then Replace (Sources_Subdir, V.Value.Value); elsif V.Name = Name_Project_Subdir and then Global_Project_Subdir.Default then Replace (Project_Subdir, V.Value.Value); elsif V.Name = Name_Mode and then Global_Install_Mode.Default then Replace (Install_Mode, V.Value.Value); elsif V.Name = Name_Install_Name and then Global_Install_Name.Default then Replace (Install_Name, V.Value.Value, Is_Dir => False); elsif V.Name = Name_Active then declare Val : constant String := To_Lower (Get_Name_String (V.Value.Value)); begin if Val = "false" then Active := False; else Active := True; end if; end; elsif V.Name = Name_Side_Debug then declare Val : constant String := To_Lower (Get_Name_String (V.Value.Value)); begin if Val = "true" then Side_Debug := True; else Side_Debug := False; end if; end; elsif V.Name = Name_Install_Project then declare Val : constant String := To_Lower (Get_Name_String (V.Value.Value)); begin if Val = "false" then Install_Project := False; else Install_Project := True; end if; end; end if; end; Id := Vels (Id).Next; end loop; end; -- Now check arrays declare Id : Array_Id := Pcks (Pck).Decl.Arrays; begin while Id /= No_Array loop declare V : constant Array_Data := Tree.Shared.Arrays.Table (Id); begin if V.Name in Name_Artifacts | Name_Required_Artifacts then declare Eid : Array_Element_Id := V.Value; begin while Eid /= No_Array_Element loop declare E : constant Array_Element := Tree.Shared.Array_Elements.Table (Eid); S : String_List_Id := E.Value.Values; begin while S /= Nil_String loop Artifacts.Append (Artifacts_Data' (E.Index, Strs (S).Value, Required => (if V.Name = Name_Artifacts then False else True))); S := Strs (S).Next; end loop; end; Eid := Tree.Shared.Array_Elements. Table (Eid).Next; end loop; end; end if; end; Id := Tree.Shared.Arrays.Table (Id).Next; end loop; end; exit Look_Install_Package; end if; Pck := Pcks (Pck).Next; end loop Look_Install_Package; -- Now check if Lib_Subdir is set and not ALI_Subdir as in this case -- we want ALI_Subdir to be equal to Lib_Subdir. if not Lib_Subdir.Default and then ALI_Subdir.Default then ALI_Subdir := Dup (Lib_Subdir); end if; end Check_Install_Package; -------------- -- Dir_Name -- -------------- function Dir_Name (Suffix : Boolean := True) return String is function Get_Suffix return String; -- Returns a suffix if needed ---------------- -- Get_Suffix -- ---------------- function Get_Suffix return String is begin -- .default is always omitted from the directory name if Suffix and then Build_Name.all /= "default" then return '.' & Build_Name.all; else return ""; end if; end Get_Suffix; begin return Get_Name_String (Project.Name) & Get_Suffix; end Dir_Name; --------------------------- -- Get_Library_Filenaame -- --------------------------- function Get_Library_Filename return File_Name_Type is begin -- Library prefix if not Is_Static (Project) and then Project.Config.Shared_Lib_Prefix /= No_File then Get_Name_String (Project.Config.Shared_Lib_Prefix); else Set_Name_Buffer ("lib"); end if; -- Library name Get_Name_String_And_Append (Project.Library_Name); -- Library suffix if Is_Static (Project) and then Project.Config.Archive_Suffix /= No_File then Get_Name_String_And_Append (Project.Config.Archive_Suffix); elsif not Is_Static (Project) and then Project.Config.Shared_Lib_Suffix /= No_File then Get_Name_String_And_Append (Project.Config.Shared_Lib_Suffix); else Add_Str_To_Name_Buffer (".so"); end if; return Name_Find; end Get_Library_Filename; ----------------------- -- Is_Install_Active -- ----------------------- function Is_Install_Active (Project : Project_Id) return Boolean is Pck : Package_Id := Project.Decl.Packages; begin Look_Install_Package : while Pck /= No_Package loop if Pcks (Pck).Decl /= No_Declarations and then Pcks (Pck).Name = Name_Install then -- Found Install package, check attributes declare Id : Variable_Id := Pcks (Pck).Decl.Attributes; begin while Id /= No_Variable loop declare V : constant Variable := Vels (Id); begin if V.Name = Name_Active then declare Val : constant String := To_Lower (Get_Name_String (V.Value.Value)); begin if Val = "false" then return False; else return True; end if; end; end if; end; Id := Vels (Id).Next; end loop; end; exit Look_Install_Package; end if; Pck := Pcks (Pck).Next; end loop Look_Install_Package; -- If not defined, the default is active return True; end Is_Install_Active; ----------------- -- Main_Binary -- ----------------- function Main_Binary (Source : Name_Id) return String is function Get_Exec_Suffix return String; -- Return the target executable suffix --------------------- -- Get_Exec_Suffix -- --------------------- function Get_Exec_Suffix return String is begin if Project.Config.Executable_Suffix = No_Name then return ""; else return Get_Name_String (Project.Config.Executable_Suffix); end if; end Get_Exec_Suffix; Builder_Package : constant Package_Id := Value_Of (Name_Builder, Project.Decl.Packages, Project_Tree.Shared); Value : Variable_Value; begin if Builder_Package /= No_Package then Value := Value_Of (Name => Source, Attribute_Or_Array_Name => Name_Executable, In_Package => Builder_Package, Shared => Project_Tree.Shared); if Value = Nil_Variable_Value then -- If not found and name has an extension declare Name : constant String := Get_Name_String (Source); S : Name_Id; begin if Name /= Base_Name (Name) then Set_Name_Buffer (Base_Name (Name)); S := Name_Find; Value := Value_Of (Name => S, Attribute_Or_Array_Name => Name_Executable, In_Package => Builder_Package, Shared => Project_Tree.Shared); end if; end; end if; end if; if Value = Nil_Variable_Value then declare Simple_Name : constant String := Get_Name_String (Source); Last : Positive := Simple_Name'First; begin -- Cut executable name at the first . (extension). Note that -- this is not necessary the first base-name as we may have -- multiple dots in the source when using non standard naming. -- For example, having "main.2.ada" whe want to get on "main". while Last < Simple_Name'Last and then Simple_Name (Last + 1) /= '.' loop Last := Last + 1; end loop; return Simple_Name (Simple_Name'First .. Last) & Get_Exec_Suffix; end; else return Get_Name_String (Value.Value) & Get_Exec_Suffix; end if; end Main_Binary; ----------------- -- Has_Sources -- ----------------- function Has_Sources (Project : Project_Id) return Boolean is begin return Project.Source_Dirs /= Nil_String or else Project.Qualifier = Aggregate_Library; end Has_Sources; -------------- -- Exec_Dir -- -------------- function Exec_Dir return String is begin if Is_Absolute_Path (Exec_Subdir.V.all) then return Exec_Subdir.V.all; else return Prefix_Dir.V.all & Exec_Subdir.V.all; end if; end Exec_Dir; ------------- -- Lib_Dir -- ------------- function Lib_Dir (Build_Name : Boolean := True) return String is Install_Name_Dir : constant String := (if Install_Name.Default then "" else Install_Name.V.all & "/"); begin if Is_Absolute_Path (Lib_Subdir.V.all) then return Lib_Subdir.V.all & Install_Name_Dir; elsif not Lib_Subdir.Default or else not Build_Name then return Prefix_Dir.V.all & Lib_Subdir.V.all & Install_Name_Dir; else return Ensure_Directory (Prefix_Dir.V.all & Lib_Subdir.V.all & Install_Name_Dir & Dir_Name); end if; end Lib_Dir; ------------------ -- Link_Lib_Dir -- ------------------ function Link_Lib_Dir return String is begin if Is_Absolute_Path (Link_Lib_Subdir.V.all) then return Link_Lib_Subdir.V.all; else return Prefix_Dir.V.all & Link_Lib_Subdir.V.all; end if; end Link_Lib_Dir; ----------------- -- Sources_Dir -- ----------------- function Sources_Dir (Build_Name : Boolean := True) return String is Install_Name_Dir : constant String := (if Install_Name.Default then "" else Install_Name.V.all & "/"); begin if Is_Absolute_Path (Sources_Subdir.V.all) then return Sources_Subdir.V.all & Install_Name_Dir; elsif not Sources_Subdir.Default or else not Build_Name then return Prefix_Dir.V.all & Sources_Subdir.V.all & Install_Name_Dir; else return Ensure_Directory (Prefix_Dir.V.all & Sources_Subdir.V.all & Install_Name_Dir & Dir_Name); end if; end Sources_Dir; ----------------- -- Project_Dir -- ----------------- function Project_Dir return String is begin if Is_Absolute_Path (Project_Subdir.V.all) then return Project_Subdir.V.all; else return Prefix_Dir.V.all & Project_Subdir.V.all; end if; end Project_Dir; --------- -- Cat -- --------- function Cat (Dir : Path_Name_Type; File : File_Name_Type) return String is begin return Get_Name_String (Dir) & Get_Name_String (File); end Cat; --------------- -- Copy_File -- --------------- procedure Copy_File (From, To, File : String; From_Ver : String := ""; Sym_Link : Boolean := False; Executable : Boolean := False; Extract_Debug : Boolean := False) is Dest_Filename : aliased String := To & File; begin if Sym_Link and then On_Windows then Put ("Internal error: cannot use symbolic links on Windows"); New_Line; Finish_Program (Project_Tree, E_Fatal); end if; if not Sym_Link and then Exists (Dest_Filename) and then not Force_Installations and then File_MD5 (From) /= File_MD5 (Dest_Filename) then Put ("file "); Put (File); Put (" exists, use -f to overwrite"); New_Line; Finish_Program (Project_Tree, E_Fatal); end if; if Dry_Run or else Opt.Verbose_Mode then if Sym_Link then Put ("ln -s "); else Put ("cp "); end if; Put (From); Put (" "); Put (Dest_Filename); New_Line; end if; if not Dry_Run then -- If file exists and is read-only, first remove it if not Sym_Link and then Exists (Dest_Filename) then if not Is_Writable_File (Dest_Filename) then Set_Writable (Dest_Filename); end if; declare Success : Boolean; begin Delete_File (Dest_Filename, Success); if not Success then Put ("cannot overwrite "); Put (Dest_Filename); Put (" check permissions"); New_Line; Finish_Program (Project_Tree, E_Fatal); end if; end; end if; if not Sym_Link and then not Exists (From) then Put ("file "); Put (From); Put (" does not exist, build may not be complete"); New_Line; Finish_Program (Project_Tree, E_Fatal); end if; if (not Sym_Link and then not Exists (To)) or else (Sym_Link and then not Exists (From)) then if Create_Dest_Dir then begin if Sym_Link then Create_Path (Containing_Directory (From)); else Create_Path (To); end if; exception when Text_IO.Use_Error => -- Cannot create path, permission issue Put ("cannot create destination directory "); Put (if Sym_Link then Containing_Directory (From) else To); Put (" check permissions"); New_Line; Finish_Program (Project_Tree, E_Fatal); end; else Put_Line (Standard_Error, "target directory " & To & " does not exist, use -p to create"); Finish_Program (Project_Tree, E_Fatal); end if; end if; -- Do copy if Sym_Link then Create_Sym_Link (From, To & File); -- Add file to manifest if Install_Manifest then Add_To_Manifest (From); end if; if From_Ver /= "" then Create_Sym_Link (From_Ver, To & File); if Install_Manifest then Add_To_Manifest (From_Ver); end if; end if; else begin Ada.Directories.Copy_File (Source_Name => From, Target_Name => Dest_Filename, Form => "preserve=timestamps"); exception when Text_IO.Use_Error => Put_Line ("cannot overwrite file " & Dest_Filename & " check permissions."); Finish_Program (Project_Tree, E_Fatal); end; if Executable then Set_Executable (Dest_Filename, Mode => S_Owner + S_Group + S_Others); -- Furthermore, if we have an executable and we ask for -- separate debug symbols we do it now. -- The commands to run are: -- $ objcopy --only-keep-debug .debug -- $ strip -- $ objcopy --add-gnu-debuglink=.debug if Extract_Debug then if Objcopy = null then Put_Line (Objcopy_Exec & " not found, " & "cannot create side debug file for " & Dest_Filename); elsif Strip = null then Put_Line (Strip_Exec & " not found, " & "cannot create side debug file for " & Dest_Filename); else declare Keep_Debug : aliased String := "--only-keep-debug"; Dest_Debug : aliased String := Dest_Filename & ".debug"; Link_Debug : aliased String := "--add-gnu-debuglink=" & Dest_Debug; Success : Boolean; Args : Argument_List (1 .. 3); begin -- 1. copy the debug symbols: Args (1) := Keep_Debug'Unchecked_Access; Args (2) := Dest_Filename'Unchecked_Access; Args (3) := Dest_Debug'Unchecked_Access; OS_Lib.Spawn (Objcopy.all, Args, Success); if Success then -- Record the debug file in the manifest if Install_Manifest then Add_To_Manifest (Dest_Debug); end if; -- 2. strip original executable Args (1) := Dest_Filename'Unchecked_Access; OS_Lib.Spawn (Strip.all, Args (1 .. 1), Success); if Success then -- 2. link debug symbols file with original -- file. Args (1) := Link_Debug'Unchecked_Access; Args (2) := Dest_Filename'Unchecked_Access; OS_Lib.Spawn (Objcopy.all, Args (1 .. 2), Success); if not Success then Put_Line (Objcopy_Exec & " error, " & "cannot link debug symbol file with" & " original executable " & Dest_Filename); end if; else Put_Line (Strip_Exec & " error, " & "cannot remove debug symbols from " & Dest_Filename); end if; else Put_Line (Objcopy_Exec & " error, " & "cannot create side debug file for " & Dest_Filename); end if; end; end if; end if; end if; -- Add file to manifest if Install_Manifest then Add_To_Manifest (Dest_Filename); end if; end if; end if; end Copy_File; ---------------- -- Copy_Files -- ---------------- procedure Copy_Files is procedure Copy_Project_Sources (Project : Project_Id); -- Copy sources from the given project procedure Copy_Source (Sid : Source_Id); procedure Copy_Artifacts (Pathname, Destination : String; Required : Boolean); -- Copy items from the artifacts attribute Source_Copied : Name_Id_Set.Set; -------------------------- -- Copy_Project_Sources -- -------------------------- procedure Copy_Project_Sources (Project : Project_Id) is function Is_Ada (Sid : Source_Id) return Boolean with Inline; -- Returns True if Sid is an Ada source function Is_Part_Of_Aggregate_Lib (Aggregate_Lib_Project : Project_Id; Sid : Source_Id) return Boolean; -- Returns True if Sid is part of the aggregate lib project. That -- is, Sid project is one of the aggregated projects. ------------ -- Is_Ada -- ------------ function Is_Ada (Sid : Source_Id) return Boolean is begin return Sid.Language /= null and then Get_Name_String (Sid.Language.Name) = "ada"; end Is_Ada; ------------------------------ -- Is_Part_Of_Aggregate_Lib -- ------------------------------ function Is_Part_Of_Aggregate_Lib (Aggregate_Lib_Project : Project_Id; Sid : Source_Id) return Boolean is P : Aggregated_Project_List := Aggregate_Lib_Project.Aggregated_Projects; begin while P /= null loop if P.Project = Sid.Project then return True; end if; P := P.Next; end loop; return False; end Is_Part_Of_Aggregate_Lib; Iter : Source_Iterator; Sid : Source_Id; begin if Project.Qualifier = Aggregate_Library then Iter := For_Each_Source (Tree, Locally_Removed => False); else Iter := For_Each_Source (Tree, Project, Locally_Removed => False); end if; loop Sid := Element (Iter); exit when Sid = No_Source; Initialize_Source_Record (Sid); -- Skip sources that are removed/excluded and sources not -- part of the interface for standalone libraries. if (Project.Qualifier /= Aggregate_Library or else (Is_Part_Of_Aggregate_Lib (Project, Sid) and then Is_Install_Active (Sid.Project))) and then (Project.Standalone_Library = No or else Sid.Declared_In_Interfaces) then if All_Sources then Copy_Source (Sid); elsif Sid.Naming_Exception = Yes then -- When a naming exception is present for a body which -- is not installed we must exclude the Naming from the -- generated project. Excluded_Naming.Include (Get_Name_String (Sid.Unit.Name)); end if; -- Objects / Deps if not Sources_Only and then (Other_Part (Sid) = null or else Sid.Kind /= Spec) then if Copy (Object) and then Sid.Kind /= Sep and then Sid.Compilable = Yes then Copy_File (From => Cat (Get_Object_Directory ((if Sid.Object_Project = No_Project then Sid.Project else Sid.Object_Project), False), Sid.Object), To => Lib_Dir, File => Get_Name_String (Sid.Object)); end if; -- Only install Ada .ali files (always name the .ali -- against the spec file). if Copy (Dependency) and then Sid.Kind /= Sep and then Is_Ada (Sid) then declare Proj : Project_Id := Sid.Project; Ssid : Source_Id; begin if Other_Part (Sid) = null or else Sid.Naming_Exception = No or else All_Sources then Ssid := Sid; else Ssid := Other_Part (Sid); end if; if Project.Qualifier = Aggregate_Library then Proj := Project; end if; Copy_File (From => Cat (Get_Object_Directory ((if Sid.Object_Project = No_Project or else Project.Qualifier = Aggregate_Library then Proj else Sid.Object_Project), Project.Library), Sid.Dep_Name), To => (if Proj.Library then ALI_Dir else Lib_Dir), File => Get_Name_String (Ssid.Dep_Name)); end; end if; end if; end if; Next (Iter); end loop; end Copy_Project_Sources; ----------------- -- Copy_Source -- ----------------- procedure Copy_Source (Sid : Source_Id) is begin if Copy (Source) and then Is_Install_Active (Sid.Project) then declare Prep_Filename : constant String := Cat (Get_Object_Directory (Sid.Project, False), Sid.File) & Prep_Suffix; begin if not Source_Copied.Contains (Name_Id (Sid.Path.Name)) then Source_Copied.Insert (Name_Id (Sid.Path.Name)); Copy_File (From => (if Exists (Prep_Filename) then Prep_Filename else Get_Name_String (Sid.Path.Display_Name)), To => Sources_Dir, File => Get_Name_String (Sid.Display_File)); end if; end; end if; end Copy_Source; -------------------- -- Copy_Artifacts -- -------------------- procedure Copy_Artifacts (Pathname, Destination : String; Required : Boolean) is procedure Copy_Entry (E : Directory_Entry_Type); -- Copy file pointed by E function Get_Directory (Fullname : String) return String; -- Returns the directory containing fullname. Note that we -- cannot use the standard Containing_Directory as filename -- can be a pattern and not be allowed in filename. function Get_Pattern return String; -- Return filename of pattern from Filename below Something_Copied : Boolean := False; -- Keep track if something has been copied or not. If an artifact -- is coming from Required_Artifacts we must ensure that there is -- actually something copied if we have a directory or wildcards. ---------------- -- Copy_Entry -- ---------------- procedure Copy_Entry (E : Directory_Entry_Type) is Fullname : constant String := Full_Name (E); Dest_Dir : constant String := (if Is_Absolute_Path (Destination) then Destination else Prefix_Dir.V.all & Destination); begin if Kind (E) = Directory and then Simple_Name (E) /= "." and then Simple_Name (E) /= ".." then Copy_Artifacts (Fullname & "/*", Dest_Dir & Simple_Name (E) & '/', Required); elsif Kind (E) = Ordinary_File then Copy_File (From => Fullname, To => Dest_Dir, File => Simple_Name (Fullname), Executable => Is_Executable_File (Fullname)); if Required then Something_Copied := True; end if; end if; end Copy_Entry; ------------------- -- Get_Directory -- ------------------- function Get_Directory (Fullname : String) return String is K : Natural := Fullname'Last; begin while K > 0 and then not Is_Directory_Separator (Fullname (K)) loop K := K - 1; end loop; pragma Assert (K > 0); return Fullname (Fullname'First .. K); end Get_Directory; ----------------- -- Get_Pattern -- ----------------- function Get_Pattern return String is K : Natural := Pathname'Last; begin while K > 0 and then not Is_Directory_Separator (Pathname (K)) loop K := K - 1; end loop; if K = 0 then return Pathname; else return Pathname (K + 1 .. Pathname'Last); end if; end Get_Pattern; begin Ada.Directories.Search (Directory => Get_Directory (Pathname), Pattern => Get_Pattern, Process => Copy_Entry'Access); if Required and not Something_Copied then Rollback_Manifests; Fail_Program (Project_Tree, "error: file does not exist '" & Pathname & ''', Flush_Messages => False); end if; exception when Text_IO.Name_Error => if Required then Rollback_Manifests; Fail_Program (Project_Tree, "warning: file does not exist '" & Pathname & ''', Flush_Messages => False); else Put_Line ("warning: file does not exist '" & Pathname & '''); end if; end Copy_Artifacts; procedure Copy_Interfaces is new For_Interface_Sources (Copy_Source); function Cat (Dir, File : String) return String is (if File = "" then "" else Dir & File); -- Returns Dir & File if File is not empty or "" otherwise begin if Has_Sources (Project) then -- Install the project and the extended projects if any declare P : Project_Id := Project; begin while P /= No_Project loop if not All_Sources then Copy_Interfaces (Tree, P); end if; Copy_Project_Sources (P); P := P.Extends; end loop; end; end if; -- Copy library if Copy (Library) and not Sources_Only then if not Is_Static (Project) and then Project.Lib_Internal_Name /= No_Name and then Project.Library_Name /= Project.Lib_Internal_Name then if Windows_Target then -- No support for version, do a simple copy Copy_File (From => Cat (Project.Library_Dir.Display_Name, Get_Library_Filename), To => Lib_Dir, File => Get_Name_String (Get_Library_Filename), Executable => True, Extract_Debug => Side_Debug); else Copy_File (From => Cat (Project.Library_Dir.Display_Name, File_Name_Type (Project.Lib_Internal_Name)), To => Lib_Dir, File => Get_Name_String (Project.Lib_Internal_Name), Executable => True, Extract_Debug => Side_Debug); Copy_File (From => Lib_Dir & Get_Name_String (Get_Library_Filename), To => Lib_Dir, File => Get_Name_String (Project.Lib_Internal_Name), From_Ver => Cat (Lib_Dir, Major_Id_Name (Get_Name_String (Get_Library_Filename), Get_Name_String (Project.Lib_Internal_Name))), Sym_Link => True); end if; else Copy_File (From => Cat (Project.Library_Dir.Display_Name, Get_Library_Filename), To => Lib_Dir, File => Get_Name_String (Get_Library_Filename), Executable => not Is_Static (Project), Extract_Debug => Side_Debug and then not Is_Static (Project)); end if; -- On Windows copy the shared libraries into the bin directory -- for it to be found in the PATH when running executable. On non -- Windows platforms add a symlink into the lib directory. if not Is_Static (Project) and then Add_Lib_Link then if Windows_Target then if Lib_Dir /= Exec_Dir then Copy_File (From => Lib_Dir & Get_Name_String (Get_Library_Filename), To => Exec_Dir, File => Get_Name_String (Get_Library_Filename), Executable => True, Extract_Debug => False); end if; elsif Link_Lib_Dir /= Lib_Dir then if On_Windows then Copy_File (From => Lib_Dir & Get_Name_String (Get_Library_Filename), To => Link_Lib_Dir, File => Get_Name_String (Get_Library_Filename), Sym_Link => False); else Copy_File (From => Link_Lib_Dir & Get_Name_String (Get_Library_Filename), To => Lib_Dir, File => Get_Name_String (Get_Library_Filename), Sym_Link => True); end if; -- Copy also the versioned library if any if Project.Lib_Internal_Name /= No_Name and then Project.Library_Name /= Project.Lib_Internal_Name then if On_Windows then Copy_File (From => Lib_Dir & Get_Name_String (Project.Lib_Internal_Name), To => Link_Lib_Dir, File => Get_Name_String (Project.Lib_Internal_Name), From_Ver => Cat (Link_Lib_Dir, Major_Id_Name (Get_Name_String (Get_Library_Filename), Get_Name_String (Project.Lib_Internal_Name))), Sym_Link => False); else Copy_File (From => Link_Lib_Dir & Get_Name_String (Project.Lib_Internal_Name), To => Lib_Dir, File => Get_Name_String (Project.Lib_Internal_Name), From_Ver => Cat (Link_Lib_Dir, Major_Id_Name (Get_Name_String (Get_Library_Filename), Get_Name_String (Project.Lib_Internal_Name))), Sym_Link => True); end if; end if; end if; end if; end if; -- Copy executable(s) if Copy (Executable) and not Sources_Only then Mains.Reset; declare M : Main_Info := Mains.Next_Main; begin while M /= No_Main_Info loop if M.Project in Project | Project.Extends then declare Bin : constant String := Main_Binary (Name_Id (M.File)); begin Copy_File (From => Get_Name_String (Project.Exec_Directory.Display_Name) & Bin, To => Exec_Dir, File => Bin, Executable => True, Extract_Debug => Side_Debug); end; end if; M := Mains.Next_Main; end loop; end; end if; -- Copy artifacts for E of Artifacts loop declare Destination : constant String := Ensure_Directory (Get_Name_String (E.Destination)); Filename : constant String := Get_Name_String (E.Filename); begin Copy_Artifacts (Get_Name_String (Project.Directory.Name) & Filename, Destination, E.Required); end; end loop; end Copy_Files; -------------------- -- Create_Project -- -------------------- procedure Create_Project (Project : Project_Id) is Filename : constant String := Project_Dir & Base_Name (Get_Name_String (Project.Path.Display_Name)) & ".gpr"; Gprinstall_Tag : constant String := "This project has been generated by GPRINSTALL"; Line : Unbounded_String; function "+" (Item : String) return Unbounded_String renames To_Unbounded_String; function "-" (Item : Unbounded_String) return String renames To_String; procedure Create_Packages; -- Create packages that are needed, currently Naming and part of -- Linker is generated for the installed project. procedure Create_Variables; -- Create global variables function Image (Name : Name_Id; Id : Array_Element_Id) return String; -- Returns Id image function Image (Id : Variable_Id) return String; -- Returns Id image function Image (Var : Variable_Value) return String; -- Returns Id image procedure Read_Project; -- Read project and set Content accordingly procedure Write_Project; -- Write content into project procedure Add_Empty_Line; pragma Inline (Add_Empty_Line); function Naming_Case_Alternative (Proj : Project_Id) return String_Vector.Vector; -- Returns the naming case alternative for this project configuration function Linker_Case_Alternative (Proj : Project_Id) return String_Vector.Vector; -- Returns the linker case alternative for this project configuration function Data_Attributes return String_Vector.Vector; -- Returns the attributes for the sources, objects and library function Get_Languages return String; -- Returns the list of languages function Get_Package (Project : Project_Id; Pkg_Name : Name_Id) return Package_Id; -- Returns the package Name for the given project function Get_Build_Line (Vars, Default : String) return String; -- Returns the build line for Var1 and possibly Var2 if not empty -- string. Default is the default build name. -------------------- -- Add_Empty_Line -- -------------------- procedure Add_Empty_Line is begin if Content.Element (Content.Last_Index) /= "" then Content.Append (""); end if; end Add_Empty_Line; -------------------- -- Get_Build_Line -- -------------------- function Get_Build_Line (Vars, Default : String) return String is use Strings.Fixed; Variables : String_Split.Slice_Set; Line : Unbounded_String; begin Line := +" BUILD : BUILD_KIND := "; if not No_Build_Var then String_Split.Create (Variables, Vars, ","); if Vars = "" then -- No variable specified, use default value Line := Line & "external("""; Line := Line & To_Upper (Dir_Name (Suffix => False)); Line := Line & "_BUILD"", "; else for K in 1 .. String_Split.Slice_Count (Variables) loop Line := Line & "external("""; Line := Line & String_Split.Slice (Variables, K) & """, "; end loop; end if; end if; Line := Line & '"' & Default & '"'; if not No_Build_Var then Line := Line & (+(Natural (String_Split.Slice_Count (Variables)) * ')')); end if; Line := Line & ';'; return -Line; end Get_Build_Line; --------------------- -- Create_Packages -- --------------------- procedure Create_Packages is procedure Create_Naming (Proj : Project_Id); -- Create the naming package procedure Create_Linker (Proj : Project_Id); -- Create the linker package if needed ------------------- -- Create_Naming -- ------------------- procedure Create_Naming (Proj : Project_Id) is P : constant Package_Id := Get_Package (Proj, Name_Naming); begin Content.Append (" package Naming is"); if P /= No_Package then -- Attributes declare V : Variable_Id := Pcks (P).Decl.Attributes; begin while V /= No_Variable loop Content.Append (" " & Image (V)); V := Vels (V).Next; end loop; end; end if; Content.Append (" case BUILD is"); if P /= No_Package then Content.Append_Vector (Naming_Case_Alternative (Proj)); end if; Content.Append (" end case;"); Content.Append (" end Naming;"); Add_Empty_Line; end Create_Naming; ------------------- -- Create_Linker -- ------------------- procedure Create_Linker (Proj : Project_Id) is P : constant Package_Id := Get_Package (Proj, Name_Linker); begin Content.Append (" package Linker is"); Content.Append (" case BUILD is"); -- Attribute Linker_Options only if set if P /= No_Package then Content.Append_Vector (Linker_Case_Alternative (Proj)); end if; Content.Append (" end case;"); Content.Append (" end Linker;"); Add_Empty_Line; end Create_Linker; begin Create_Naming (Project); Create_Linker (Project); end Create_Packages; ---------------------- -- Create_Variables -- ---------------------- procedure Create_Variables is Vars : Variable_Id; Types : Type_Node_Ref := null; Current : Type_Node_Ref; Max_Len : Natural := 0; begin Vars := Project.Decl.Variables; Var_Loop : while Vars /= No_Variable loop declare V : constant Variable := Vels (Vars); begin -- Compute variable's name maximum length if V.Value.Kind in Single | List then Max_Len := Natural'Max (Max_Len, Get_Name_String (V.Name)'Length); end if; -- Check if a typed variable if GPR.Tree.Present (V.Value.String_Type) then Current := Types; Type_Loop : while Current /= null loop exit Type_Loop when Current.String_Type = V.Value.String_Type; Current := Current.Next; end loop Type_Loop; if Current = null then Types := new Type_Node' (String_Type => V.Value.String_Type, Next => Types); end if; end if; Vars := V.Next; end; end loop Var_Loop; -- Output the types if any Current := Types; while Current /= null loop Pretty_Print (Project => Current.String_Type, In_Tree => Node_Tree, Increment => 2, Eliminate_Empty_Case_Constructions => False, Minimize_Empty_Lines => False, W_Char => Write_Char'Access, W_Eol => Write_Eol'Access, W_Str => Write_Str'Access, Backward_Compatibility => False, Id => No_Project, Max_Line_Length => 79, Initial_Indent => 3); Write_Eol; Current := Current.Next; end loop; -- Finally output variables Vars := Project.Decl.Variables; while Vars /= No_Variable loop declare V : constant Variable := Vels (Vars); begin if V.Value.Kind in Single | List then Write_Str (" " & Get_Name_String (V.Name)); Write_Str (To_String ((Max_Len - Get_Name_String (V.Name)'Length) * ' ')); if GPR.Tree.Present (V.Value.String_Type) then Write_Str (" : "); Write_Str (Get_Name_String (GPR.Tree.Name_Of (V.Value.String_Type, Node_Tree))); end if; Write_Str (" := " & Image (V.Value)); Write_Eol; end if; Vars := V.Next; end; end loop; end Create_Variables; --------------------- -- Data_Attributes -- --------------------- function Data_Attributes return String_Vector.Vector is procedure Gen_Dir_Name (P : Param; Line : in out Unbounded_String); -- Generate dir name ------------------ -- Gen_Dir_Name -- ------------------ procedure Gen_Dir_Name (P : Param; Line : in out Unbounded_String) is begin if P.Default then -- This is the default value, add Dir_Name Line := Line & Dir_Name (Suffix => False); -- Furthermore, if the build name is "default" do not output if Build_Name.all /= "default" then Line := Line & "." & Build_Name.all; end if; end if; end Gen_Dir_Name; V : String_Vector.Vector; Line : Unbounded_String; begin V.Append (" when """ & Build_Name.all & """ =>"); -- Project sources Line := +" for Source_Dirs use ("""; if Has_Sources (Project) then Line := Line & Relative_Path (Sources_Dir (Build_Name => False), To => Project_Dir); Gen_Dir_Name (Sources_Subdir, Line); end if; Line := Line & """);"; V.Append (-Line); -- Project objects and/or library if Project.Library then Line := +" for Library_Dir use """; else Line := +" for Object_Dir use """; end if; Line := Line & Relative_Path (Lib_Dir (Build_Name => False), To => Project_Dir); Gen_Dir_Name (Lib_Subdir, Line); Line := Line & """;"; V.Append (-Line); if Project.Library then -- If ALI are in a different location, set the corresponding -- attribute. if Lib_Dir /= ALI_Dir then Line := +" for Library_ALI_Dir use """; Line := Line & Relative_Path (ALI_Dir (Build_Name => False), To => Project_Dir); Gen_Dir_Name (ALI_Subdir, Line); Line := Line & """;"; V.Append (-Line); end if; Line := +" for Library_Kind use """; Line := Line & Image (Project.Library_Kind); Line := Line & """;"; V.Append (-Line); if Project.Standalone_Library /= No then if not Is_Static (Project) then Line := +" for Library_Standalone use """; Line := Line & To_Lower (Standalone'Image (Project.Standalone_Library)); Line := Line & """;"; V.Append (-Line); end if; -- And then generates the interfaces declare First : Boolean := True; V : constant Variable_Value := Value_Of (Name_Interfaces, Project.Decl.Attributes, Tree.Shared); procedure Source_Interface (Source : Source_Id); ---------------------- -- Source_Interface -- ---------------------- procedure Source_Interface (Source : Source_Id) is begin if Source.Unit /= No_Unit_Index then if not First then Append (Line, ", "); else First := False; end if; Append (Line, """"); Append (Line, Get_Name_String (Source.Unit.Name)); Append (Line, """"); end if; end Source_Interface; procedure List_Interfaces is new For_Interface_Sources (Source_Interface); begin if V /= Nil_Variable_Value and then not V.Default and then V.Values /= Nil_String then Line := +" for Interfaces use "; pragma Assert (V.Kind = List); Append (Line, Image (V)); else Line := +" for Library_Interface use ("; List_Interfaces (Tree, Project); Append (Line, ");"); end if; end; V.Append (-Line); end if; end if; return V; end Data_Attributes; ------------------- -- Get_Languages -- ------------------- function Get_Languages return String is package Lang_Set is new Containers.Indefinite_Ordered_Sets (String, Strings.Less_Case_Insensitive, Strings.Equal_Case_Insensitive); Langs : Lang_Set.Set; procedure For_Project (Project : Project_Id); -- Add languages for the given project ----------------- -- For_Project -- ----------------- procedure For_Project (Project : Project_Id) is L : Language_Ptr := Project.Languages; begin while L /= null loop if L.Config.Compiler_Driver /= No_File and then Get_Name_String (L.Config.Compiler_Driver) /= "" then Langs.Include (Get_Name_String (L.Display_Name)); end if; L := L.Next; end loop; end For_Project; begin -- First adds language for the main project For_Project (Project); -- If we are dealing with an aggregate library, adds the languages -- from all aggregated projects. if Project.Qualifier = Aggregate_Library then declare Agg : Aggregated_Project_List := Project.Aggregated_Projects; begin while Agg /= null loop For_Project (Agg.Project); Agg := Agg.Next; end loop; end; end if; declare Res : Unbounded_String; First : Boolean := True; begin for V of Langs loop if not First then Res := Res & ", "; end if; Res := Res & '"' & V & '"'; First := False; end loop; return To_String (Res); end; end Get_Languages; ----------------- -- Get_Package -- ----------------- function Get_Package (Project : Project_Id; Pkg_Name : Name_Id) return Package_Id is Pck : Package_Id := Project.Decl.Packages; begin while Pck /= No_Package loop if Pcks (Pck).Decl /= No_Declarations and then Pcks (Pck).Name = Pkg_Name then return Pck; end if; Pck := Pcks (Pck).Next; end loop; return No_Package; end Get_Package; ----------- -- Image -- ----------- function Image (Name : Name_Id; Id : Array_Element_Id) return String is E : constant Array_Element := Tree.Shared.Array_Elements.Table (Id); begin return "for " & Get_Name_String (Name) & " (""" & Get_Name_String (E.Index) & """) use " & Image (E.Value); end Image; function Image (Id : Variable_Id) return String is V : constant Variable_Value := Vels (Id).Value; begin if V.Default then return ""; else return "for " & Get_Name_String (Vels (Id).Name) & " use " & Image (V); end if; end Image; function Image (Var : Variable_Value) return String is begin case Var.Kind is when Single => return '"' & Get_Name_String (Var.Value) & '"' & (if Var.Index = 0 then "" else " at" & Var.Index'Img) & ';'; when List => declare V : Unbounded_String; L : String_List_Id := Var.Values; First : Boolean := True; begin Append (V, "("); while L /= Nil_String loop if not First then Append (V, ", "); else First := False; end if; Append (V, '"' & Get_Name_String (Strs (L).Value) & '"'); if Strs (L).Index > 0 then Append (V, " at" & Strs (L).Index'Img); end if; L := Strs (L).Next; end loop; Append (V, ");"); return To_String (V); end; when Undefined => return ""; end case; end Image; ----------------------------- -- Linker_Case_Alternative -- ----------------------------- function Linker_Case_Alternative (Proj : Project_Id) return String_Vector.Vector is use type Ada.Containers.Count_Type; procedure Linker_For (Pck : Package_Id); -- Handle the linker options for this package procedure Append (Values : String_List_Id); -- Add values if any procedure Add_Library_Options (Proj : Project_Id); -- For a library project, add the Library_Options procedure Opts_Append (Opt : String); -- Add options only if it was not appended before into Opts Seen : Seen_Set.Set; -- Records the attribute generated to avoid duplicate when -- handling aggregated projects. R : String_Vector.Vector; Opts : String_Vector.Vector; ------------------------- -- Add_Library_Options -- ------------------------- procedure Add_Library_Options (Proj : Project_Id) is begin if Proj.Library then declare V : constant Variable_Value := Value_Of (Name_Library_Options, Proj.Decl.Attributes, Tree.Shared); begin if V /= Nil_Variable_Value then Append (V.Values); end if; end; end if; end Add_Library_Options; ----------------- -- Opts_Append -- ----------------- procedure Opts_Append (Opt : String) is Position : Seen_Set.Cursor; Inserted : Boolean; begin Seen.Insert (Opt, Position, Inserted); if Inserted then Opts.Append (Opt); end if; end Opts_Append; ------------ -- Append -- ------------ procedure Append (Values : String_List_Id) is L : String_List_Id := Values; begin while L /= Nil_String loop Opts_Append (Get_Name_String (Strs (L).Value)); L := Strs (L).Next; end loop; end Append; ---------------- -- Linker_For -- ---------------- procedure Linker_For (Pck : Package_Id) is V : Variable_Id := Pcks (Pck).Decl.Attributes; begin while V /= No_Variable loop if Vels (V).Name = Name_Linker_Options then Append (Vels (V).Value.Values); end if; V := Vels (V).Next; end loop; end Linker_For; begin R.Append (" when """ & Build_Name.all & """ =>"); Linker_For (Get_Package (Proj, Name_Linker)); -- For libraries we want to add the library options here Add_Library_Options (Proj); if Proj.Qualifier = Aggregate_Library then declare Agg : Aggregated_Project_List := Project.Aggregated_Projects; begin while Agg /= null loop Linker_For (Get_Package (Agg.Project, Name_Linker)); -- Likewise for all aggregated libraries Add_Library_Options (Agg.Project); Agg := Agg.Next; end loop; end; end if; -- We also want to add the externally built libraries without -- sources (referencing system libraries for example). declare L : Project_List := Project.All_Imported_Projects; begin while L /= null loop if L.Project.Library and then L.Project.Externally_Built and then not Bring_Sources (L.Project) then Opts_Append ("-L" & Get_Name_String (L.Project.Library_Dir.Name)); Opts_Append ("-l" & Get_Name_String (L.Project.Library_Name)); end if; L := L.Next; end loop; end; if Opts.Length = 0 then -- No linker alternative found, add null statement R.Append (" null;"); else declare O_List : Unbounded_String; begin for O of Opts loop if O_List /= Null_Unbounded_String then Append (O_List, ", "); end if; Append (O_List, '"' & O & '"'); end loop; R.Append (" for Linker_Options use (" & To_String (O_List) & ");"); end; end if; return R; end Linker_Case_Alternative; ----------------------------- -- Naming_Case_Alternative -- ----------------------------- function Naming_Case_Alternative (Proj : Project_Id) return String_Vector.Vector is procedure Naming_For (Pck : Package_Id); -- Handle the naming scheme for this package function Is_Language_Active (Lang : String) return Boolean; -- Returns True if Lang is active in the installed project Seen : Seen_Set.Set; -- Records the attribute generated to avoid duplicate when -- handling aggregated projects. V : String_Vector.Vector; -- Contains the final result returned Languages : constant String := Characters.Handling.To_Lower (Get_Languages); -- Languages for the generated projects ------------------------ -- Is_Language_Active -- ------------------------ function Is_Language_Active (Lang : String) return Boolean is begin return Strings.Fixed.Index (Languages, Characters.Handling.To_Lower (Lang)) /= 0; end Is_Language_Active; ---------------- -- Naming_For -- ---------------- procedure Naming_For (Pck : Package_Id) is A : Array_Id := Pcks (Pck).Decl.Arrays; N, I : Name_Id; E : Array_Element_Id; begin -- Arrays while A /= No_Array loop N := Tree.Shared.Arrays.Table (A).Name; E := Tree.Shared.Arrays.Table (A).Value; I := Tree.Shared.Array_Elements.Table (E).Index; while E /= No_Array_Element loop -- Check if this naming is not to be filtered-out. This -- is a special case when a renaming is given for a -- body. See Excluded_Name comments. if (N /= Name_Body or else not Excluded_Naming.Contains (Get_Name_String (I))) and then (N not in Name_Spec_Suffix | Name_Body_Suffix | Name_Separate_Suffix or else Is_Language_Active (Get_Name_String (Tree.Shared.Array_Elements.Table (E).Index))) then declare Decl : constant String := Image (N, E); begin if not Seen.Contains (Decl) then V.Append (" " & Decl); Seen.Include (Decl); end if; end; end if; E := Tree.Shared.Array_Elements.Table (E).Next; end loop; A := Tree.Shared.Arrays.Table (A).Next; end loop; end Naming_For; begin V.Append (" when """ & Build_Name.all & """ =>"); Naming_For (Get_Package (Proj, Name_Naming)); if Proj.Qualifier = Aggregate_Library then declare Agg : Aggregated_Project_List := Project.Aggregated_Projects; begin while Agg /= null loop Naming_For (Get_Package (Agg.Project, Name_Naming)); Agg := Agg.Next; end loop; end; end if; return V; end Naming_Case_Alternative; ------------------ -- Read_Project -- ------------------ procedure Read_Project is Max_Buffer : constant := 1_024; File : File_Type; Buffer : String (1 .. Max_Buffer); Last : Natural; begin Open (File, In_File, Filename); while not End_Of_File (File) loop declare L : Unbounded_String; begin loop Get_Line (File, Buffer, Last); Append (L, Buffer (1 .. Last)); exit when Last < Max_Buffer or else End_Of_Line (File); end loop; Content.Append (To_String (L)); end; end loop; Close (File); end Read_Project; ------------------- -- Write_Project -- ------------------- procedure Write_Project is F : File_Access := Standard_Output; File : aliased File_Type; begin if not Dry_Run then if not Exists (Project_Dir) then Create_Path (Project_Dir); end if; Create (File, Out_File, Filename); F := File'Unchecked_Access; end if; for K in Content.First_Index .. Content.Last_Index loop Put_Line (F.all, Content.Element (K)); end loop; if not Dry_Run then Close (File); end if; end Write_Project; type Section_Kind is (Top, Naming, Linker); Project_Exists : constant Boolean := Exists (Filename); Current_Section : Section_Kind := Top; Pos : String_Vector.Cursor; Generated : Boolean := False; begin if Dry_Run or else Opt.Verbose_Mode then New_Line; Put ("Project "); Put (Filename); if Dry_Run then Put_Line (" would be installed"); else Put_Line (" installed"); end if; New_Line; end if; -- If project exists, read it and check the generated status if Project_Exists then Read_Project; -- First check that this project has been generated by gprbuild, -- if not exit with an error as we cannot modify a project created -- manually and we do not want to overwrite it. Pos := Content.First; Check_Generated_Status : while String_Vector.Has_Element (Pos) loop if Fixed.Index (String_Vector.Element (Pos), Gprinstall_Tag) /= 0 then Generated := True; exit Check_Generated_Status; end if; String_Vector.Next (Pos); end loop Check_Generated_Status; if not Generated and then not Force_Installations then Put ("non gprinstall project file "); Put (Filename); Put (" exists, use -f to overwrite"); New_Line; Finish_Program (Project_Tree, E_Fatal); end if; end if; if Project_Exists and then Generated then if not Has_Sources (Project) then -- Nothing else to do in this case return; end if; if Opt.Verbose_Mode then Put_Line ("project file exists, merging new build"); end if; -- Do merging for new build, we need to add an entry into the -- BUILD_KIND type and a corresponding case entry in the naming -- and Linker package. Parse_Content : while String_Vector.Has_Element (Pos) loop declare BN : constant String := Build_Name.all; Line : constant String := String_Vector.Element (Pos); P, L : Natural; begin if Fixed.Index (Line, "type BUILD_KIND is (") /= 0 then -- This is the "type BUILD_KIND" line, add new build name -- First check if the current build name already exists if Fixed.Index (Line, """" & BN & """") = 0 then -- Get end of line P := Fixed.Index (Line, ");"); if P = 0 then Fail_Program (Project_Tree, "cannot parse the BUILD_KIND line"); else Content.Replace_Element (Pos, Line (Line'First .. P - 1) & ", """ & BN & """);"); end if; end if; elsif Fixed.Index (Line, ":= external(") /= 0 then -- This is the BUILD line, get build vars declare Default : Unbounded_String; begin -- Get default value L := Fixed.Index (Line, """", Going => Strings.Backward); P := Fixed.Index (Line (Line'First .. L - 1), """", Going => Strings.Backward); Default := +Line (P + 1 .. L - 1); Content.Replace_Element (Pos, Get_Build_Line ((if Build_Vars = null then "" else Build_Vars.all), -Default)); end; elsif Fixed.Index (Line, "package Naming is") /= 0 then Current_Section := Naming; elsif Fixed.Index (Line, "package Linker is") /= 0 then Current_Section := Linker; elsif Fixed.Index (Line, "case BUILD is") /= 0 then -- Add new case section for the new build name case Current_Section is when Naming => String_Vector.Next (Pos); Content.Insert_Vector (Pos, Naming_Case_Alternative (Project)); when Linker => String_Vector.Next (Pos); Content.Insert_Vector (Pos, Linker_Case_Alternative (Project)); when Top => -- For the Sources/Lib attributes String_Vector.Next (Pos); Content.Insert_Vector (Pos, Data_Attributes); end case; elsif Fixed.Index (Line, "when """ & BN & """ =>") /= 0 then -- Found a when with the current build name, this is a -- previous install overwritten by this one. Remove this -- section. Note that this removes sections from all -- packages Naming and Linker, and from project level -- case alternative. Count_And_Delete : declare use type Containers.Count_Type; function End_When (L : String) return Boolean; -- Return True if L is the end of a when alternative -------------- -- End_When -- -------------- function End_When (L : String) return Boolean is P : constant Natural := Strings.Fixed.Index_Non_Blank (L); Len : constant Natural := L'Length; begin return P > 0 and then ((P + 4 <= Len and then L (P .. P + 4) = "when ") or else (P + 8 <= Len and then L (P .. P + 8) = "end case;")); end End_When; N : Containers.Count_Type := 0; P : String_Vector.Cursor := Pos; begin -- The number of line to delete are from Pos to the -- first line starting with a "when". loop String_Vector.Next (P); N := N + 1; exit when End_When (String_Vector.Element (P)); end loop; Content.Delete (Pos, N); end Count_And_Delete; end if; end; String_Vector.Next (Pos); end loop Parse_Content; else -- Project does not exist, or it exists, was not generated by -- gprinstall and -f used. In this case it will be overwritten by -- a generated project. Content.Clear; -- Tag project as generated by gprbuild Content.Append ("-- " & Gprinstall_Tag & ' ' & Gpr_Version_String); Add_Empty_Line; -- Handle with clauses, generate a with clauses only for project -- bringing some visibility to sources. No need for doing this for -- aggregate projects. if Project.Qualifier /= Aggregate_Library then declare L : Project_List := Project.Imported_Projects; begin while L /= null loop if Has_Sources (L.Project) and then Is_Install_Active (L.Project) then Content.Append ("with """ & Base_Name (Get_Name_String (L.Project.Path.Display_Name)) & """;"); end if; L := L.Next; end loop; end; end if; -- In all cases adds externally built projects declare L : Project_List := Project.All_Imported_Projects; begin while L /= null loop if Has_Sources (L.Project) and then L.Project.Externally_Built then Content.Append ("with """ & Base_Name (Get_Name_String (L.Project.Path.Display_Name)) & """;"); end if; L := L.Next; end loop; end; Add_Empty_Line; -- Project name if Project.Library then Line := +"library "; else if Has_Sources (Project) then Line := +"standard "; else Line := +"abstract "; end if; end if; Line := Line & "project "; Line := Line & Get_Name_String (Project.Display_Name); Line := Line & " is"; Content.Append (-Line); if Has_Sources (Project) or Project.Library then -- BUILD variable Content.Append (" type BUILD_KIND is (""" & Build_Name.all & """);"); Line := +Get_Build_Line (Vars => (if Build_Vars = null then "" else Build_Vars.all), Default => Build_Name.all); Content.Append (-Line); -- Add languages, for an aggregate library we want all unique -- languages from all aggregated libraries. if Has_Sources (Project) then Add_Empty_Line; Content.Append (" for Languages use (" & Get_Languages & ");"); end if; -- Build_Suffix used to avoid .default as suffix Add_Empty_Line; Content.Append (" case BUILD is"); Content.Append_Vector (Data_Attributes); Content.Append (" end case;"); Add_Empty_Line; -- Library Name if Project.Library then Content.Append (" for Library_Name use """ & Get_Name_String (Project.Library_Name) & """;"); -- Issue the Library_Version only if needed if not Is_Static (Project) and then Project.Lib_Internal_Name /= No_Name and then Project.Library_Name /= Project.Lib_Internal_Name then Content.Append (" for Library_Version use """ & Get_Name_String (Project.Lib_Internal_Name) & """;"); end if; end if; -- Packages if Has_Sources (Project) then Add_Empty_Line; Create_Packages; end if; -- Set as not installable Add_Empty_Line; Content.Append (" package Install is"); Content.Append (" for Active use ""False"";"); Content.Append (" end Install;"); -- Externally Built if not Sources_Only then Add_Empty_Line; Content.Append (" for Externally_Built use ""True"";"); end if; else -- This is an abstract project Content.Append (" for Source_Dirs use ();"); end if; -- Variables Add_Empty_Line; Create_Variables; -- Close project Content.Append ("end " & Get_Name_String (Project.Display_Name) & ";"); end if; -- Write new project if needed Write_Project; if not Dry_Run and then Install_Manifest then -- Add project file to manifest Add_To_Manifest (Filename); end if; end Create_Project; ------------------------- -- Open_Check_Manifest -- ------------------------- procedure Open_Check_Manifest (File : out Text_IO.File_Type; Current_Line : out Text_IO.Count) is Dir : constant String := Project_Dir & "manifests"; Name : constant String := Dir & DS & Install_Name.V.all; Prj_Sig : constant String := File_MD5 (Get_Name_String (Project.Path.Display_Name)); Buf : String (1 .. 128); Last : Natural; begin -- Check whether the manifest does not exist in this case if Exists (Name) then -- If this manifest is the same of the current aggregate -- one, do not try to reopen it. if not Is_Open (Agg_Manifest) or else Normalize_Pathname (Text_IO.Name (Agg_Manifest), Case_Sensitive => False) /= Normalize_Pathname (Name, Case_Sensitive => False) then Open (File, In_File, Name); Get_Line (File, Buf, Last); if Last >= Message_Digest'Length and then (Buf (1 .. 2) /= Sig_Line or else Buf (3 .. Message_Digest'Last + 2) /= Prj_Sig) and then Install_Name.Default and then Install_Project then Put_Line ("Project already installed, either:"); Put_Line (" - uninstall first using --uninstall option"); Put_Line (" - install under another name, use --install-name"); Put_Line (" - force installation under the same name, " & "use --install-name=" & Install_Name.V.all); Finish_Program (Project_Tree, E_Fatal); end if; Reset (File, Append_File); Current_Line := Line (File); end if; else Create_Path (Dir); Create (File, Out_File, Name); Current_Line := 1; Put_Line (File, Sig_Line & Prj_Sig); end if; exception when Text_IO.Use_Error => Put_Line ("cannot open or create the manifest file " & Project_Subdir.V.all & Install_Name.V.all); Put_Line ("check permissions on this location"); Finish_Program (Project_Tree, E_Fatal); end Open_Check_Manifest; ------------------------ -- Rollback_Manifests -- ------------------------ procedure Rollback_Manifests is Content : String_Vector.Vector; procedure Rollback_Manifest (File : in out Text_IO.File_Type; Line : Text_IO.Count); ----------------------- -- Rollback_Manifest -- ----------------------- procedure Rollback_Manifest (File : in out Text_IO.File_Type; Line : Text_IO.Count) is use type Ada.Containers.Count_Type; Dir : constant String := Containing_Directory (Name (File)) & DS; Buffer : String (1 .. 4_096); Last : Natural; begin -- Set manifest file in Read mode Reset (File, Text_IO.In_File); while not End_Of_File (File) loop Get_Line (File, Buffer, Last); if Text_IO.Line (File) = 2 or else Text_IO.Line (File) < Line then -- Record file to be kept in manifest Content.Append (Buffer (1 .. Last)); else -- Delete file declare Filename : constant String := Dir & Buffer (GNAT.MD5.Message_Digest'Length + 2 .. Last); begin Ada.Directories.Delete_File (Filename); Delete_Empty_Directory (Prefix_Dir.V.all, Containing_Directory (Filename)); end; end if; end loop; -- There is nothing left in the manifest file (only the signature -- line), remove it, otherwise we create the new manifest file -- containing only the previous content. if Content.Length = 1 then declare Manifest_Filename : constant String := Name (File); begin Delete (File); -- Delete manifest directories if empty Delete_Empty_Directory (Prefix_Dir.V.all, Containing_Directory (Manifest_Filename)); end; else -- Set manifest file back to Write mode Reset (File, Text_IO.Out_File); for C of Content loop Text_IO.Put_Line (File, C); end loop; Close (File); end if; end Rollback_Manifest; begin if Is_Open (Man) then Rollback_Manifest (Man, Line_Manifest); end if; if Is_Open (Agg_Manifest) then Rollback_Manifest (Agg_Manifest, Line_Agg_Manifest); end if; end Rollback_Manifests; Is_Project_To_Install : Boolean; -- Whether the project is to be installed begin -- Empty Content Content.Delete_First (Count => Ada.Containers.Count_Type'Last); -- First look for the Install package and set up the local values -- accordingly. Check_Install_Package; -- The default install name is the name of the project without -- extension. if Install_Name.Default then Install_Name.V := new String'((Base_Name (Get_Name_String (Project.Path.Name)))); end if; -- Skip non active project and externally built ones Is_Project_To_Install := Active and (Bring_Sources (Project) or Project.Externally_Built); -- If we have an aggregate project we just install separately all -- aggregated projects. if Project.Qualifier = Aggregate then -- If this is the main project and is an aggregate project, create -- the corresponding manifest. if Project = Main_Project and then Main_Project.Qualifier = Aggregate and then Install_Manifest then Open_Check_Manifest (Agg_Manifest, Line_Agg_Manifest); end if; declare L : Aggregated_Project_List := Project.Aggregated_Projects; begin while L /= null loop Process (L.Tree, L.Node_Tree, L.Project); L := L.Next; end loop; end; -- Nothing more to do for an aggregate project return; end if; if not Installed.Contains (Project.Name) then Installed.Include (Project.Name); if not Opt.Quiet_Output then if Is_Project_To_Install then Put ("Install"); elsif Opt.Verbose_Mode then Put ("Skip"); end if; if Is_Project_To_Install or Opt.Verbose_Mode then Put (" project "); Put (Get_Name_String (Project.Display_Name)); if Build_Name.all /= "default" then Put (" - " & Build_Name.all); end if; end if; if not Is_Project_To_Install and Opt.Verbose_Mode then Put (" (not active)"); end if; if Is_Project_To_Install or Opt.Verbose_Mode then New_Line; end if; end if; -- If this is not an active project, just return now if not Is_Project_To_Install then return; end if; -- What should be copied Copy := (Source => For_Dev, Object => For_Dev and then Project.Mains = Nil_String and then Project.Qualifier /= Library and then Project.Qualifier /= Aggregate_Library and then not Project.Library, Dependency => For_Dev and then Project.Mains = Nil_String, Library => Project.Library and then ((For_Dev and then Is_Static (Project)) or else not Is_Static (Project)), Executable => Project.Mains /= Nil_String); -- Copy all files from the project Copy_Files; -- A project file is only needed in developer mode if For_Dev and then Install_Project then Create_Project (Project); end if; -- Add manifest into the main aggregate project manifest if Is_Open (Man) then if Is_Open (Agg_Manifest) then declare Filename : constant String := Project_Dir & "manifests" & DS & Simple_Name (Name (Man)); begin Close (Man); Add_To_Manifest (Filename, Aggregate_Only => True); end; else Close (Man); end if; end if; -- Handle all projects recursively if needed if Recursive then declare L : Project_List := Project.Imported_Projects; begin while L /= null loop Process (Tree, Node_Tree, L.Project); L := L.Next; end loop; end; end if; end if; Free (Prefix_Dir); Free (Sources_Subdir); Free (Lib_Subdir); Free (Exec_Subdir); Free (Project_Subdir); end Process; ------------------- -- Double_Buffer -- ------------------- procedure Double_Buffer is New_Buffer : constant GNAT.OS_Lib.String_Access := new String (1 .. Buffer'Last * 2); begin New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last); Free (Buffer); Buffer := New_Buffer; end Double_Buffer; ---------------- -- Write_Char -- ---------------- procedure Write_Char (C : Character) is begin if Buffer_Last = Buffer'Last then Double_Buffer; end if; Buffer_Last := Buffer_Last + 1; Buffer (Buffer_Last) := C; end Write_Char; --------------- -- Write_Eol -- --------------- procedure Write_Eol is begin Content.Append (New_Item => (Buffer (1 .. Buffer_Last))); Buffer_Last := 0; end Write_Eol; --------------- -- Write_Str -- --------------- procedure Write_Str (S : String) is begin while Buffer_Last + S'Length > Buffer'Last loop Double_Buffer; end loop; Buffer (Buffer_Last + 1 .. Buffer_Last + S'Length) := S; Buffer_Last := Buffer_Last + S'Length; end Write_Str; end Gprinstall.Install; gprbuild-25.0.0/src/gprinstall-install.ads000066400000000000000000000031531470075373400205250ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2012-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ with GPR; package Gprinstall.Install is procedure Process (Tree : GPR.Project_Tree_Ref; Node_Tree : GPR.Project_Node_Tree_Ref; Project : GPR.Project_Id); -- Install Project and possibly all imported projects depending on the -- options. end Gprinstall.Install; gprbuild-25.0.0/src/gprinstall-main.adb000066400000000000000000001011251470075373400177600ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2012-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; use Ada.Command_Line; with Ada.Directories; with Ada.Exceptions; use Ada.Exceptions; with Ada.Text_IO; use Ada.Text_IO; with GNAT.Case_Util; use GNAT.Case_Util; with GNAT.Command_Line; use GNAT.Command_Line; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.OS_Lib; use GNAT.OS_Lib; with Gpr_Build_Util; use Gpr_Build_Util; with GPR.Conf; use GPR.Conf; with GPR.Env; with GPR.Err; with GPR.Names; use GPR.Names; with GPR.Opt; use GPR.Opt; with GPR.Osint; use GPR.Osint; with GPR.Proc; use GPR.Proc; with GPR.Snames; use GPR.Snames; with GPR.Tree; use GPR.Tree; with GPR.Util; use GPR.Util; with Gprinstall.DB; with Gprinstall.Install; with Gprinstall.Uninstall; procedure Gprinstall.Main is -- Options specific to gprinstall Build_Var_Option : constant String := "--build-var"; No_Build_Var_Option : constant String := "--no-build-var"; Build_Name_Option : constant String := "--build-name"; Install_Name_Option : constant String := "--install-name"; Uninstall_Option : constant String := "--uninstall"; Mode_Option : constant String := "--mode"; ALI_Subdir_Option : constant String := "--ali-subdir"; Lib_Subdir_Option : constant String := "--lib-subdir"; Link_Lib_Subdir_Option : constant String := "--link-lib-subdir"; Exec_Subdir_Option : constant String := "--exec-subdir"; Sources_Subdir_Option : constant String := "--sources-subdir"; Project_Subdir_Option : constant String := "--project-subdir"; No_Lib_Link_Option : constant String := "--no-lib-link"; List_Option : constant String := "--list"; Stat_Option : constant String := "--stat"; Sources_Only_Option : constant String := "--sources-only"; Side_Debug_Option : constant String := "--side-debug"; No_Manifest_Option : constant String := "--no-manifest"; Opt_A_Set : Boolean := False; -- to detect if -a and -m are used together Opt_M_Set : Boolean := False; -- likewise procedure Initialize; -- Do the necessary package initialization and process the command line -- arguments. procedure Usage; -- Display the usage procedure Scan_Arg (Arg : String; Command_Line : Boolean; Success : out Boolean); -- Process one gprinstall argument Arg. Command_Line is True if the -- argument is specified on the command line. Optional parameter Additional -- gives additional information about the origin of the argument if it is -- found illegal. procedure Copyright; -- Output the Copyright notice type Sigint_Handler is access procedure; pragma Convention (C, Sigint_Handler); procedure Install_Int_Handler (Handler : Sigint_Handler); pragma Import (C, Install_Int_Handler, "__gnat_install_int_handler"); -- Called by Gnatmake to install the SIGINT handler below --------------- -- Copyright -- --------------- procedure Copyright is begin -- Only output the Copyright notice once if not Copyright_Output then Copyright_Output := True; Display_Version ("GPRINSTALL", "2012"); end if; end Copyright; -------------- -- Scan_Arg -- -------------- procedure Scan_Arg (Arg : String; Command_Line : Boolean; Success : out Boolean) is function Has_Prefix (Name : String) return Boolean; -- Returns True if Arg start with Name procedure Set_Param (P : in out Param; Name : String; Is_Dir : Boolean := True; Normalize : Boolean := False); -- Set P with value for option Name ---------------- -- Has_Prefix -- ---------------- function Has_Prefix (Name : String) return Boolean is begin pragma Assert (Arg'First = 1); return Arg'Length >= Name'Length and then Arg (1 .. Name'Length) = Name; end Has_Prefix; --------------- -- Set_Param -- --------------- procedure Set_Param (P : in out Param; Name : String; Is_Dir : Boolean := True; Normalize : Boolean := False) is Value : constant String := Arg (Name'Length + 2 .. Arg'Last); begin P := (new String' ((if Is_Dir then (if Normalize then Ensure_Directory (Normalize_Pathname (Value)) else Ensure_Directory (Value)) else Value)), False); end Set_Param; Processed : Boolean := True; begin pragma Assert (Arg'First = 1); Success := True; if Arg'Length = 0 then return; end if; -- If preceding switch was -P, a project file name need to be -- specified, not a switch. if Project_File_Name_Expected then if Arg (1) = '-' then Fail_Program (Project_Tree, "project file name missing after -P"); else Project_File_Name_Expected := False; Project_File_Name := new String'(Arg); end if; -- If preceding switch was -o, an executable name need to be -- specified, not a switch. elsif Search_Project_Dir_Expected then if Arg (1) = '-' then Fail_Program (Project_Tree, "directory name missing after -aP"); else Search_Project_Dir_Expected := False; GPR.Env.Add_Directories (Root_Environment.Project_Path, Arg); end if; elsif Db_Directory_Expected then Db_Directory_Expected := False; Knowledge.Parse_Knowledge_Base (Project_Tree, Arg); -- Set the processor/language for the following switches -- Switches start with '-' elsif Arg (1) = '-' then if Has_Prefix (Source_Info_Option) then Project_Tree.Source_Info_File_Name := new String'(Arg (Source_Info_Option'Length + 1 .. Arg'Last)); elsif Has_Prefix (Config_Project_Option) then if Config_Project_File_Name /= null and then (Autoconf_Specified or else Config_Project_File_Name.all /= Arg (Config_Project_Option'Length + 1 .. Arg'Last)) then Fail_Program (Project_Tree, "several different configuration switches " & "cannot be specified"); else Autoconfiguration := False; Autoconf_Specified := False; Config_Project_File_Name := new String' (Arg (Config_Project_Option'Length + 1 .. Arg'Last)); end if; elsif Has_Prefix (Autoconf_Project_Option) then if Config_Project_File_Name /= null and then (not Autoconf_Specified or else Config_Project_File_Name.all /= Arg (Autoconf_Project_Option'Length + 1 .. Arg'Last)) then Fail_Program (Project_Tree, "several different configuration switches " & "cannot be specified"); else Config_Project_File_Name := new String' (Arg (Autoconf_Project_Option'Length + 1 .. Arg'Last)); Autoconf_Specified := True; end if; elsif Has_Prefix (RTS_Option) then declare Set : constant Boolean := Runtime_Name_Set_For (Name_Ada); Old : constant String := Runtime_Name_For (Name_Ada); RTS : constant String := Arg (RTS_Option'Length + 1 .. Arg'Last); begin if Command_Line then if Set and then Old /= RTS then Fail_Program (Project_Tree, "several different run-times cannot be specified"); end if; Set_Runtime_For (Name_Ada, RTS); Set_Default_Runtime_For (Name_Ada, RTS); end if; -- Ignore any --RTS= switch in package Builder. These are only -- taken into account to create the config file in -- auto-configuration. end; elsif Arg = "-h" then Usage_Needed := True; elsif Arg = "-p" or else Arg = "--create-missing-dirs" then Create_Dest_Dir := True; elsif Arg'Length >= 2 and then Arg (2) = 'P' then if Project_File_Name /= null then Fail_Program (Project_Tree, "cannot have several project files specified"); elsif Arg'Length = 2 then Project_File_Name_Expected := True; else Project_File_Name := new String'(Arg (3 .. Arg'Last)); end if; elsif Arg'Length >= 3 and then Arg (1 .. 3) = "-aP" then if Arg'Length = 3 then Search_Project_Dir_Expected := True; else GPR.Env.Add_Directories (Root_Environment.Project_Path, Arg (4 .. Arg'Last)); end if; elsif Arg = "-q" then Opt.Quiet_Output := True; Opt.Verbose_Mode := False; Opt.Verbosity_Level := Opt.None; elsif Arg = "-r" then Recursive := True; elsif Arg = "-v" then Opt.Verbose_Mode := True; Opt.Verbosity_Level := Opt.High; Opt.Quiet_Output := False; elsif Arg = "-f" then Force_Installations := True; elsif Arg = "-a" then if Opt_M_Set then Fail_Program (Project_Tree, "cannot use -a and -m together"); else All_Sources := True; Opt_A_Set := True; end if; elsif Arg = "-m" then if Opt_A_Set then Fail_Program (Project_Tree, "cannot use -m and -a together"); else All_Sources := False; Opt_M_Set := True; end if; elsif Arg = "-eL" then Opt.Follow_Links_For_Files := True; Opt.Follow_Links_For_Dirs := True; elsif Arg = "-d" then Dry_Run := True; elsif Arg'Length >= 3 and then Arg (2) = 'X' and then Is_External_Assignment (Root_Environment, Arg) then -- Is_External_Assignment has side effects when it returns True null; elsif Arg'Length > 1 and then Arg (2) = '-' then if Has_Prefix (Prefix_Project_Option) then Set_Param (Global_Prefix_Dir, Prefix_Project_Option, Normalize => True); elsif Has_Prefix (Exec_Subdir_Option) then Set_Param (Global_Exec_Subdir, Exec_Subdir_Option); elsif Has_Prefix (Lib_Subdir_Option) then Set_Param (Global_Lib_Subdir, Lib_Subdir_Option); elsif Has_Prefix (ALI_Subdir_Option) then Set_Param (Global_ALI_Subdir, ALI_Subdir_Option); elsif Has_Prefix (Link_Lib_Subdir_Option) then Set_Param (Global_Link_Lib_Subdir, Link_Lib_Subdir_Option); elsif Has_Prefix (Sources_Subdir_Option) then Set_Param (Global_Sources_Subdir, Sources_Subdir_Option); elsif Has_Prefix (Project_Subdir_Option) then Set_Param (Global_Project_Subdir, Project_Subdir_Option); elsif Has_Prefix (Build_Var_Option) then if Build_Vars = null then Build_Vars := new String' (Arg (Build_Var_Option'Length + 2 .. Arg'Last)); else Build_Vars := new String' ((Arg (Build_Var_Option'Length + 2 .. Arg'Last)) & ',' & Build_Vars.all); end if; elsif Has_Prefix (No_Build_Var_Option) then No_Build_Var := True; elsif Has_Prefix (Build_Name_Option) then Free (Build_Name); Build_Name := new String' (Arg (Build_Name_Option'Length + 2 .. Arg'Last)); elsif Has_Prefix (Install_Name_Option) then Set_Param (Global_Install_Name, Install_Name_Option, Is_Dir => False); elsif Has_Prefix (Sources_Only_Option) then Sources_Only := True; elsif Has_Prefix (Uninstall_Option) then Usage_Mode := Uninstall_Mode; elsif Has_Prefix (List_Option) then Usage_Mode := List_Mode; elsif Has_Prefix (Stat_Option) then Output_Stats := True; elsif Has_Prefix (Side_Debug_Option) then Side_Debug := True; elsif Has_Prefix (Mode_Option) then declare Mode : String := Arg (Mode_Option'Length + 2 .. Arg'Last); begin To_Lower (Mode); if Mode in "dev" | "usage" then Set_Param (Global_Install_Mode, Mode_Option, Is_Dir => False); else Processed := False; end if; end; elsif Has_Prefix (Dry_Run_Option) then Dry_Run := True; elsif Has_Prefix (No_Project_Option) then Global_Install_Project := False; elsif Has_Prefix (No_Manifest_Option) then Install_Manifest := False; elsif Has_Prefix (No_Lib_Link_Option) then Add_Lib_Link := False; elsif Has_Prefix (Subdirs_Option) then Subdirs := new String'(Arg (Subdirs_Option'Length + 1 .. Arg'Last)); elsif Arg'Length >= Relocate_Build_Tree_Option'Length and then Arg (1 .. Relocate_Build_Tree_Option'Length) = Relocate_Build_Tree_Option then if Arg'Length = Relocate_Build_Tree_Option'Length then Build_Tree_Dir := new String'(Get_Current_Dir); else declare Dir : constant String := Ensure_Directory (Arg (Relocate_Build_Tree_Option'Length + 2 .. Arg'Last)); begin if Is_Absolute_Path (Dir) then Build_Tree_Dir := new String'(Dir); else Build_Tree_Dir := new String'(Get_Current_Dir & Dir); end if; end; end if; -- Out-of-tree compilation also imply -p (create missing dirs) Opt.Create_Dirs := Create_All_Dirs; elsif Arg'Length >= Root_Dir_Option'Length and then Arg (1 .. Root_Dir_Option'Length) = Root_Dir_Option then Root_Dir := new String' (Normalize_Pathname (Arg (Root_Dir_Option'Length + 2 .. Arg'Last), Get_Current_Dir, Resolve_Links => Opt.Follow_Links_For_Dirs) & Dir_Separator); elsif Has_Prefix (Target_Project_Option) then if Target_Name /= null then if Target_Name.all /= Arg (Target_Project_Option'Length + 1 .. Arg'Last) then Fail_Program (Project_Tree, "several different target switches " & "cannot be specified"); end if; else Target_Name := new String' (Arg (Target_Project_Option'Length + 1 .. Arg'Last)); end if; else Processed := False; end if; else Processed := False; end if; elsif Command_Line then -- The file name of a main or a project file declare File_Name : String := Arg; begin Canonical_Case_File_Name (File_Name); if Usage_Mode = Uninstall_Mode or else (File_Name'Length > Project_File_Extension'Length and then File_Name (File_Name'Last - Project_File_Extension'Length + 1 .. File_Name'Last) = Project_File_Extension) then if Project_File_Name /= null then Fail_Program (Project_Tree, "cannot have several project files specified"); else Project_File_Name := new String'(File_Name); end if; else -- Not a project file, then it is a main Fail_Program (Project_Tree, "only project files expected"); end if; end; else Processed := False; end if; if not Processed then if Command_Line then Fail_Program (Project_Tree, "illegal option """ & Arg & """ on the command line"); end if; end if; end Scan_Arg; ---------------- -- Initialize -- ---------------- procedure Initialize is procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage); begin -- Do some necessary package initializations Snames.Initialize; Set_Program_Name ("gprinstall"); GPR.Tree.Initialize (Root_Environment, Gprinstall_Flags); GPR.Tree.Initialize (Project_Node_Tree); GPR.Initialize (Project_Tree); Mains.Delete; -- Get the command line arguments, starting with --version and --help Check_Version_And_Help ("GPRINSTALL", "2012"); -- Now process the other options Autoconfiguration := True; declare Do_Not_Care : Boolean; begin Scan_Args : for Next_Arg in 1 .. Argument_Count loop Scan_Arg (Argument (Next_Arg), Command_Line => True, Success => Do_Not_Care); end loop Scan_Args; end; -- If --lib-subdir set and not --ali-subdir then makes the later with -- --lib-subdir. if not Global_Lib_Subdir.Default and then Global_ALI_Subdir.Default then Global_ALI_Subdir := Dup (Global_Lib_Subdir); end if; GPR.Env.Initialize_Default_Project_Path (Root_Environment.Project_Path, Target_Name => "-"); if Opt.Verbose_Mode then Copyright; end if; if Usage_Needed then Usage; Usage_Needed := False; end if; -- Fail if command line ended with "-P" if Project_File_Name_Expected then Fail_Program (Project_Tree, "project file name missing after -P"); elsif Search_Project_Dir_Expected then Fail_Program (Project_Tree, "directory name missing after -aP"); end if; if Build_Name.all /= "default" and then Usage_Mode = Uninstall_Mode then Fail_Program (Project_Tree, "cannot specify --build-name in uninstall mode"); end if; if Build_Vars /= null and then Usage_Mode = Uninstall_Mode then Fail_Program (Project_Tree, "cannot specify --build-var in uninstall mode"); end if; if Build_Vars /= null and then No_Build_Var then Fail_Program (Project_Tree, "cannot specify --build-var and --no-build-var"); end if; if Output_Stats and then Usage_Mode /= List_Mode then Fail_Program (Project_Tree, "cannot specify --stat in install/uninstall mode"); end if; if not Global_Install_Project and then not Global_Project_Subdir.Default then Fail_Program (Project_Tree, "cannot specify --no-project and --project-subdir"); end if; if Load_Standard_Base then -- We need to parse the knowledge base so that we are able to -- normalize the target names. Unfortunately, if we have to spawn -- gprconfig, it will also have to parse that knowledge base on -- its own. Knowledge.Parse_Knowledge_Base (Project_Tree); end if; -- If no project file was specified, look first for a default if Project_File_Name = null and then Usage_Mode /= List_Mode then Try_Help; Fail_Program (Project_Tree, "no project file specified"); end if; -- Check prefix, if not specified set to default toolchain if Global_Prefix_Dir.V = null then -- Set to default for current toolchain Global_Prefix_Dir := (new String'(Executable_Prefix_Path), True); elsif Global_Prefix_Dir.V.all = "" then Fail_Program (Project_Tree, "--prefix argument cannot be empty"); end if; -- Do not require directory to be present in Sources_Only mode Opt.Directories_Must_Exist_In_Projects := not Sources_Only; -- Check consistency of out-of-tree build options if Root_Dir /= null and then Build_Tree_Dir = null then Fail_Program (Project_Tree, "cannot use --root-dir without --relocate-build-tree option"); end if; end Initialize; ----------- -- Usage -- ----------- procedure Usage is begin if not Usage_Output then Usage_Output := True; Put ("Usage: "); Write_Program_Name; Put (" [-P] [.gpr] [opts]"); New_Line; New_Line; -- GPRINSTALL switches Put ("gprinstall switches:"); New_Line; Display_Usage_Version_And_Help; -- Line for Config_Project_Option Put (" "); Put (Config_Project_Option); Put ("file.cgpr"); New_Line; Put (" Specify the main config project file name"); New_Line; -- Line for Autoconf_Project_Option Put (" "); Put (Autoconf_Project_Option); Put ("file.cgpr"); New_Line; Put (" Specify/create the main config project file name"); New_Line; Put (" --RTS="); New_Line; Put (" Use runtime for language Ada"); New_Line; -- Line for --prefix Put_Line (" --prefix="); Put_Line (" Install destination directory"); Put_Line (" --install-name="); Put_Line (" The name of the installation"); Put_Line (" --sources-subdir="); Put_Line (" The sources directory/sub-directory"); Put_Line (" --ali-subdir="); Put_Line (" The ALI directory/sub-directory"); Put_Line (" --lib-subdir="); Put_Line (" The library directory/sub-directory"); Put_Line (" --link-lib-subdir="); Put_Line (" The symlib directory/sub-directory to libraries"); Put_Line (" --exec-subdir="); Put_Line (" The executables directory/sub-directory"); Put_Line (" --project-subdir="); Put_Line (" The project directory/sub-directory"); Put_Line (" --no-lib-link"); Put_Line (" Do not copy shared lib in exec/lib directory"); Put_Line (" --sources-only"); Put_Line (" Copy project sources only"); Put_Line (" --side-debug"); Put_Line (" Write debug information into a separate file"); -- Line for --relocate-build-tree= Put (" --relocate-build-tree[=dir]"); New_Line; Put (" Root obj/lib/exec dirs are current-directory" & " or dir"); New_Line; -- Line for --root-dir= Put (" --root-dir=dir"); New_Line; Put (" Root directory of obj/lib/exec to relocate"); New_Line; -- Line for --subdirs= Put_Line (" --subdirs=dir"); Put_Line (" Use dir as suffix to obj/lib/exec directories"); -- Line for Target_Project_Option Put (" "); Put (Target_Project_Option); Put ("targetname"); New_Line; Put (" Specify a target for cross platforms"); New_Line; -- Line for --dry-run Put_Line (" -d, --dry-run"); Put_Line (" Execute nothing, display commands"); -- Line for --build-var Put_Line (" --build-var="); Put_Line (" Name of the variable which identify a build"); -- Line for --no-manifest Put_Line (" --no-manifest"); Put_Line (" Do not generate the manifest File"); -- Line for --no-build-var Put_Line (" --no-build-var"); Put_Line (" Do not generate external build variable"); -- Line for --build-name Put_Line (" --build-name="); Put_Line (" Build name value (default is ""Default"")"); -- Line for --no-project Put_Line (" --no-project"); Put_Line (" Do not install project file"); -- Line for --mode Put_Line (" --mode=[dev|usage]"); Put_Line (" Kind of installation (default is ""dev"")"); -- Line for --uninstall Put_Line (" --uninstall"); Put_Line (" Remove all previously installed files"); -- Lines for --list/--stat Put_Line (" --list"); Put_Line (" List all installed projects"); Put_Line (" --stat"); Put_Line (" Display stats about installed projects, must be " & "used with --list"); -- Line for -aP Put_Line (" -aP dir Add directory dir to project search path"); -- Line for -eL Put_Line (" -eL " & "Follow symbolic links when processing project files"); -- Line for -P Put_Line (" -P proj Use Project File proj"); -- Line for -p Put_Line (" -p, --create-missing-dirs"); Put_Line (" Create missing directories"); -- Line for -q Put_Line (" -q Be quiet/terse"); -- Line for -r Put_Line (" -r Recursive"); -- Line for -a Put_Line (" -a Copy all source files (default)"); -- Line for -m Put_Line (" -m Minimal copy of sources (only those needed)"); -- Line for -f Put_Line (" -f Force installation, overwrite files"); -- Line for -v Put_Line (" -v Verbose output"); -- Line for -X Put_Line (" -Xnm=val Specify an external reference for " & "Project Files"); New_Line; end if; end Usage; User_Project_Node : Project_Node_Id; begin -- First initialize and read the command line arguments Initialize; -- And install Ctrl-C handler Install_Int_Handler (Gprinstall.Sigint_Intercepted'Access); -- Add the external variable GPR_TOOL (default value "gprbuild") Add_Gpr_Tool_External; -- Check command line arguments. These will be overridden when looking -- for the configuration file if Target_Name = null then Target_Name := new String'(""); end if; if Config_Project_File_Name = null then Config_Project_File_Name := new String'((if Sources_Only then "auto.cgpr" else "")); end if; -- Then, parse the user's project and the configuration file. Apply the -- configuration file to the project so that its settings are -- automatically inherited by the project. -- If either the project or the configuration file contains errors, the -- following call with call Fail_Program and never return if Usage_Mode = Install_Mode then begin Main_Project := No_Project; Parse_Project_And_Apply_Config (Main_Project => Main_Project, User_Project_Node => User_Project_Node, Config_File_Name => Config_Project_File_Name.all, Autoconf_Specified => Autoconf_Specified, Project_File_Name => Project_File_Name.all, Project_Tree => Project_Tree, Env => Root_Environment, Project_Node_Tree => Project_Node_Tree, Packages_To_Check => Packages_To_Check, Allow_Automatic_Generation => Autoconfiguration, Automatically_Generated => Delete_Autoconf_File, Config_File_Path => Configuration_Project_Path, Target_Name => Target_Name.all, Normalized_Hostname => Knowledge.Normalized_Hostname, Implicit_Project => No_Project_File_Found); exception when E : GPR.Conf.Invalid_Config | Name_Error => Fail_Program (Project_Tree, Exception_Message (E)); end; if Main_Project = No_Project then -- Don't flush messages in case of parsing error. This has already -- been taken care when parsing the tree. Otherwise, it results in -- the same message being displayed twice. Fail_Program (Project_Tree, """" & Project_File_Name.all & """ processing failed", Flush_Messages => Present (User_Project_Node)); end if; if Configuration_Project_Path /= null then Free (Config_Project_File_Name); Config_Project_File_Name := new String' (Base_Name (Configuration_Project_Path.all)); end if; if Total_Errors_Detected > 0 then GPR.Err.Finalize; Fail_Program (Project_Tree, "problems while getting the configuration", Flush_Messages => False); end if; Main_Project_Dir := new String'(Get_Name_String (Main_Project.Directory.Display_Name)); if Warnings_Detected > 0 then GPR.Err.Finalize; GPR.Err.Initialize; end if; Mains.Fill_From_Project (Main_Project, Project_Tree); Mains.Complete_Mains (Root_Environment.Flags, Main_Project, Project_Tree); Compute_All_Imported_Projects (Main_Project, Project_Tree); Install.Process (Project_Tree, Project_Node_Tree, Main_Project); if Warnings_Detected /= 0 then GPR.Err.Finalize; end if; elsif Usage_Mode = List_Mode then DB.List; else if Global_Install_Name.Default then Uninstall.Process (Ada.Directories.Compose (Ada.Directories.Containing_Directory (Project_File_Name.all), Ada.Directories.Base_Name (Project_File_Name.all))); else Uninstall.Process (Global_Install_Name.V.all); end if; end if; if Usage_Mode = Install_Mode then Finish_Program (Project_Tree); else Delete_All_Temp_Files (Project_Tree.Shared); end if; end Gprinstall.Main; gprbuild-25.0.0/src/gprinstall-uninstall.adb000066400000000000000000000203171470075373400210500ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2012-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ with Ada.Directories; use Ada.Directories; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with Ada.Text_IO; use Ada.Text_IO; with GNAT.MD5; use GNAT.MD5; with GPR.Opt; with GPR.Osint; use GPR; with GPR.Util; use GPR.Util; package body Gprinstall.Uninstall is package File_Set renames GPR.String_Sets; ------------- -- Process -- ------------- procedure Process (Install_Name : String) is procedure Delete_File (Position : File_Set.Cursor); -- Delete file pointed to by Position, do nothing if the file is not -- found. procedure Do_Delete (Filename : String); -- Delete file or display a message if in dry-run mode procedure Delete_Empty_Directory (Dir_Name : String); -- Delete Dir_Name if empty, if removed try with parent directory function Project_Dir return String; -- Returns the full pathname to the project directory ---------------------------- -- Delete_Empty_Directory -- ---------------------------- procedure Delete_Empty_Directory (Dir_Name : String) is begin Delete_Empty_Directory (Global_Prefix_Dir.V.all, Dir_Name); end Delete_Empty_Directory; ----------------- -- Delete_File -- ----------------- procedure Delete_File (Position : File_Set.Cursor) is Pathname : constant String := File_Set.Element (Position); begin Do_Delete (Pathname); end Delete_File; --------------- -- Do_Delete -- --------------- procedure Do_Delete (Filename : String) is Success : Boolean; begin if Dry_Run then Put_Line ("delete " & Filename); else Delete_File (Filename, Success); Delete_Empty_Directory (Containing_Directory (Filename)); end if; end Do_Delete; ----------------- -- Project_Dir -- ----------------- function Project_Dir return String is begin if Is_Absolute_Path (Install_Name) then return Containing_Directory (Containing_Directory (Install_Name)); else if Is_Absolute_Path (Global_Project_Subdir.V.all) then return Global_Project_Subdir.V.all; else return Global_Prefix_Dir.V.all & Global_Project_Subdir.V.all; end if; end if; end Project_Dir; Dir : constant String := (if Is_Absolute_Path (Install_Name) then Containing_Directory (Install_Name) else Project_Dir & "manifests"); Name : constant String := (if Is_Absolute_Path (Install_Name) then Install_Name else Dir & DS & Install_Name); Man : File_Type; Buffer : String (1 .. 4096); Last : Natural; Files : File_Set.Set; Changed : File_Set.Set; -- Ranges in Buffer above, we have the MD5 (32 chars) a space and then -- the filename. subtype MD5_Range is Positive range Message_Digest'Range; subtype Name_Range is Positive range MD5_Range'Last + 2 .. Buffer'Last; File_Digest : Message_Digest; Expected_Digest : Message_Digest; Removed : Boolean; Prefix : Unbounded_String; begin -- Check if manifest for this project exists if not Exists (Name) then if not Opt.Quiet_Output then Fail_Program (Project_Tree, "Manifest " & Name & " not found."); end if; Finish_Program (Project_Tree, Exit_Code => Osint.E_General); end if; if not Opt.Quiet_Output then Put_Line ("Uninstall project " & Install_Name); end if; -- Check each file to be deleted Open (Man, In_File, Name); while not End_Of_File (Man) loop Get_Line (Man, Buffer, Last); -- Skip first line if it is the original project's signature if Last > MD5_Range'Last and then Buffer (1 .. 2) /= Sig_Line then declare F_Name : constant String := Buffer (Name_Range'First .. Last); Pathname : constant String := (if Exists (Dir & DS & F_Name) then Dir & DS & F_Name else Global_Prefix_Dir.V.all & F_Name); -- For upward compatibility we fallback into previous location begin Expected_Digest := Buffer (MD5_Range); if Exists (Pathname) then File_Digest := File_MD5 (Pathname); Removed := False; else Removed := True; end if; if Global_Prefix_Dir.Default then if Prefix = Null_Unbounded_String then Prefix := To_Unbounded_String (Normalize_Pathname (Pathname)); else Prefix := To_Unbounded_String (Common_Prefix (To_String (Prefix), Pathname)); end if; end if; -- Unconditionally add a file to the remove list if digest is -- ok, if we are running in force mode or the file has already -- been removed. if Removed or else Force_Installations or else File_Digest = Expected_Digest then Files.Include (Pathname); else Changed.Include (Pathname); end if; end; end if; end loop; Close (Man); if Prefix /= Null_Unbounded_String then Global_Prefix_Dir := (new String'(Ensure_Directory (To_String (Prefix))), False); end if; -- Delete files if Changed.Is_Subset (Of_Set => Files) then Files.Iterate (Delete_File'Access); -- Then finally delete the manifest for this project Do_Delete (Name); else if not Opt.Quiet_Output then Put_Line ("Following files have been changed:"); declare procedure Display (Position : File_Set.Cursor); -- Display only if not part of Files set ------------- -- Display -- ------------- procedure Display (Position : File_Set.Cursor) is F_Name : constant String := File_Set.Element (Position); begin if not Files.Contains (F_Name) then Put_Line (F_Name); end if; end Display; begin Changed.Iterate (Display'Access); end; Fail_Program (Project_Tree, "use option -f to force file deletion."); end if; end if; end Process; end Gprinstall.Uninstall; gprbuild-25.0.0/src/gprinstall-uninstall.ads000066400000000000000000000027031470075373400210700ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2012-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ package Gprinstall.Uninstall is procedure Process (Install_Name : String); -- Uninstall Project end Gprinstall.Uninstall; gprbuild-25.0.0/src/gprinstall.adb000066400000000000000000000070711470075373400170430ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2012-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ with Ada.Directories; use Ada.Directories; with Ada.Text_IO; package body Gprinstall is use Ada; ---------------------------- -- Delete_Empty_Directory -- ---------------------------- procedure Delete_Empty_Directory (Prefix, Dir_Name : String) is Prefix_Dir_Len : constant Natural := Prefix'Length - 1; Search : Search_Type; Element : Directory_Entry_Type; To_Delete : Boolean := True; begin -- Do not try to remove a directory past the project dir if Dir_Name'Length >= Prefix_Dir_Len then -- Check whether the directory is empty or not if Exists (Dir_Name) then Start_Search (Search, Dir_Name, Pattern => ""); Check_Entry : while More_Entries (Search) loop Get_Next_Entry (Search, Element); if Simple_Name (Element) /= "." and then Simple_Name (Element) /= ".." then To_Delete := False; exit Check_Entry; end if; end loop Check_Entry; End_Search (Search); else To_Delete := False; end if; -- If empty delete it if To_Delete then begin Delete_Directory (Dir_Name); exception -- This can happen if there is still some sym links into -- the directory. when Text_IO.Use_Error => null; end; end if; -- And then try recursively with parent directory Delete_Empty_Directory (Prefix, Containing_Directory (Dir_Name)); end if; end Delete_Empty_Directory; --------- -- Dup -- --------- function Dup (P : Param) return Param is begin return (new String'(P.V.all), P.Default); end Dup; ---------- -- Free -- ---------- procedure Free (P : in out Param) is begin Free (P.V); end Free; ------------------------ -- Sigint_Intercepted -- ------------------------ procedure Sigint_Intercepted is begin Text_IO.Put_Line ("*** Interrupted ***"); Delete_All_Temp_Files (Project_Tree.Shared); OS_Exit (2); end Sigint_Intercepted; end Gprinstall; gprbuild-25.0.0/src/gprinstall.ads000066400000000000000000000145761470075373400170740ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2012-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ private with GNAT.OS_Lib; private with GPR; package Gprinstall is private use GPR; use GNAT.OS_Lib; DS : constant Character := GNAT.OS_Lib.Directory_Separator; Display_Paths : Boolean := False; -- Set by switch --display-paths: config project path and user project path -- will be displayed after all command lines witches have been scanned. Project_File_Name_Expected : Boolean := False; -- True when last switch was -P Main_Project_Dir : String_Access; -- The absolute path of the project directory of the main project, -- initialized in procedure Initialize. Force_Installations : Boolean := False; -- True if gprinstall is allowed to overwrite existing files -- A Param, track if it is set on the command line or if it is the default -- value. type Param is record V : String_Access; Default : Boolean := False; end record; function Dup (P : Param) return Param; -- Return a copy of P procedure Free (P : in out Param); -- Free P Global_Prefix_Dir : Param := (null, True); -- Root installation directory Global_Exec_Subdir : Param := (new String'("bin" & DS), True); -- Subdirectory for executable Global_Lib_Subdir : Param := (new String'("lib" & DS), True); -- Subdirectory for libraries Global_ALI_Subdir : Param := (new String'("lib" & DS), True); -- Subdirectory for libraries' .ali file Global_Link_Lib_Subdir : Param := (new String'("lib" & DS), True); -- Subdirectory for libraries sym links (on UNIX) Global_Sources_Subdir : Param := (new String'("include" & DS), True); -- Subdirectory for sources Global_Project_Subdir : Param := (new String'("share" & DS & "gpr" & DS), True); -- Subdirectory used for the installed generated project file Global_Install_Mode : Param := (new String'("dev"), True); -- Either dev or usage. -- "dev" if the installation is for developers (source of the libraries -- are also installed). If set to "usage" only the shared libraries are -- installed and/or the main executables. Global_Install_Name : Param := (new String'("default"), True); -- The installation name, the default value is the project name without -- extension. Global_Install_Project : Boolean := True; -- If set to False no project is generated/installed Build_Vars : String_Access; -- Name of the build variables for the installed project file No_Build_Var : Boolean := False; -- Whether a build variable is to be generated Build_Name : String_Access := new String'("default"); -- Name of the current build Search_Project_Dir_Expected : Boolean := False; -- True when last switch was -aP Project_Tree : constant Project_Tree_Ref := new Project_Tree_Data (Is_Root_Tree => True); -- The project tree Copyright_Output : Boolean := False; Usage_Output : Boolean := False; -- Flags to avoid multiple displays of Copyright notice and of Usage Usage_Needed : Boolean := False; -- Set by switch -h: usage will be displayed after all command line -- switches have been scanned. Recursive : Boolean := False; -- Installation will recurse into all imported projects Dry_Run : Boolean := False; -- Whether the actual installation takes place or not. If Dry_Run is set to -- True then the action will be displayed on the console but actually not -- performed. type Usage_Kind is (Install_Mode, Uninstall_Mode, List_Mode); Usage_Mode : Usage_Kind := Install_Mode; -- Set to true if project is to be uninstalled Output_Stats : Boolean := False; -- Whether the stats are to be displayed when listing installed packages All_Sources : Boolean := True; -- By default install all the sources. If set to False install only -- the sources needed to use the project (the interface for a SAL). Add_Lib_Link : Boolean := True; -- Whether to copy the shared library into the executable directory on -- Windows or create a link into the lib directory on UNIX. Create_Dest_Dir : Boolean := False; -- Whether to create the missing directories in the destination point Sig_Line : constant String := "S "; -- The prefix of the line containing the original project's signature Sources_Only : Boolean := False; -- Whether to copy only the projects sources. This means that the object, -- library, executable files are not to be copied. Side_Debug : Boolean := False; -- Whether the debug symbols are kept into the main executable (default) or -- written into a side debug file. Install_Manifest : Boolean := True; -- Whether to install the manifest file or not procedure Delete_Empty_Directory (Prefix, Dir_Name : String); -- Delete Dir_Name if empty, if removed try with parent directory but not -- above the given prefix. procedure Sigint_Intercepted; pragma Convention (C, Sigint_Intercepted); -- Called when the program is interrupted by Ctrl-C to delete the -- temporary mapping files and configuration pragmas files. end Gprinstall; gprbuild-25.0.0/src/gprinstall.exe.manifest000066400000000000000000000011651470075373400207010ustar00rootroot00000000000000 Description of your application gprbuild-25.0.0/src/gprlib-build_shared_lib.adb000066400000000000000000000400461470075373400214130ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2006-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ -- This is the version of the body of procedure Build_Shared_Lib for most -- where shared libraries are supported. with GPR.Util.Aux; separate (Gprlib) procedure Build_Shared_Lib is Lib_File : constant String := Shared_Lib_Prefix.all & Library_Name.all & Shared_Lib_Suffix.all; Lib_Path : constant String := Library_Directory.all & Lib_File; Maj_Version : String_Access := new String'(""); Result : Integer; pragma Unreferenced (Result); procedure Build (Output_File : String); -- Find the library builder executable and invoke it with the correct -- options to build the shared library. ----------- -- Build -- ----------- procedure Build (Output_File : String) is Success : Boolean; Windows_Target : constant Boolean := Shared_Lib_Suffix.all = ".dll"; Out_Opt : constant String_Access := new String'("-o"); Out_V : constant String_Access := new String'(Output_File); Driver : String_Access; Response_File_Name : Path_Name_Type := No_Path; Response_2 : Path_Name_Type := No_Path; Export_File : Path_Name_Type := No_Path; procedure Display_Linking_Command; -- Display the linking command, depending on verbosity and quiet output ----------------------------- -- Display_Linking_Command -- ----------------------------- procedure Display_Linking_Command is begin if not Opt.Quiet_Output then if Opt.Verbose_Mode then Set_Name_Buffer (Driver.all); for Arg of Arguments loop Add_Str_To_Name_Buffer (" "); Add_Str_To_Name_Buffer (Arg); end loop; Put_Line (Name_Buffer (1 .. Name_Len)); else Display (Section => Build_Libraries, Command => "link library", Argument => Lib_File); end if; end if; end Display_Linking_Command; begin -- Get the executable to use, either the specified Driver, or "gcc" if Driver_Name = No_Name then Driver := Locate_Exec_On_Path (Gcc_Name); if Driver = null then Fail_Program (null, Gcc_Name & " not found in path"); end if; else Driver := Locate_Exec_On_Path (Get_Name_String (Driver_Name)); if Driver = null then Fail_Program (null, Get_Name_String (Driver_Name) & " not found in path"); end if; end if; Arguments := String_Vectors.Empty_Vector; -- Argument_Length := Driver'Length; -- The leading library options, if any Arguments.Append_Vector (Leading_Library_Options_Table); -- The minimum arguments Arguments.Append_Vector (Shared_Lib_Minimum_Options); -- -o Arguments.Append (Out_Opt.all); Arguments.Append (Out_V.all); -- The options for Option of Options_Table loop if Option /= "" then Arguments.Append (Option); end if; end loop; -- Other options for Option of Library_Version_Options loop if Option /= "" then Arguments.Append (Option); end if; end loop; -- The object files if Partial_Linker /= null then Partial_Linker_Path := Locate_Exec_On_Path (Partial_Linker.all); if Partial_Linker_Path = null then Fail_Program (null, "unable to locate linker " & Partial_Linker.all); end if; end if; if Resp_File_Format = GPR.None and then Partial_Linker_Path /= null then -- If partial linker is used, do a partial link first Partial_Number := 0; First_Object := Object_Files.First_Index; loop declare Partial : constant String := Partial_Name (Library_Name.all, Partial_Number, Object_Suffix); Size : Natural := 0; Saved_PL_Options : String_Vectors.Vector; begin Saved_PL_Options := PL_Options; PL_Options.Append (Partial); Size := Size + 1 + Partial'Length; if Partial_Number > 0 then PL_Options.Append (Partial_Name (Library_Name.all, Partial_Number - 1, Object_Suffix)); end if; for Option of PL_Options loop Size := Size + 1 + Option'Length; end loop; loop PL_Options.Append (Object_Files (First_Object)); Size := Size + 1 + PL_Options.Last_Element'Length; First_Object := First_Object + 1; exit when First_Object > Object_Files.Last_Index or else Size >= Maximum_Size; end loop; if not Quiet_Output then if Verbose_Mode then Set_Name_Buffer (Partial_Linker_Path.all); for Option of PL_Options loop Add_Str_To_Name_Buffer (" "); Add_Str_To_Name_Buffer (Option); end loop; Put_Line (Name_Buffer (1 .. Name_Len)); end if; end if; Spawn_And_Script_Write (Partial_Linker_Path.all, PL_Options, Success); Set_Name_Buffer (Get_Current_Dir & Partial); Record_Temp_File (Shared => null, Path => Name_Find); if not Success then Fail_Program (null, "call to linker driver " & Partial_Linker.all & " failed"); end if; if First_Object > Object_Files.Last_Index then Arguments.Append (Partial); exit; end if; PL_Options := Saved_PL_Options; Partial_Number := Partial_Number + 1; end; end loop; else First_Object := Arguments.Last_Index + 1; for Obj of Object_Files loop Arguments.Append (Obj); end loop; end if; Last_Object := Arguments.Last_Index; -- In Ofiles we can have at the end some libraries -lname, so ensure -- that the object are only taken up to Last_Object_File_Index. if Last_Object_File_Index > First_Object and then Last_Object_File_Index < Last_Object then Last_Object := Last_Object_File_Index; end if; -- Finally the additional switches, the library switches and the library -- options. Arguments.Append_Vector (Additional_Switches); Arguments.Append_Vector (Library_Switches_Table); Arguments.Append_Vector (Ada_Runtime_Switches); Arguments.Append_Vector (Library_Options_Table); -- Check if a response file is needed if Max_Command_Line_Length > 0 and then Resp_File_Format /= GPR.None then declare Arg_Length : Natural := Driver'Length; Options : String_Vectors.Vector; Objects : String_Vectors.Vector; begin Arg_Length := Arg_Length + Natural (Arguments.Length); for Arg of Arguments loop Arg_Length := Arg_Length + Arg'Length; end loop; if Arg_Length > Max_Command_Line_Length then Options := Slice (Arguments, Last_Object + 1, Arguments.Last_Index); Objects := Slice (Arguments, First_Object, Last_Object); Aux.Create_Response_File (Format => Resp_File_Format, Objects => Objects, Other_Arguments => Options, Resp_File_Options => Response_File_Switches, Name_1 => Response_File_Name, Name_2 => Response_2); Record_Temp_File (Shared => null, Path => Response_File_Name); if Response_2 /= No_Path then Record_Temp_File (Shared => null, Path => Response_2); end if; -- Remove objects and tail options from Arguments while Arguments.Last_Index > First_Object - 1 loop Arguments.Delete_Last; end loop; if Resp_File_Format = GCC or else Resp_File_Format = GCC_GNU or else Resp_File_Format = GCC_Object_List or else Resp_File_Format = GCC_Option_List then Arguments.Append ("@" & Get_Name_String (Response_File_Name)); else if Response_File_Switches.Is_Empty then Arguments.Append (Get_Name_String (Response_File_Name)); else Response_File_Switches.Replace_Element (Response_File_Switches.Last_Index, Response_File_Switches.Last_Element & Get_Name_String (Response_File_Name)); Arguments.Append_Vector (Response_File_Switches); end if; -- Put back the options Arguments.Append_Vector (Options); end if; end if; end; end if; -- For a standalone shared library, create an export symbols file if -- supported. We need a support for an export file and either: -- -- A library symbol file to be defined -- or -- An object lister and the corresponding matcher if Standalone /= No and then Export_File_Switch /= null then if Library_Symbol_File /= null then -- The exported symbols are to be taken from the symbol file Aux.Create_Export_Symbols_File (Driver_Path => "", Options => To_Argument_List (OL_Options), Sym_Matcher => "", Format => Export_File_Format, Objects => String_List'(1 .. 0 => null), Library_Symbol_File => Library_Symbol_File.all, Export_File_Name => Export_File); elsif Object_Lister /= null and then Object_Lister_Matcher /= null then -- The exported symbols are to be read from the object artifacts -- of the library interface. declare List : String_Vectors.Vector; begin -- Ada unit interfaces List := Interface_Objs; -- We need to add the binder generated object file which -- contains the library initilization code to be explicitely -- called by the main application. List.Append_Vector (Generated_Objects); Aux.Create_Export_Symbols_File (Driver_Path => Object_Lister.all, Options => To_Argument_List (OL_Options), Sym_Matcher => Object_Lister_Matcher.all, Format => Export_File_Format, Objects => To_Argument_List (List), Library_Symbol_File => "", Export_File_Name => Export_File); end; end if; -- If the export file has been created properly pass it to the linker if Export_File /= No_Path then Arguments.Append (Export_File_Switch.all & Get_Name_String (Export_File)); end if; end if; -- On Windows, if we are building a standard library or a library with -- unrestricted symbol-policy make sure all symbols are exported. if Windows_Target and then (Standalone = No or else Export_File_Switch = null) then -- This is needed if an object contains a declspec(dllexport) as in -- this case only the specified symbols will be exported. That is the -- linker change from export-all to export only the symbols specified -- as dllexport. Arguments.Append ("-Wl,--export-all-symbols"); end if; Display_Linking_Command; -- Finally spawn the library builder driver Spawn_And_Script_Write (Driver.all, Arguments, Success); if not Success then if Driver_Name = No_Name then Fail_Program (null, Gcc_Name & " execution error"); else Fail_Program (null, Get_Name_String (Driver_Name) & " execution error"); end if; end if; end Build; -- Start of processing for Build_Shared_Lib begin if Verbosity_Level > Opt.Low then Put ("building relocatable shared library "); Put_Line (Lib_File); end if; if Library_Version.all = "" or else not Symbolic_Link_Supported then -- If no Library_Version specified, make sure the table is empty and -- call Build. Library_Version_Options.Clear; Build (Lib_Path); else -- Put the necessary options corresponding to the Library_Version in the -- table. if Major_Minor_Id_Supported then Maj_Version := new String'(Major_Id_Name (Lib_File, Library_Version.all)); end if; if not Library_Version_Options.Is_Empty then if Maj_Version.all /= "" then Library_Version_Options.Replace_Element (Library_Version_Options.Last_Index, Library_Version_Options.Last_Element & Maj_Version.all); else Library_Version_Options.Replace_Element (Library_Version_Options.Last_Index, Library_Version_Options.Last_Element & Library_Version.all); end if; end if; if Is_Absolute_Path (Library_Version.all) then Library_Version_Path := Library_Version; else Library_Version_Path := new String' (Library_Directory.all & Library_Version.all); end if; -- Now that the table has been filled, call Build Build (Library_Version_Path.all); -- Create symbolic link, if appropriate if Library_Version.all /= Lib_Path then Create_Sym_Links (Lib_Path, Library_Version.all, Library_Directory.all, Maj_Version.all); end if; end if; end Build_Shared_Lib; gprbuild-25.0.0/src/gprlib.adb000066400000000000000000002525111470075373400161440ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2006-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ -- gprlib is called by gprmake to build the library for a library project -- file. gprlib gets it parameters from a text file and give back results -- through the same text file. with Ada.Command_Line; use Ada.Command_Line; with Ada.Exceptions; with Ada.Text_IO; use Ada.Text_IO; with GNAT.Case_Util; use GNAT.Case_Util; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.Expect; with GNAT.OS_Lib; use GNAT.OS_Lib; with Gprexch; use Gprexch; with GPR.ALI; use GPR; with GPR.Names; use GPR.Names; with GPR.Opt; use GPR.Opt; with GPR.Osint; use GPR.Osint; with GPR.Script; use GPR.Script; with GPR.Snames; with GPR.Tempdir; with GPR.Util; use GPR.Util; procedure Gprlib is Size : Natural; Partial_Number : Natural; First_Object : Natural; Last_Object : Natural; Gcc_Name : constant String := "gcc"; Object_Suffix : constant String := Get_Target_Object_Suffix.all; -- The suffix of object files on this platform -- Switches used when spawning processes No_Main : constant String := "-n"; Output_Switch : constant String := "-o"; No_Warning : constant String := "-gnatws"; Auto_Initialize : constant String := "-a"; IO_File : File_Type; -- The file to get the inputs and to put the results Line : String (1 .. 100_000); Last : Natural; Exchange_File_Name : String_Access; -- Name of the exchange file GNAT_Version : String_Access := new String'("000"); -- The version of GNAT, coming from the Toolchain_Version for Ada GNAT_Version_Set : Boolean := False; -- True when the toolchain version is in the input exchange file S_Osinte_Ads : File_Name_Type := No_File; -- Name_Id for "s-osinte.ads" Libgnat : String_Access := new String'(Dash_Lgnat); -- Switch to link with libgnat Libgnarl : String_Access := new String'(Dash_Lgnarl); -- Switch to link with libgnarl Libgnarl_Needed : Boolean := False; -- True if libgnarl is needed No_SAL_Binding : Boolean := False; -- Whether to bind a standalone library or not Mapping_File_Name : String_Access := null; -- The path name of the binder mapping file Runtime_Library_Dirs : String_Vectors.Vector; -- Full path names of the Ada runtime library directories Current_Section : Library_Section := No_Library_Section; -- The current section when reading the exchange file No_Std_Lib_String : constant String := "-nostdlib"; Use_GNAT_Lib : Boolean := True; -- Set to False when "-nostdlib" is in the library options. When False, -- a shared library is not linked with the GNAT libraries. Standalone : GPR.Standalone := No; -- True when building a stand-alone library Library_Path_Name : String_Access; -- Path name of the library file Object_Files : String_Vectors.Vector; -- A table to store the object files of the library Last_Object_File_Index : Natural := 0; -- Index of the last object file in the Object_Files table. When building -- a Stand Alone Library, the binder generated object file will be added -- in the Object_Files table. Additional_Switches : String_Vectors.Vector; -- A table to store switches coming from the binder generated file Ada_Runtime_Switches : String_Vectors.Vector; -- A table to store switches for ada runtime libraries Options_Table : String_Vectors.Vector; -- A table to store the options from the exchange file Imported_Library_Directories : String_Vectors.Vector; -- A table to store the directories of the imported libraries Imported_Library_Names : String_Vectors.Vector; -- A table to store the names of the imported libraries ALIs : String_Vectors.Vector; -- A table to store all of the ALI files Interface_ALIs : String_Vectors.Vector; -- A table to store the ALI files of the interfaces of a SAL Other_Interfaces : String_Vectors.Vector; -- A table to store the interface files other than the ALI files Interface_Objs : String_Vectors.Vector; -- A table to store the object files of the interfaces of a SAL. The -- symbols in these files are the only ones exported from a SAL. Binding_Options_Table : String_Vectors.Vector; -- A table to store the binding options Leading_Library_Options_Table : String_Vectors.Vector; -- A table to store the leading library options from the exchange file Library_Options_Table : String_Vectors.Vector; -- A table to store the library options Library_Rpath_Options_Table : String_Vectors.Vector; -- A table to store the library rpath options Library_Switches_Table : String_Vectors.Vector; -- A table to store the switches for the imported libraries Object_Directories : String_Vectors.Vector; -- A table to store the object directories of the project and of all -- the projects it extends. Sources : String_Vectors.Vector; Generated_Sources : String_Vectors.Vector; Generated_Objects : String_Vectors.Vector; Ada_Leading_Switches : String_Vectors.Vector; Ada_Trailing_Switches : String_Vectors.Vector; Current_Language : Name_Id := No_Name; Language_Equal : constant String := "language="; Auto_Init : Boolean := False; -- True when a SAL is auto initializable Relocatable : Boolean := False; -- True if the library is relocatable No_Create : Boolean := False; -- Should the library (static or dynamic) be built Archive_Builder : String_Access := null; Empty_Archive_Builder : Boolean := False; -- Name of the archive builder AB_Create_Options : String_Vectors.Vector; -- Options of the archive builder AB_Append_Options : String_Vectors.Vector; -- Options for appending to an archive Archive_Indexer : String_Access := null; -- Name of the archive indexer AI_Options : String_Vectors.Vector; -- Options of the archive indexer Object_Lister : String_Access := null; -- Object lister OL_Options : String_Vectors.Vector; -- Object lister options Object_Lister_Matcher : String_Access := null; -- Object lister matcher, the pattern matcher to get the symbols name from -- the output of the object lister. Library_Symbol_File : String_Access; -- The file containing the symbols to export from the shared library Partial_Linker : String_Access := null; -- Name of the library partial linker PL_Options : String_Vectors.Vector; -- Options of the library partial linker Trailing_PL_Options : String_Vectors.Vector; -- Partial linker options from Library_Options Partial_Linker_Path : String_Access; -- The path to the partial linker driver Archive_Suffix : String_Access := new String'(".a"); Bind_Options : String_Vectors.Vector; Library_Name : String_Access := null; Library_Directory : String_Access := null; Project_Directory : String_Access := null; Library_Dependency_Directory : String_Access := null; Library_Version : String_Access := new String'(""); Library_Version_Path : String_Access := new String'(""); Symbolic_Link_Supported : Boolean := False; Major_Minor_Id_Supported : Boolean := False; PIC_Option : String_Access := null; Library_Version_Options : String_Vectors.Vector; Shared_Lib_Prefix : String_Access := new String'("lib"); Shared_Lib_Suffix : String_Access := new String'(".so"); Shared_Lib_Minimum_Options : String_Vectors.Vector; Copy_Source_Directory : String_Access := null; Driver_Name : Name_Id := No_Name; Gnatbind_Name : String_Access := new String'("gnatbind"); Compiler_Name : String_Access := new String'("gcc"); Objcopy_Name : String_Access := new String'("objcopy"); Path_Option : String_Vectors.Vector; Separate_Run_Path_Options : Boolean := False; Rpath_Origin : String_Access := null; Rpath : String_Vectors.Vector; -- Allocated only if Path Option is supported Install_Name : String_Access := null; Arguments : String_Vectors.Vector; -- Response Files Max_Command_Line_Length : Natural := 0; Resp_File_Format : GPR.Response_File_Format := GPR.None; Response_File_Switches : String_Vectors.Vector; Export_File_Format : GPR.Export_File_Format := GPR.None; Export_File_Switch : String_Access; CodePeer_Mode : Boolean := False; Success : Boolean; Linker_Option_Object_File : String_Access := null; -- For SALs: object file receiving the .GPR.linker_options section. -- The file used depends on whether a partial link is done or not. procedure Add_Rpath (Path : String; Absolute : Boolean := False); -- Add a path name to Rpath procedure Copy_ALI_Files; -- Copy the ALI files. For not SALs, copy all the ALI files. For SALs, -- only copy the interface ALI files, marking them with the special -- indicator "SL" on the P line. procedure Copy_Sources; -- Copy to the Copy_Source_Directory the sources of the interfaces of -- a Stand-Alone Library. function Is_Gnarl_Dependent return Boolean; -- Detects from the .ali files if there is a dependency on libgnarl procedure Process_Common; -- Process common part of shared & static libraries procedure Process_Shared; -- Process a shared library procedure Process_Static; -- Process a static library procedure Process_Standalone; -- Specific processing for Sand-Alone Libraries procedure Process_Encapsulated; -- Specific processing for encapsulated Sand-Alone Libraries procedure Read_Exchange_File; -- Read the library exchange file and initialize global variables and -- tables. function SALs_Use_Constructors return Boolean; -- Indicate if Stand-Alone Libraries are automatically initialized using -- the constructor mechanism. procedure Build_Shared_Lib; -- Build a shared library procedure Build_Shared_Lib is separate; procedure Display_Command (Cmd : String; Args : String_Vectors.Vector); -- Print a command and its arguments on stdout. --------------- -- Add_Rpath -- --------------- procedure Add_Rpath (Path : String; Absolute : Boolean := False) is Full : constant String := As_RPath (Path, True); Relative : constant String := Relative_RPath (Path, Library_Directory.all, (if Rpath_Origin = null then "" else Rpath_Origin.all)); begin if Path'Length = 0 then return; end if; -- Check if the directory is already there for J in 1 .. Rpath.Last_Index loop if Rpath (J) = Full then -- Full path in Rpath list: do nothing return; end if; if Rpath (J) = Relative then if Absolute then -- The path is already present as relative path, but we want -- it absolute, let's remove it. Rpath.Delete (J); exit; else -- Dpulicated relative path. Skip return; end if; end if; end loop; -- Insert the new path in the Rpath list. if Absolute then -- In order to accomodate both old native ld versions that -- do not cope well with paths relative to $ORIGIN in shared -- libraries, and cross ld that just ignore the full paths, -- we need to add both an absolute and a relative path here. -- -- We need to ensure that the full path is always first in the -- rpath list, so that the path duplication detection above -- works. Rpath.Append (Full); if Relative /= Full then Rpath.Append (Relative); end if; else Rpath.Append (Relative); end if; end Add_Rpath; -------------------- -- Copy_ALI_Files -- -------------------- procedure Copy_ALI_Files is Success : Boolean := False; FD : File_Descriptor; Len : Integer; Actual_Len : Integer; S : String_Access; Curr : Natural; P_Line_Found : Boolean; Status : Boolean; begin if Standalone = No then for ALI_File of ALIs loop declare Destination : constant String := Library_Dependency_Directory.all & Directory_Separator & Base_Name (ALI_File); Disregard : Boolean; pragma Warnings (Off, Disregard); begin if Is_Regular_File (Destination) then Set_Writable (Destination); Delete_File (Destination, Disregard); end if; end; if Verbosity_Level > Opt.Low then Put ("Copying "); Put (ALI_File); Put_Line (" to library dependency directory"); end if; if Is_Regular_File (ALI_File) then Script_Copy (ALI_File, Library_Dependency_Directory.all); Copy_File (ALI_File, Library_Dependency_Directory.all, Success, Mode => Overwrite, Preserve => Time_Stamps); else Success := False; end if; exit when not Success; end loop; else for ALI_File of Interface_ALIs loop declare File_Name : String := Base_Name (ALI_File); Destination : constant String := Library_Dependency_Directory.all & Directory_Separator & File_Name; Remain : Natural; Disregard : Boolean; pragma Warnings (Off, Disregard); begin if Is_Regular_File (Destination) then Set_Writable (Destination); Delete_File (Destination, Disregard); end if; if Verbosity_Level > Opt.Low then Put ("Copying "); Put (ALI_File); Put_Line (" to library dependency directory"); end if; Osint.Canonical_Case_File_Name (File_Name); -- Open the file Name_Len := ALI_File'Length; Name_Buffer (1 .. Name_Len) := ALI_File; Name_Len := Name_Len + 1; Name_Buffer (Name_Len) := ASCII.NUL; FD := Open_Read (Name_Buffer'Address, Binary); if FD /= Invalid_FD then Len := Integer (File_Length (FD)); S := new String (1 .. Len + 3); -- Read the file. Curr := 1; Remain := Len; while Remain > 0 loop Actual_Len := Read (FD, S (Curr)'Address, Remain); if Actual_Len < 0 then Fail_Program (null, "Error """ & GNAT.OS_Lib.Errno_Message & """ on read ALI file " & ALI_File); end if; Curr := Curr + Actual_Len; Remain := Remain - Actual_Len; end loop; -- We are done with the input file, so we close it -- (we simply ignore any bad status on the close) Close (FD, Status); P_Line_Found := False; -- Look for the P line. When found, add marker SL at the -- beginning of the P line. for Index in 1 .. Len - 3 loop if (S (Index) = ASCII.LF or else S (Index) = ASCII.CR) and then S (Index + 1) = 'P' then S (Index + 5 .. Len + 3) := S (Index + 2 .. Len); S (Index + 2 .. Index + 4) := " SL"; P_Line_Found := True; exit; end if; end loop; if P_Line_Found then -- Create new modified ALI file Set_Name_Buffer (Library_Dependency_Directory.all); Add_Char_To_Name_Buffer (Directory_Separator); Add_Str_To_Name_Buffer (File_Name); Add_Char_To_Name_Buffer (ASCII.NUL); FD := Create_File (Name_Buffer'Address, Binary); -- Write the modified text and close the newly -- created file. if FD /= Invalid_FD then Actual_Len := Write (FD, S (1)'Address, Len + 3); Close (FD, Status); -- Set Success to True only if the newly -- created file has been correctly written. Success := Status and Actual_Len = Len + 3; end if; end if; end if; end; end loop; end if; if not Success then Fail_Program (null, "could not copy ALI files to library directory"); end if; end Copy_ALI_Files; ------------------ -- Copy_Sources -- ------------------ procedure Copy_Sources is Text : Text_Buffer_Ptr; The_ALI : ALI.ALI_Id; Lib_File : File_Name_Type; First_Unit : ALI.Unit_Id; Second_Unit : ALI.Unit_Id; Copy_Subunits : Boolean := False; use ALI; procedure Copy (Fname : String); -- Copy one source of the project to the copy source directory ---------- -- Copy -- ---------- procedure Copy (Fname : String) is Success : Boolean := False; begin for Source of Sources loop if Base_Name (Source) = Fname then if Verbosity_Level > Opt.Low then Put ("Copying "); Put (Source); Put_Line (" to copy source directory"); end if; Copy_File (Source, Copy_Source_Directory.all, Success, Mode => Overwrite, Preserve => Time_Stamps); exit; end if; end loop; end Copy; begin for ALI_File of Interface_ALIs loop -- First, load the ALI file Set_Name_Buffer (ALI_File); Lib_File := Name_Find; Text := Osint.Read_Library_Info (Lib_File); The_ALI := ALI.Scan_ALI (Lib_File, Text, Ignore_ED => False, Err => True, Read_Lines => "UD"); Free (Text); Second_Unit := ALI.No_Unit_Id; First_Unit := ALI.ALIs.Table (The_ALI).First_Unit; Copy_Subunits := True; -- If there is both a spec and a body, check if they are both needed if ALI.Units.Table (First_Unit).Utype = ALI.Is_Body then Second_Unit := ALI.ALIs.Table (The_ALI).Last_Unit; -- If the body is not needed, then reset First_Unit if not ALI.Units.Table (Second_Unit).Body_Needed_For_SAL then First_Unit := ALI.No_Unit_Id; Copy_Subunits := False; end if; elsif ALI.Units.Table (First_Unit).Utype = ALI.Is_Spec_Only then Copy_Subunits := False; end if; -- Copy the file(s) that need to be copied if First_Unit /= No_Unit_Id then Copy (Fname => Get_Name_String (ALI.Units.Table (First_Unit).Sfile)); end if; if Second_Unit /= No_Unit_Id then Copy (Fname => Get_Name_String (ALI.Units.Table (Second_Unit).Sfile)); end if; -- Copy all the separates, if any if Copy_Subunits then for Dep in ALI.ALIs.Table (The_ALI).First_Sdep .. ALI.ALIs.Table (The_ALI).Last_Sdep loop if ALI.Sdep.Table (Dep).Subunit_Name /= No_Name then Copy (Fname => Get_Name_String (Sdep.Table (Dep).Sfile)); end if; end loop; end if; end loop; for Fname of Other_Interfaces loop Copy (Fname => Fname); end loop; end Copy_Sources; --------------------- -- Display_Command -- --------------------- procedure Display_Command (Cmd : String; Args : String_Vectors.Vector) is begin Set_Name_Buffer (Cmd); for Arg of Args loop Add_Str_To_Name_Buffer (" "); Add_Str_To_Name_Buffer (Arg); end loop; Put_Line (Name_Buffer (1 .. Name_Len)); end Display_Command; -------------------- -- Process_Common -- -------------------- procedure Process_Common is begin Libgnarl_Needed := Is_Gnarl_Dependent; for Dir of Imported_Library_Directories loop Library_Switches_Table.Append ("-L" & Dir); if not Path_Option.Is_Empty then Add_Rpath (Dir); end if; end loop; for Libname of Imported_Library_Names loop Library_Switches_Table.Append ("-l" & Libname); end loop; end Process_Common; -------------------------- -- Process_Encapsulated -- -------------------------- procedure Process_Encapsulated is begin -- For encapsulated library we want to link against the static -- GNAT runtime. For sufficiently recent compilers a static -- pic version of the runtime might be present. Fallback on -- the regular static libgnat otherwise. -- For relocatable, first, look for libgnat_pic.a, then look for -- libgnat.a. For static, looks only for libgnat.a. Free (Libgnat); Free (Libgnarl); Main_Loop : for Dyn in reverse False .. Relocatable loop for D of Runtime_Library_Dirs loop declare Dir : constant String := Ensure_Directory (D); Pic_A : constant String := (if Dyn then "_pic" else "") & Archive_Suffix.all; Lib : constant String := Dir & "libgnat" & Pic_A; begin if Is_Regular_File (Lib) then Libgnat := new String'(Lib); Libgnarl := new String'(Dir & "libgnarl" & Pic_A); exit Main_Loop; end if; end; end loop; end loop Main_Loop; -- If libgnat.a was not found, assume it should be in the -- first directory. An error message will be displayed. if Libgnat = null and then not Runtime_Library_Dirs.Is_Empty then declare Dir : constant String := Ensure_Directory (Runtime_Library_Dirs.First_Element); begin Libgnat := new String'(Dir & "libgnat" & Archive_Suffix.all); Libgnarl := new String'(Dir & "libgnarl" & Archive_Suffix.all); end; end if; if not Is_Regular_File (Libgnat.all) then Fail_Program (null, "missing " & Libgnat.all & " for encapsulated library"); end if; if Libgnarl_Needed and then not Is_Regular_File (Libgnarl.all) then Fail_Program (null, "missing " & Libgnarl.all & " for encapsulated library"); end if; -- Adds options into the library options table as those static -- libraries must come late in the linker command line. if Libgnarl_Needed then Library_Options_Table.Append (Libgnarl.all); end if; Library_Options_Table.Append (Libgnat.all); -- Then adds back all libraries already on the command-line after -- libgnat to fulfill dependencies on OS libraries that may be -- used by the GNAT runtime. These are libraries added with a -- pragma Linker_Options in sources that have already been put -- in table Additional_Switches. for Switch of Additional_Switches loop Library_Options_Table.Append (Switch); end loop; end Process_Encapsulated; -------------------- -- Process_Shared -- -------------------- procedure Process_Shared is begin Library_Path_Name := new String' (Library_Directory.all & Shared_Lib_Prefix.all & Library_Name.all & Shared_Lib_Suffix.all); if Relocatable and then PIC_Option /= null and then PIC_Option.all /= "" then Options_Table.Append (PIC_Option.all); end if; GPR.Initialize (GPR.No_Project_Tree); if Use_GNAT_Lib and then not Runtime_Library_Dirs.Is_Empty then if Standalone = Encapsulated then Process_Encapsulated; else for Dir of Runtime_Library_Dirs loop Options_Table.Append ("-L" & Dir); if not Path_Option.Is_Empty then Add_Rpath (Dir, Absolute => True); -- Add to the Path Option the directory of the shared -- version of libgcc. Add_Rpath (Shared_Libgcc_Dir (Dir), Absolute => True); end if; end loop; if Libgnarl_Needed then Ada_Runtime_Switches.Append (Libgnarl.all); end if; Ada_Runtime_Switches.Append (Libgnat.all); end if; end if; if Install_Name /= null then Options_Table.Append (Install_Name.all & Directory_Separator & Shared_Lib_Prefix.all & Library_Name.all & Shared_Lib_Suffix.all); end if; if not Path_Option.Is_Empty then for Path of Library_Rpath_Options_Table loop Add_Rpath (Path); end loop; end if; if not Path_Option.Is_Empty and then not Rpath.Is_Empty then if Separate_Run_Path_Options then for J in 1 .. Rpath.Last_Index loop Options_Table.Append (Concat_Paths (Path_Option, " ") & ' ' & Rpath (J)); end loop; else Options_Table.Append (Concat_Paths (Path_Option, " ") & Concat_Paths (Rpath, ":")); end if; end if; Build_Shared_Lib; end Process_Shared; ------------------------ -- Process_Standalone -- ------------------------ procedure Process_Standalone is Binder_Simple : constant String := "b__" & Canonical_Case_File_Name (Library_Name.all); Binder_Generated_Body : constant String := Binder_Simple & ".adb"; Binder_Generated_Spec : constant String := Binder_Simple & ".ads"; Binder_Generated_ALI : constant String := Binder_Simple & ".ali"; Binder_Generated_Object : constant String := Binder_Simple & Canonical_Case_File_Name (Object_Suffix); First_ALI : File_Name_Type; T : Text_Buffer_Ptr; A : ALI.ALI_Id; Gnatbind_Path : String_Access; Compiler_Path : String_Access; use ALI; begin if not No_SAL_Binding then Linker_Option_Object_File := new String'(Binder_Generated_Object); -- We will add the Linker Opt section to b__.o Gnatbind_Path := Locate_Exec_On_Path (Gnatbind_Name.all); if Gnatbind_Path = null then Fail_Program (null, "unable to locate binder " & Gnatbind_Name.all); end if; Bind_Options := String_Vectors.Empty_Vector; Bind_Options.Append (No_Main); Bind_Options.Append (Output_Switch); Bind_Options.Append (Binder_Generated_Body); -- Make sure that the init procedure is never "adainit" if Library_Name.all = "ada" then Bind_Options.Append ("-Lada_"); else Bind_Options.Append ("-L" & Library_Name.all); end if; if Auto_Init and then SALs_Use_Constructors then -- Check that pragma Linker_Constructor is supported if not GNAT_Version_Set or else (GNAT_Version'Length > 2 and then GNAT_Version (GNAT_Version'First .. GNAT_Version'First + 1) = "3.") then -- GNAT version 3.xx or unknown null; elsif GNAT_Version'Length > 2 and then GNAT_Version (GNAT_Version'First .. GNAT_Version'First + 1) = "5." and then GNAT_Version.all < "5.04" then -- GNAT versions 5.00, 5.01, 5.02 or 5.03 null; else -- Any other supported GNAT version should support pragma -- Linker_Constructor. So, invoke gnatbind with -a. Bind_Options.Append (Auto_Initialize); end if; end if; Bind_Options.Append_Vector (Binding_Options_Table); -- Get an eventual --RTS from the ALI file Set_Name_Buffer (ALIs.First_Element); First_ALI := Name_Find; -- Load the ALI file T := Osint.Read_Library_Info (First_ALI, True); -- Read it A := Scan_ALI (First_ALI, T, Ignore_ED => False, Err => False, Read_Lines => "A"); if A /= No_ALI_Id then for Index in ALI.Units.Table (ALI.ALIs.Table (A).First_Unit).First_Arg .. ALI.Units.Table (ALI.ALIs.Table (A).First_Unit).Last_Arg loop -- Look for --RTS. If found, add the switch to call gnatbind declare Arg : String_Access renames Args.Table (Index); begin if Arg'Length >= 6 and then Arg (Arg'First + 2 .. Arg'First + 5) = "RTS=" then Bind_Options.Append (Arg.all); exit; end if; end; end loop; end if; Bind_Options.Append_Vector (ALIs); if Mapping_File_Name /= null then Bind_Options.Append ("-F=" & Mapping_File_Name.all); end if; if CodePeer_Mode then Bind_Options.Append ("-P"); end if; if not Quiet_Output then Name_Len := 0; if Verbose_Mode then Display_Command (Gnatbind_Path.all, Bind_Options); else Display (Section => Build_Libraries, Command => "bind SAL", Argument => Library_Name.all); end if; end if; -- If there is more than one object directory, set ADA_OBJECTS_PATH -- for the additional object libraries, so that gnatbind may find all -- the ALI files, including those from imported library projects. if Natural (Object_Directories.Length) > 1 then declare Size : Natural := 0; begin for J in 2 .. Object_Directories.Last_Index loop Size := Size + Object_Directories.Element (J)'Length + 1; end loop; declare Value : String (1 .. Size); Last : Natural := 0; begin for J in 2 .. Object_Directories.Last_Index loop if Last > 0 then Last := Last + 1; Value (Last) := Path_Separator; end if; Value (Last + 1 .. Last + Object_Directories.Element (J)'Length) := Object_Directories (J); Last := Last + Object_Directories.Element (J)'Length; end loop; Setenv ("ADA_OBJECTS_PATH", Value (1 .. Last)); end; end; end if; declare Size : Natural := 0; begin for Arg of Bind_Options loop Size := Size + Arg'Length + 1; end loop; -- Invoke gnatbind with the arguments if the size is not too -- large or if the version of GNAT is not recent enough. if Size <= Maximum_Size or else not GNAT_Version_Set or else (GNAT_Version'Length > 2 and then (GNAT_Version (GNAT_Version'First .. GNAT_Version'First + 1) = "3." or else GNAT_Version (GNAT_Version'First .. GNAT_Version'First + 1) = "5.")) then Spawn_And_Script_Write (Gnatbind_Path.all, Bind_Options, Success); else -- Otherwise create a temporary response file declare EOL : aliased constant Character := ASCII.LF; FD : File_Descriptor; Path : Path_Name_Type; Args : String_Vectors.Vector; Status : Integer; Quotes_Needed : Boolean; begin Tempdir.Create_Temp_File (FD, Path); Record_Temp_File (null, Path); Args.Append ("@" & Get_Name_String (Path)); for Arg of Bind_Options loop -- Check if the argument should be quoted Quotes_Needed := False; for Ch of Arg loop if Ch = ' ' or else Ch = ASCII.HT or else Ch = '"' then Quotes_Needed := True; exit; end if; end loop; if Quotes_Needed then -- Quote the argument, doubling '"' declare Quoted : String (1 .. Arg'Length * 2 + 2); Last_Char : Natural := 1; begin for Ch of Arg loop Last_Char := Last_Char + 1; Quoted (Last_Char) := Ch; if Ch = '"' then Last_Char := Last_Char + 1; Quoted (Last_Char) := '"'; end if; end loop; Quoted (1) := '"'; Last_Char := Last_Char + 1; Quoted (Last_Char) := '"'; Status := Write (FD, Quoted (1)'Address, Last_Char); if Status /= Last_Char then Fail_Program (null, "disk full"); end if; end; else Status := Write (FD, Arg (Arg'First)'Address, Arg'Length); if Status /= Arg'Length then Fail_Program (null, "disk full"); end if; end if; Status := Write (FD, EOL'Address, 1); if Status /= 1 then Fail_Program (null, "disk full"); end if; end loop; Close (FD); -- And invoke gnatbind with this response file Spawn_And_Script_Write (Gnatbind_Path.all, Args, Success); end; end if; end; if not Success then Fail_Program (null, "invocation of " & Gnatbind_Name.all & " failed"); end if; Generated_Sources.Append (Binder_Generated_Spec); Generated_Sources.Append (Binder_Generated_Body); Generated_Sources.Append (Binder_Generated_ALI); Compiler_Path := Locate_Exec_On_Path (Compiler_Name.all); if Compiler_Path = null then Fail_Program (null, "unable to locate compiler " & Compiler_Name.all); end if; Bind_Options := String_Vectors.Empty_Vector; Bind_Options.Append_Vector (Ada_Leading_Switches); Bind_Options.Append (No_Warning); Bind_Options.Append (Binder_Generated_Body); Bind_Options.Append (Output_Switch); Bind_Options.Append (Binder_Generated_Object); if Relocatable and then PIC_Option /= null then Bind_Options.Append (PIC_Option.all); end if; -- Get the back-end switches and --RTS from the ALI file -- Load the ALI file T := Osint.Read_Library_Info (First_ALI, True); -- Read it A := Scan_ALI (First_ALI, T, Ignore_ED => False, Err => False, Read_Lines => "A"); if A /= No_ALI_Id then for Index in ALI.Units.Table (ALI.ALIs.Table (A).First_Unit).First_Arg .. ALI.Units.Table (ALI.ALIs.Table (A).First_Unit).Last_Arg loop -- Do not compile with the front end switches except -- for --RTS. declare Arg : String_Access renames Args.Table (Index); Argv : constant String (1 .. Arg'Length) := Arg.all; begin if (Argv'Last <= 2 or else Argv (1 .. 2) /= "-I") and then (Argv'Last <= 5 or else Argv (1 .. 5) /= "-gnat") then Bind_Options.Append (Arg.all); end if; end; end loop; end if; Bind_Options.Append_Vector (Ada_Trailing_Switches); if not Quiet_Output then Name_Len := 0; if Verbose_Mode then Display_Command (Compiler_Path.all, Bind_Options); else Display (Section => Build_Libraries, Command => "Ada", Argument => Binder_Generated_Body); end if; end if; Spawn_And_Script_Write (Compiler_Path.all, Bind_Options, Success); if not Success then Fail_Program (null, "invocation of " & Compiler_Name.all & " failed"); end if; else if Is_Regular_File (Binder_Generated_Body) then Generated_Sources.Append (Binder_Generated_Body); else Fail_Program (null, "cannot find binder generated file " & Binder_Generated_Body); end if; if Is_Regular_File (Binder_Generated_Spec) then Generated_Sources.Append (Binder_Generated_Spec); else Fail_Program (null, "cannot find binder generated spec " & Binder_Generated_Spec); end if; if Is_Regular_File (Binder_Generated_ALI) then Generated_Sources.Append (Binder_Generated_ALI); else Fail_Program (null, "cannot find binder generated ALI file " & Binder_Generated_ALI); end if; if not Is_Regular_File (Binder_Generated_Object) then Fail_Program (null, "cannot find binder generated object file " & Binder_Generated_Object); end if; end if; Generated_Objects.Append (Binder_Generated_Object); Object_Files.Append (Binder_Generated_Object); -- For shared libraries, check if libgnarl is needed if Relocatable then declare BG_File : File_Type; Line : String (1 .. 1_000); Last : Natural; begin Open (BG_File, In_File, Binder_Generated_Body); while not End_Of_File (BG_File) loop Get_Line (BG_File, Line, Last); exit when Line (1 .. Last) = Begin_Info; end loop; while not End_Of_File (BG_File) loop Get_Line (BG_File, Line, Last); exit when Line (1 .. Last) = End_Info; if Use_GNAT_Lib and then not Runtime_Library_Dirs.Is_Empty and then Line (9 .. Last) = Dash_Lgnarl then Libgnarl_Needed := True; end if; if Standalone /= No and then (Partial_Linker = null or else Resp_File_Format /= GPR.None) and then Line (9 .. 10) = "-l" and then Line (9 .. Last) not in Dash_Lgnat | Dash_Lgnarl then Additional_Switches.Append (Line (9 .. Last)); end if; end loop; end; end if; end Process_Standalone; -------------------- -- Process_Static -- -------------------- procedure Process_Static is AB_Options : String_Vectors.Vector; AB_Objects : String_Vectors.Vector; Archive_Files : String_Vectors.Vector; Check_Archives : Boolean; First_AB_Object_Pos : Natural; Last_AB_Object_Pos : Natural; -- Various indexes in AB_Options used when building an archive in chunks begin if Standalone /= No and then Partial_Linker /= null then Partial_Linker_Path := Locate_Exec_On_Path (Partial_Linker.all); if Partial_Linker_Path = null then Fail_Program (null, "unable to locate linker " & Partial_Linker.all); end if; Library_Options_Table.Append (Library_Switches_Table); end if; if Archive_Builder = null then Empty_Archive_Builder := True; end if; Library_Path_Name := new String' (Library_Directory.all & "lib" & Library_Name.all & Archive_Suffix.all); if Standalone = Encapsulated then Process_Encapsulated; end if; Check_Archives := not Empty_Archive_Builder and then Base_Name (Archive_Builder.all, ".exe") = "ar" and then Standalone = Encapsulated and then Partial_Linker_Path = null; -- Add the object files specified in the Library_Options. -- If we perform a partial link, do not check that all library -- options are object files: switches may also be used. for Opt of Library_Options_Table loop if Is_Regular_File (Opt) then if Check_Archives and then Ends_With (Opt, Archive_Suffix.all) then Archive_Files.Append (Opt); else Object_Files.Append (Opt); end if; elsif Partial_Linker_Path = null then Fail_Program (null, "unknown object file """ & Opt & """"); else Trailing_PL_Options.Append (Opt); end if; end loop; if Standalone /= No and then Partial_Linker_Path /= null then -- If partial linker is used, do a partial link and put the resulting -- object file in the archive. Partial_Number := 0; First_Object := Object_Files.First_Index; loop declare Partial : constant String := Partial_Name (Library_Name.all, Partial_Number, Object_Suffix); Size : Natural := 0; Saved_PL_Options : String_Vectors.Vector; begin Saved_PL_Options := PL_Options; PL_Options.Append (Partial); if Partial_Number > 0 then PL_Options.Append (Partial_Name (Library_Name.all, Partial_Number - 1, Object_Suffix)); end if; for Option of PL_Options loop Size := Size + 1 + Option'Length; end loop; for Option of Trailing_PL_Options loop Size := Size + 1 + Option'Length; end loop; loop PL_Options.Append (Object_Files (First_Object)); Size := Size + 1 + PL_Options.Last_Element'Length; First_Object := First_Object + 1; exit when First_Object > Object_Files.Last_Index or else Size >= Maximum_Size; end loop; PL_Options.Append_Vector (Trailing_PL_Options); if Verbose_Mode then Display_Command (Partial_Linker_Path.all, PL_Options); end if; Spawn_And_Script_Write (Partial_Linker_Path.all, PL_Options, Success); Set_Name_Buffer (Get_Current_Dir & Partial); Record_Temp_File (Shared => null, Path => Name_Find); if not Success then Fail_Program (null, "call to linker driver " & Partial_Linker.all & " failed"); end if; if First_Object > Object_Files.Last_Index then AB_Objects.Append (Partial); exit; end if; PL_Options := Saved_PL_Options; Partial_Number := Partial_Number + 1; end; end loop; Linker_Option_Object_File := new String' (Partial_Name (Library_Name.all, Partial_Number, Object_Suffix)); -- We will add the Linker Opt section to p___.o else -- Not a standalone library, or Partial linker is not specified. -- Put all objects in the archive. AB_Objects.Append_Vector (Object_Files); end if; -- Add the .GPR.linker_options section to Linker_Option_Object_File. if Linker_Option_Object_File /= null then -- Retrieve the relevant options in the binder-generated file. -- ??? This is a duplicated code from Process_Standalone! -- A refactoring would be nice. declare BG_File : File_Type; Line : String (1 .. 1_000); Last : Natural; Start_Retrieving : Boolean := False; Options_File : constant String := Library_Name.all & ".linker_options"; Objcopy_Exec : String_Access := Locate_Exec_On_Path (Objcopy_Name.all); Objcopy_Args : String_Vectors.Vector; begin -- Read the linker options from the binder-generated file if we -- did the standalone process. Create (IO_File, Out_File, Options_File); if not ALIs.Is_Empty then Open (BG_File, In_File, "b__" & Library_Name.all & ".adb"); while not End_Of_File (BG_File) loop Get_Line (BG_File, Line, Last); exit when Line (1 .. Last) = Begin_Info; end loop; while not End_Of_File (BG_File) loop Get_Line (BG_File, Line, Last); exit when Line (1 .. Last) = End_Info; if not Start_Retrieving and then Line (9 .. 10) = "-L" then Start_Retrieving := True; end if; if Start_Retrieving then -- Don't store -static and -shared flags, they may cause -- issues when linking with the library. -- Don't store -lgnat and -lgnarl for encapsulated -- because libgnat.a and libgnarl.a already encapsulated. if Line (9 .. Last) not in Dash_Static | Dash_Shared and then not (Standalone = Encapsulated and then Line (9 .. Last) in Dash_Lgnat | Dash_Lgnarl) then Put_Line (IO_File, Line (9 .. Last)); end if; end if; end loop; Close (BG_File); end if; Close (IO_File); -- Call objcopy to add a section to Linker_Option_Object_File, -- containing those linker options. Objcopy_Args.Append ("--add-section"); Objcopy_Args.Append (".GPR.linker_options=" & Options_File); Objcopy_Args.Append (Linker_Option_Object_File.all); if not Quiet_Output then Name_Len := 0; if Verbose_Mode then Display_Command (Objcopy_Name.all, Objcopy_Args); else Display (Section => Build_Libraries, Command => "objcopy", Argument => Linker_Option_Object_File.all); end if; end if; if Objcopy_Exec = null then Objcopy_Exec := Locate_Exec_On_Path ("objcopy"); end if; if Objcopy_Exec = null then if Verbose_Mode then Put ("Warning: unable to locate objcopy " & Objcopy_Name.all & "."); end if; Success := False; else declare Arg_List : String_List_Access := new String_List'(To_Argument_List (Objcopy_Args)); FD : File_Descriptor; Tmp_File : Path_Name_Type; Status : aliased Integer; begin -- Create the temporary file to receive (and -- discard) the output from spawned processes. Tempdir.Create_Temp_File (FD, Tmp_File); if FD = Invalid_FD then Fail_Program (null, "could not create temporary file"); end if; Record_Temp_File (null, Tmp_File); Spawn (Objcopy_Exec.all, Arg_List.all, FD, Status); Success := Status = 0; Free (Arg_List); Close (FD); end; if not Success and then Verbose_Mode then Put_Line ("Warning: invocation of " & Objcopy_Exec.all & " failed."); end if; end if; if not Success and then Verbose_Mode then Put_Line (" Linker options for SAL will not be stored."); end if; -- Same code as for recording the p___N.o files. Set_Name_Buffer (Get_Current_Dir & Options_File); Record_Temp_File (Shared => null, Path => Name_Find); end; end if; -- Delete the archive if it already exists, to avoid having duplicated -- object files in the archive when it is built in chunks. if Is_Regular_File (Library_Path_Name.all) then Delete_File (Library_Path_Name.all, Success); end if; First_AB_Object_Pos := AB_Objects.First_Index; while First_AB_Object_Pos <= AB_Objects.Last_Index loop if AB_Append_Options.Is_Empty then -- If there is no Archive_Builder_Append_Option, always build the -- archive in one chunk. AB_Options := AB_Create_Options; AB_Options.Append_Vector (AB_Objects); First_AB_Object_Pos := AB_Objects.Last_Index + 1; else -- If Archive_Builder_Append_Option is specified, for the creation -- of the archive, only put on the command line a number of -- character lower that Maximum_Size. if First_AB_Object_Pos > AB_Objects.First_Index then AB_Options := AB_Append_Options; else AB_Options := AB_Create_Options; end if; AB_Options.Append (Library_Path_Name.all); Size := 0; for Option of AB_Options loop Size := Size + Option'Length + 1; end loop; Last_AB_Object_Pos := First_AB_Object_Pos; for J in First_AB_Object_Pos .. AB_Objects.Last_Index loop Size := Size + AB_Objects.Element (J)'Length + 1; exit when Size > Maximum_Size; Last_AB_Object_Pos := J; end loop; AB_Options.Append_Vector (Slice (AB_Objects, First_AB_Object_Pos, Last_AB_Object_Pos)); -- Display the invocation of the archive builder for the creation -- of the archive. if not Quiet_Output then Name_Len := 0; if Verbose_Mode then if not Empty_Archive_Builder then Display_Command (Archive_Builder.all, AB_Options); end if; elsif First_AB_Object_Pos = AB_Objects.First_Index then -- Only display this once Display (Section => Build_Libraries, Command => "archive", Argument => "lib" & Library_Name.all & Archive_Suffix.all); end if; end if; First_AB_Object_Pos := Last_AB_Object_Pos + 1; end if; if not Empty_Archive_Builder then Spawn_And_Script_Write (Archive_Builder.all, AB_Options, Success); if not Success then Fail_Program (null, "call to archive builder " & Archive_Builder.all & " failed"); end if; else First_Object := Object_Files.First_Index; loop Script_Copy (Object_Files (First_Object), Library_Directory.all); Copy_File (Object_Files (First_Object), Library_Directory.all, Success, Mode => Overwrite, Preserve => Time_Stamps); if not Success then Fail_Program (null, "copy of " & Object_Files (First_Object) & " to " & Library_Directory.all & " failed"); end if; First_Object := First_Object + 1; exit when First_Object > Object_Files.Last_Index; end loop; end if; end loop; if not Archive_Files.Is_Empty and then not Empty_Archive_Builder then declare Dash_M : aliased String := "-M"; Status : aliased Integer; Rel_Path : constant String := Relative_Path (Library_Path_Name.all, To => Get_Current_Dir, Directory => False); -- We need relative path here because ar -M script does not accept -- Linux legal absolute pathname with '+' character. Relative path -- gives much less probability to get that. Lib_Path : constant String := (if Rel_Path'Length < Library_Path_Name'Length then Rel_Path else Library_Path_Name.all); function Add_Libraries (First : Positive) return String is ("ADDLIB " & Archive_Files (First) & ASCII.LF & (if First = Archive_Files.Last_Index then "" else Add_Libraries (First + 1))); function Input return String; ----------- -- Input -- ----------- function Input return String is Version : Long_Float; End_Of : constant String := "SAVE" & ASCII.LF & "END" & ASCII.LF; Success : Boolean; function Simple return String is ("OPEN " & Lib_Path & ASCII.LF & Add_Libraries (1) & End_Of); begin if not On_Windows then return Simple; end if; if not GNAT_Version_Set or else GNAT_Version = null then Fail_Program (null, "No GNAT version to detect possibility to build" & " encapsulated static SAL without partial linker"); end if; begin Version := Long_Float'Value (GNAT_Version.all); exception when E : others => Fail_Program (null, "Unable to get number of GNAT version """ & GNAT_Version.all & """ to detect possibility to build encapsulated" & " static SAL without partial linker. " & Ada.Exceptions.Exception_Message (E)); end; if Version > 8.0 then -- I do not know exactly, but GNAT 7.3 should be procedded -- another way. return Simple; elsif Ends_With (Lib_Path, ".a") then declare Tmp : constant String := Lib_Path (Lib_Path'First .. Lib_Path'Last - 1) & "tmp"; begin Rename_File (Lib_Path, Tmp, Success); if not Success then Fail_Program (null, "Unable to rename """ & Lib_Path & """ to """ & Tmp & '"'); end if; Record_Temp_File (null, Get_Path_Name_Id (Tmp)); return "CREATE " & Lib_Path & ASCII.LF & "ADDLIB " & Tmp & ASCII.LF & Add_Libraries (1) & End_Of; end; else Fail_Program (null, "Unexpected suffix for library file name """ & Lib_Path & '"'); end if; end Input; Output : constant String := GNAT.Expect.Get_Command_Output (Command => Archive_Builder.all, Arguments => (1 => Dash_M'Unchecked_Access), Input => Input, Status => Status'Unchecked_Access, Err_To_Out => True); begin if Status /= 0 then Fail_Program (null, "ar -M failure: " & Output); elsif Output /= "" and then Verbose_Mode then Put_Line ("ar -M output: " & Output); end if; end; end if; -- If there is an Archive Indexer, invoke it if Archive_Indexer /= null then AI_Options.Append (Library_Path_Name.all); if not Quiet_Output then if Verbose_Mode then Display_Command (Archive_Indexer.all, AI_Options); else Display (Section => Build_Libraries, Command => "index", Argument => File_Name (Library_Path_Name.all)); end if; end if; Spawn_And_Script_Write (Archive_Indexer.all, AI_Options, Success); if not Success then Fail_Program (null, "call to archive indexer " & Archive_Indexer.all & " failed"); end if; end if; end Process_Static; ------------------------ -- Is_Gnarl_Dependent -- ------------------------ function Is_Gnarl_Dependent return Boolean is Gnarl_Dependent : Boolean := Libgnarl_Needed; begin -- If Ada is used and we don't already know that libgnarl is needed, -- look for s-osinte.ads in all the ALI files. If found in at least one, -- then libgnarl is needed. if Use_GNAT_Lib and then not Runtime_Library_Dirs.Is_Empty and then not Libgnarl_Needed then declare Lib_File : File_Name_Type; Text : Text_Buffer_Ptr; Id : ALI.ALI_Id; use ALI; begin if Verbosity_Level > Opt.Low then Put_Line ("Reading ALI files to decide for -lgnarl"); end if; ALI_Loop : for ALI_File of ALIs loop if Verbosity_Level > Opt.Low then Put_Line ("Reading " & ALI_File); end if; Set_Name_Buffer (ALI_File); Lib_File := Name_Find; Text := Osint.Read_Library_Info (Lib_File, True); Id := ALI.Scan_ALI (F => Lib_File, T => Text, Ignore_ED => False, Err => True, Read_Lines => "D"); Free (Text); if Id = No_ALI_Id and then Verbose_Mode then Put_Line ("warning: reading of " & ALI_File & " failed"); else -- Look for s-osinte.ads in the dependencies for Index in ALI.ALIs.Table (Id).First_Sdep .. ALI.ALIs.Table (Id).Last_Sdep loop if ALI.Sdep.Table (Index).Sfile = S_Osinte_Ads then Gnarl_Dependent := True; exit ALI_Loop; end if; end loop; end if; end loop ALI_Loop; if Verbosity_Level > Opt.Low then Put_Line ("End of ALI file reading"); end if; end; end if; return Gnarl_Dependent; end Is_Gnarl_Dependent; ------------------------ -- Read_Exchange_File -- ------------------------ procedure Read_Exchange_File is begin begin Open (IO_File, In_File, Exchange_File_Name.all); exception when others => Fail_Program (null, "could not read " & Exchange_File_Name.all); end; while not End_Of_File (IO_File) loop Get_Line (IO_File, Line, Last); if Last > 0 and then Line (1) = '[' then Current_Section := Get_Library_Section (Line (1 .. Last)); case Current_Section is when No_Library_Section => Fail_Program (null, "unknown section: " & Line (1 .. Last)); when Quiet => Quiet_Output := True; Verbose_Mode := False; Verbosity_Level := Opt.None; when Verbose_Low => Quiet_Output := False; Verbose_Mode := True; Verbosity_Level := Opt.Low; when Verbose_Higher => Quiet_Output := False; Verbose_Mode := True; Verbosity_Level := Opt.High; when Gprexch.Relocatable => Relocatable := True; when Gprexch.Static => Relocatable := False; when Gprexch.Archive_Builder => Archive_Builder := null; when Gprexch.Archive_Builder_Append_Option => AB_Append_Options.Clear; when Gprexch.Archive_Indexer => Archive_Indexer := null; AI_Options.Clear; when Gprexch.Partial_Linker => Partial_Linker := null; PL_Options.Clear; Trailing_PL_Options.Clear; when Gprexch.Auto_Init => Auto_Init := True; when Gprexch.Symbolic_Link_Supported => Symbolic_Link_Supported := True; when Gprexch.Major_Minor_Id_Supported => Major_Minor_Id_Supported := True; when Gprexch.Keep_Temporary_Files => Opt.Keep_Temporary_Files := True; when Gprexch.Separate_Run_Path_Options => Separate_Run_Path_Options := True; when Gprexch.Compiler_Leading_Switches | Gprexch.Compiler_Trailing_Switches => Current_Language := No_Name; when Gprexch.No_Create => No_Create := True; when Gprexch.No_SAL_Binding => No_SAL_Binding := True; when Gprexch.CodePeer_Mode => CodePeer_Mode := True; when others => null; end case; elsif Last > 0 or else Current_Section = Gprexch.Shared_Lib_Prefix or else Current_Section = Gprexch.Response_File_Switches then case Current_Section is when No_Library_Section => Fail_Program (null, "no section specified: " & Line (1 .. Last)); when Gprexch.No_Create => Fail_Program (null, "no create section should be empty"); when Gprexch.CodePeer_Mode => Fail_Program (null, "codepeer section should be empty"); when Quiet => Fail_Program (null, "quiet section should be empty"); when Verbose_Low | Verbose_Higher => Fail_Program (null, "verbose section should be empty"); when Gprexch.Relocatable => Fail_Program (null, "relocatable section should be empty"); when Gprexch.Static => Fail_Program (null, "static section should be empty"); when Gprexch.Keep_Temporary_Files => Fail_Program (null, "keep temporary files section should be empty"); when Gprexch.Separate_Run_Path_Options => Fail_Program (null, "separate run path options should be empty"); when Gprexch.No_SAL_Binding => Fail_Program (null, "no SAL binding section should be empty"); when Gprexch.Object_Files => Object_Files.Append (Line (1 .. Last)); when Gprexch.Options => Options_Table.Append (Line (1 .. Last)); when Gprexch.Object_Directory => -- Make sure that there is no repetitions of the same -- object directory. declare Dir : constant String := Line (1 .. Last); begin if not Object_Directories.Contains (Dir) then Object_Directories.Append (Dir); end if; end; when Gprexch.Library_Name => Library_Name := new String'(Line (1 .. Last)); when Gprexch.Library_Directory => Library_Directory := new String'(Line (1 .. Last)); when Gprexch.Project_Directory => Project_Directory := new String'(Line (1 .. Last)); when Gprexch.Library_Dependency_Directory => Library_Dependency_Directory := new String'(Line (1 .. Last)); when Gprexch.Library_Version => Library_Version := new String'(Line (1 .. Last)); when Gprexch.Leading_Library_Options => if Line (1 .. Last) = No_Std_Lib_String then Use_GNAT_Lib := False; end if; Leading_Library_Options_Table.Append (Line (1 .. Last)); when Gprexch.Library_Options => if Line (1 .. Last) = No_Std_Lib_String then Use_GNAT_Lib := False; end if; Library_Options_Table.Append (Line (1 .. Last)); when Gprexch.Library_Rpath_Options => Library_Rpath_Options_Table.Append (Line (1 .. Last)); when Library_Path => Fail_Program (null, "library path should not be specified"); when Gprexch.Library_Version_Options => Library_Version_Options.Append (Line (1 .. Last)); when Gprexch.Shared_Lib_Prefix => Shared_Lib_Prefix := new String'(Line (1 .. Last)); when Gprexch.Shared_Lib_Suffix => Shared_Lib_Suffix := new String'(Line (1 .. Last)); when Gprexch.Shared_Lib_Minimum_Options => Shared_Lib_Minimum_Options.Append (Line (1 .. Last)); when Gprexch.Symbolic_Link_Supported => Fail_Program (null, "symbolic link supported section should be empty"); when Gprexch.Major_Minor_Id_Supported => Fail_Program (null, "major minor id supported section should be empty"); when Gprexch.PIC_Option => PIC_Option := new String'(Line (1 .. Last)); when Gprexch.Imported_Libraries => if End_Of_File (IO_File) then Fail_Program (null, "no library name for imported library " & Line (1 .. Last)); else Imported_Library_Directories.Append (Line (1 .. Last)); Get_Line (IO_File, Line, Last); Imported_Library_Names.Append (Line (1 .. Last)); end if; when Gprexch.Driver_Name => Name_Len := Last; Name_Buffer (1 .. Name_Len) := Line (1 .. Last); Driver_Name := Name_Find; when Gprexch.Compilers => if End_Of_File (IO_File) then Fail_Program (null, "no compiler specified for language " & Line (1 .. Last)); else To_Lower (Line (1 .. Last)); if Line (1 .. Last) = "ada" then Get_Line (IO_File, Line, Last); if Last = 0 then Fail_Program (null, "Ada compiler name cannot be empty"); else Compiler_Name := new String'(Line (1 .. Last)); if Last > 3 and then Line (Last - 2 .. Last) = "gcc" then Gnatbind_Name := new String'(Line (1 .. Last - 3) & "gnatbind"); Objcopy_Name := new String'(Line (1 .. Last - 3) & "objcopy"); elsif Last > 7 and then Line (Last - 6 .. Last) = "gcc.exe" then Gnatbind_Name := new String'(Line (1 .. Last - 7) & "gnatbind"); Objcopy_Name := new String'(Line (1 .. Last - 7) & "objcopy"); end if; end if; else Skip_Line (IO_File); end if; end if; when Gprexch.Compiler_Leading_Switches => if Last > Language_Equal'Length and then Line (1 .. Language_Equal'Length) = Language_Equal then Set_Name_Buffer (Line (Language_Equal'Length + 1 .. Last)); To_Lower (Name_Buffer (1 .. Name_Len)); Current_Language := Name_Find; elsif Current_Language = Snames.Name_Ada then Ada_Leading_Switches.Append (Line (1 .. Last)); end if; when Gprexch.Compiler_Trailing_Switches => if Last > Language_Equal'Length and then Line (1 .. Language_Equal'Length) = Language_Equal then Set_Name_Buffer (Line (Language_Equal'Length + 1 .. Last)); To_Lower (Name_Buffer (1 .. Name_Len)); Current_Language := Name_Find; elsif Current_Language = Snames.Name_Ada then Ada_Trailing_Switches.Append (Line (1 .. Last)); end if; when Toolchain_Version => if End_Of_File (IO_File) then Fail_Program (null, "no toolchain version for language " & Line (1 .. Last)); elsif Line (1 .. Last) = "ada" then Get_Line (IO_File, Line, Last); if Last > 5 and then Line (1 .. 5) = GNAT_And_Space then GNAT_Version := new String'(Line (6 .. Last)); GNAT_Version_Set := True; Free (Libgnat); Free (Libgnarl); Libgnat := new String'("-lgnat-" & Line (6 .. Last)); Libgnarl := new String'("-lgnarl-" & Line (6 .. Last)); end if; else Skip_Line (IO_File); end if; when Gprexch.Archive_Builder => if Archive_Builder = null then Archive_Builder := new String'(Line (1 .. Last)); else AB_Create_Options.Append (Line (1 .. Last)); end if; when Gprexch.Archive_Builder_Append_Option => AB_Append_Options.Append (Line (1 .. Last)); when Gprexch.Archive_Indexer => if Archive_Indexer = null then Archive_Indexer := new String'(Line (1 .. Last)); else AI_Options.Append (Line (1 .. Last)); end if; when Gprexch.Object_Lister => if Object_Lister = null then Object_Lister := new String'(Line (1 .. Last)); OL_Options.Clear; else OL_Options.Append (Line (1 .. Last)); end if; when Gprexch.Object_Lister_Matcher => Object_Lister_Matcher := new String'(Line (1 .. Last)); when Gprexch.Partial_Linker => if Partial_Linker = null then Partial_Linker := new String'(Line (1 .. Last)); else PL_Options.Append (Line (1 .. Last)); end if; when Gprexch.Archive_Suffix => Archive_Suffix := new String'(Line (1 .. Last)); when Gprexch.Run_Path_Option => Path_Option.Append (Line (1 .. Last)); when Gprexch.Run_Path_Origin => if Rpath_Origin /= null then Fail_Program (null, "multiple run path origin"); end if; Rpath_Origin := new String'(Line (1 .. Last)); when Gprexch.Install_Name => if Install_Name /= null then Fail_Program (null, "multiple install names"); end if; Install_Name := new String'(Line (1 .. Last)); when Gprexch.Auto_Init => Fail_Program (null, "auto init section should be empty"); when Interface_Dep_Files => Interface_ALIs.Append (Line (1 .. Last)); Standalone := GPR.Standard; when Gprexch.Other_Interfaces => Other_Interfaces.Append (Line (1 .. Last)); when Interface_Obj_Files => Interface_Objs.Append (Line (1 .. Last)); when Gprexch.Standalone_Mode => Standalone := GPR.Standalone'Value (Line (1 .. Last)); when Dependency_Files => if Last > 4 and then Line (Last - 3 .. Last) = ".ali" then ALIs.Append (Line (1 .. Last)); end if; when Mapping_File => Mapping_File_Name := new String'(Line (1 .. Last)); when Binding_Options => Binding_Options_Table.Append (Line (1 .. Last)); when Copy_Source_Dir => Copy_Source_Directory := new String'(Line (1 .. Last)); when Gprexch.Sources => Sources.Append (Line (1 .. Last)); when Gprexch.Runtime_Library_Dir => if End_Of_File (IO_File) then Fail_Program (null, "no runtime library dir for language " & Line (1 .. Last)); elsif Line (1 .. Last) = "ada" then Get_Line (IO_File, Line, Last); Runtime_Library_Dirs.Append (Line (1 .. Last)); else Skip_Line (IO_File); end if; when Gprexch.Generated_Object_Files | Gprexch.Generated_Source_Files => null; when Gprexch.Max_Command_Line_Length => begin Max_Command_Line_Length := Natural'Value (Line (1 .. Last)); if Max_Command_Line_Length < Maximum_Size then Maximum_Size := Max_Command_Line_Length; end if; exception when Constraint_Error => Fail_Program (null, "incorrect value for max command line length: " & Line (1 .. Last)); end; when Gprexch.Response_File_Format => begin Resp_File_Format := GPR.Response_File_Format'Value (Line (1 .. Last)); exception when Constraint_Error => Fail_Program (null, "incorrect value for response file format: " & Line (1 .. Last)); end; when Gprexch.Response_File_Switches => Response_File_Switches.Append (Line (1 .. Last)); when Gprexch.Export_File => -- First the format begin Export_File_Format := GPR.Export_File_Format'Value (Line (1 .. Last)); exception when Constraint_Error => Fail_Program (null, "incorrect value for export file format: " & Line (1 .. Last)); end; -- Followed by the corresponding linker switch Get_Line (IO_File, Line, Last); Export_File_Switch := new String'(Line (1 .. Last)); when Gprexch.Library_Symbol_File => Library_Symbol_File := new String'(Line (1 .. Last)); when Script_Path => Build_Script_Name := new String'(Line (1 .. Last)); end case; end if; end loop; Close (IO_File); end Read_Exchange_File; --------------------------- -- SALs_Use_Constructors -- --------------------------- function SALs_Use_Constructors return Boolean is function C_SALs_Init_Using_Constructors return Integer; pragma Import (C, C_SALs_Init_Using_Constructors, "__gnat_sals_init_using_constructors"); begin return C_SALs_Init_Using_Constructors /= 0; end SALs_Use_Constructors; -- Start of processing for Gprlib begin -- Initialize some packages Snames.Initialize; Set_Program_Name ("gprlib"); -- As the section header has already been displayed, indicate that it -- should not been displayed again. Set (Section => Build_Libraries); if Argument_Count /= 1 then Put_Line ("usage: gprlib "); if Argument_Count /= 0 then Fail_Program (null, "incorrect invocation"); end if; return; end if; Exchange_File_Name := new String'(Argument (1)); -- DEBUG: save a copy of the exchange file if Getenv ("GPRLIB_DEBUG").all = "TRUE" then Copy_File (Exchange_File_Name.all, Exchange_File_Name.all & "__saved", Success, Mode => Overwrite, Preserve => Time_Stamps); end if; Read_Exchange_File; -- In codepeer mode, we might end up with no object files for project -- files with no Ada sources (e.g. C only). Do not consider this as -- an error in this case. if Object_Files.Is_Empty and not CodePeer_Mode then Fail_Program (null, "no object files specified"); end if; Last_Object_File_Index := Object_Files.Last_Index; if Library_Name = null then Fail_Program (null, "no library name specified"); end if; if Library_Directory = null then Fail_Program (null, "no library directory specified"); end if; if Project_Directory = null then Fail_Program (null, "no project directory specified"); end if; if Object_Directories.Is_Empty then Fail_Program (null, "no object directory specified"); end if; if Library_Directory.all = Object_Directories.First_Element then Fail_Program (null, "object directory and library directory cannot be the same"); end if; if Library_Dependency_Directory = null then Library_Dependency_Directory := Library_Directory; end if; if Standalone /= No and then not ALIs.Is_Empty then Process_Standalone; end if; -- Archives if not No_Create then if S_Osinte_Ads = No_File then Set_Name_Buffer ("s-osinte.ads"); S_Osinte_Ads := Name_Find; end if; Process_Common; if Relocatable then Process_Shared; else Process_Static; end if; end if; if not ALIs.Is_Empty then Copy_ALI_Files; end if; if Copy_Source_Directory /= null then Copy_Sources; end if; -- Create new exchange files with the path of the library file and the -- paths of the object files with their time stamps. begin Create (IO_File, Out_File, Exchange_File_Name.all); exception when others => Fail_Program (null, "could not create " & Exchange_File_Name.all); end; if Library_Path_Name /= null then Put_Line (IO_File, Library_Label (Library_Path)); Put_Line (IO_File, Library_Path_Name.all); end if; Put_Line (IO_File, Library_Label (Gprexch.Object_Files)); for Index in 1 .. Last_Object_File_Index loop Put_Line (IO_File, Object_Files (Index)); Put_Line (IO_File, String (Osint.File_Stamp (Object_Files (Index)))); end loop; if not Generated_Sources.Is_Empty then Put_Line (IO_File, Library_Label (Gprexch.Generated_Source_Files)); for Source of Generated_Sources loop Put_Line (IO_File, Source); end loop; end if; if not Generated_Objects.Is_Empty then Put_Line (IO_File, Library_Label (Gprexch.Generated_Object_Files)); for Object of Generated_Objects loop Put_Line (IO_File, Object); end loop; end if; if Relocatable and then Library_Version.all /= "" and then Symbolic_Link_Supported then Put_Line (IO_File, Library_Label (Gprexch.Library_Version)); Put_Line (IO_File, Library_Version.all); end if; Close (IO_File); Delete_All_Temp_Files (null); end Gprlib; gprbuild-25.0.0/src/gprls-main.adb000066400000000000000000001266661470075373400167510ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2015-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Command_Line; use Ada.Command_Line; with Ada.Containers.Generic_Sort; with Ada.Exceptions; use Ada.Exceptions; with Ada.Text_IO; use Ada.Text_IO; with GNAT.Command_Line; use GNAT.Command_Line; with GPR.Conf; use GPR.Conf; with GPR.Env; use GPR.Env; with GPR.Names; use GPR.Names; with GPR.Osint; with GPR.Snames; with GPR.Tree; with GPR.Util; use GPR.Util; with Gpr_Build_Util; use Gpr_Build_Util; procedure Gprls.Main is use GPR; File_Set : Boolean := False; -- Set to True by -P switch. -- Used to detect multiple -P switches. Print_Usage : Boolean := False; -- Set to True with switch -h Project_File_Name_Expected : Boolean := False; -- True when switch "-P" has just been scanned Search_Project_Dir_Expected : Boolean := False; -- True when last switch was -aP Path_Name : String_Access; Path_Last : Natural; Output_Name : String_Access; User_Project_Node : Project_Node_Id; No_Project_File_Specified : Boolean := False; All_Projects : Boolean := False; procedure Initialize; procedure Scan_Arg (Argv : String); -- Scan and process user specific arguments (Argv is a single argument) procedure Usage; -- Print usage message procedure Display_Closures; -- Display output when switch --closure is used procedure Display_Output; -- Display output when switch --closure is not used procedure Display_Paths; -- Display source, object and project paths procedure Get_Source_Dirs (Project : Project_Id; Tree : Project_Tree_Ref; With_State : in out Paths); procedure Get_All_Source_Dirs is new For_Every_Project_Imported (Paths, Get_Source_Dirs); procedure Get_Object_Dirs (Project : Project_Id; Tree : Project_Tree_Ref; With_State : in out Paths); procedure Get_All_Object_Dirs is new For_Every_Project_Imported (Paths, Get_Object_Dirs); procedure Get_Runtime_Object_Dirs (Project : Project_Id; Tree : Project_Tree_Ref; With_State : in out Paths); procedure Get_All_Runtime_Object_Dirs is new For_Every_Project_Imported (Paths, Get_Runtime_Object_Dirs); procedure Look_For_Sources; -- Get the source ids subtype One_Range is Integer range -1 .. 1; function Compare (Left, Right : String) return One_Range is (if Left > Right then 1 elsif Left = Right then 0 else -1); function Get_Tree_Name (Index : Positive) return String; -- Get main project name of the source taken by Index from File_Names -- container. function Before (Left, Right : Positive) return Boolean is (case Compare (Get_Tree_Name (Left), Get_Tree_Name (Right)) is when 1 => False, when -1 => True, when 0 => (case Compare (File_Names (Left).File_Name, File_Names (Right).File_Name) is when 1 => False, when -1 => True, when 0 => File_Names (Left).Source.Path.Display_Name < File_Names (Right).Source.Path.Display_Name)); -- Returns True if element of the File_Names in Left position have to be -- before the element in Right position. procedure Swap_File_Names (Left, Right : Positive); -- Swap 2 elements in File_Names vector procedure Do_List (Project : Project_Id; Tree : Project_Tree_Ref); -- Iterates over project or over aggregated projects to prepare the source -- list to process. procedure Sort_File_Names is new Ada.Containers.Generic_Sort (Index_Type => Positive, Before => Before, Swap => Swap_File_Names); -- Sort File_Names vector declared in the GPRls specification ---------------------- -- Display_Closures -- ---------------------- procedure Display_Closures is begin if File_Names.Is_Empty then Fail_Program (Project_Tree, "no main specified for closure"); else declare The_Sources : String_Vectors.Vector; Result : String_Vectors.Vector; Status : GPR.Util.Status_Type; begin for FN_Source of File_Names loop if FN_Source.Source /= No_Source then The_Sources.Append (Get_Name_String (FN_Source.Source.File)); end if; end loop; if The_Sources.Is_Empty then Finish_Program (Project_Tree); end if; Get_Closures (Project => Main_Project, In_Tree => Project_Tree, Mains => The_Sources, All_Projects => True, Include_Externally_Built => True, Status => Status, Result => Result); New_Line; if Status = Incomplete_Closure then if The_Sources.Last_Index = 1 then Put_Line ("Incomplete closure:"); else Put_Line ("Incomplete closures:"); end if; elsif Status = GPR.Util.Success then if The_Sources.Last_Index = 1 then Put_Line ("Closure:"); else Put_Line ("Closures:"); end if; else Fail_Program (Project_Tree, "unable to get closures: " & Status'Img); end if; New_Line; if not Result.Is_Empty then for Res of Result loop Put_Line (" " & Res); end loop; New_Line; end if; end; end if; end Display_Closures; -------------------- -- Display_Output -- -------------------- procedure Display_Output is begin if Very_Verbose_Mode then -- First the ALI files that are not found for FN_Source of File_Names loop if FN_Source.Source /= No_Source and then FN_Source.The_ALI = No_ALI_Id then GNATDIST.Output_No_ALI (FN_Source); end if; end loop; -- Then the ALI that have been found for FN_Source of File_Names loop if FN_Source.Source /= No_Source and then FN_Source.The_ALI /= No_ALI_Id then GNATDIST.Output_ALI (FN_Source); end if; end loop; else for FN_Source of File_Names loop declare Id : ALI_Id; Last_U : Unit_Id; begin if FN_Source.Source /= No_Source then Id := FN_Source.The_ALI; if Id = No_ALI_Id then null; else Get_Name_String (Units.Table (ALIs.Table (Id).First_Unit).Uname); if Print_Object then if ALIs.Table (Id).No_Object then Output_Object (No_File); else Output_Object (ALIs.Table (Id).Ofile_Full_Name); end if; end if; -- In verbose mode print all main units in the ALI file, -- otherwise just print the first one to ease columnwise -- printout. if Verbose_Mode then Last_U := ALIs.Table (Id).Last_Unit; else Last_U := ALIs.Table (Id).First_Unit; end if; for U in ALIs.Table (Id).First_Unit .. Last_U loop if Print_Unit then Output_Unit (U); end if; -- Output source now, unless if it will be done as -- part of outputing dependencies. if not (Dependable and then Print_Source) then Output_Source (FN_Source.Source, Corresponding_Sdep_Entry (Id, U)); end if; end loop; -- Print out list of units on which this unit depends (D -- lines). if Dependable and then Print_Source then if Verbose_Mode then Put_Line (" depends upon"); end if; for D in ALIs.Table (Id).First_Sdep .. ALIs.Table (Id).Last_Sdep loop if not Is_Ada_Predefined_File_Name (Sdep.Table (D).Sfile) then Put (" "); Output_Source (FN_Source.Tree, D); end if; end loop; end if; end if; end if; end; end loop; end if; end Display_Output; ------------------- -- Display_Paths -- ------------------- procedure Display_Paths is Source_Paths : Paths := No_Paths; Object_Paths : Paths := No_Paths; Path : Path_Access; procedure Put_Path (Path : String); -- Put path prefixed with 3 spaces to standard output add directory -- separator at the end if absent. -------------- -- Put_Path -- -------------- procedure Put_Path (Path : String) is begin if Path'Length > 1 and then Path (Path'Last - 1 .. Path'Last) = (1 .. 2 => Directory_Separator) then Put_Path (Path (Path'First .. Path'Last - 1)); return; end if; Put (" "); Put (Path); if Path (Path'Last) /= Directory_Separator then Put_Line ("" & Directory_Separator); else New_Line; end if; end Put_Path; begin New_Line; Display_Version ("GPRLS", "2015"); New_Line; Put_Line ("Source Search Path:"); -- First the source directories Get_All_Source_Dirs (Main_Project, Project_Tree, Source_Paths); -- Then the runtime source directories, if any Get_All_Runtime_Source_Dirs (Main_Project, Project_Tree, Source_Paths); Path := Source_Paths.First; while Path /= null loop Put_Path (Path.Path.all); Path := Path.Next; end loop; New_Line; Put_Line ("Object Search Path:"); -- First the object directories Get_All_Object_Dirs (Main_Project, Project_Tree, Object_Paths); -- Then the runtime library directories, if any Get_All_Runtime_Object_Dirs (Main_Project, Project_Tree, Object_Paths); Path := Object_Paths.First; while Path /= null loop Put_Path (Path.Path.all); Path := Path.Next; end loop; New_Line; Put_Line ("Project Search Path:"); declare procedure Output (Path : String); -- Calls Put_Path with Path parameter if Path is not "." ------------ -- Output -- ------------ procedure Output (Path : String) is begin if Path /= "." then Put_Path (Path); end if; end Output; begin Put_Line (" "); Iterate (Root_Environment.Project_Path, Output'Access); end; New_Line; end Display_Paths; --------------------- -- Get_Object_Dirs -- --------------------- procedure Get_Object_Dirs (Project : Project_Id; Tree : Project_Tree_Ref; With_State : in out Paths) is pragma Unreferenced (Tree); Name : Path_Name_Type := No_Path; begin case Project.Qualifier is when Aggregate | Abstract_Project | Configuration => null; when Library | Aggregate_Library => Name := Project.Library_ALI_Dir.Display_Name; if Name = No_Path then Name := Project.Library_Dir.Display_Name; end if; when Unspecified | GPR.Standard => Name := Project.Object_Directory.Display_Name; end case; if Name /= No_Path then Add (Get_Name_String (Name), With_State); end if; end Get_Object_Dirs; ----------------------------- -- Get_Runtime_Object_Dirs -- ----------------------------- procedure Get_Runtime_Object_Dirs (Project : Project_Id; Tree : Project_Tree_Ref; With_State : in out Paths) is List : Language_Ptr := Project.Languages; Dirs : Name_List_Index; Nam_Nod : Name_Node; begin while List /= No_Language_Index loop Dirs := List.Config.Runtime_Library_Dirs; while Dirs /= No_Name_List loop Nam_Nod := Tree.Shared.Name_Lists.Table (Dirs); Add (Get_Name_String (Nam_Nod.Name), With_State); Dirs := Nam_Nod.Next; end loop; List := List.Next; end loop; end Get_Runtime_Object_Dirs; --------------------- -- Get_Source_Dirs -- --------------------- procedure Get_Source_Dirs (Project : Project_Id; Tree : Project_Tree_Ref; With_State : in out Paths) is Source_Dirs : String_List_Id := Project.Source_Dirs; begin while Source_Dirs /= Nil_String loop Add (Get_Name_String (Tree.Shared.String_Elements.Table (Source_Dirs).Display_Value), With_State); Source_Dirs := Tree.Shared.String_Elements.Table (Source_Dirs).Next; end loop; end Get_Source_Dirs; ------------------- -- Get_Tree_Name -- ------------------- function Get_Tree_Name (Index : Positive) return String is Tree : constant Project_Tree_Ref := File_Names (Index).Tree; begin if Tree = null then return ""; else return Get_Name_String (Tree.Projects.Project.Name); end if; end Get_Tree_Name; ---------------------- -- Look_For_Sources -- ---------------------- procedure Look_For_Sources is begin for FN_Source of File_Names loop if FN_Source.Source = No_Source then Put_Line (Standard_Error, "Can't find source for " & FN_Source.File_Name); elsif FN_Source.Source.Dep_Path = No_Path then Put_Line (Standard_Error, "Can't find ALI file for " & Get_Name_String_Safe (FN_Source.Source.Path.Display_Name)); else declare Text : Text_Buffer_Ptr; Source : constant GPR.Source_Id := FN_Source.Source; begin Text := Osint.Read_Library_Info (File_Name_Type (Source.Dep_Path)); -- If the ALI file cannot be found and the project is an -- externally built library project, look for the ALI file -- in the library directory. if Text = null and then Source.Project.Externally_Built and then Source.Project.Library then declare Dep_Path_Name : constant String := Get_Name_String (Source.Project.Library_Dir.Name) & Directory_Separator & Get_Name_String (Source.Dep_Name); Dep_Path : File_Name_Type; begin Set_Name_Buffer (Dep_Path_Name); Dep_Path := Name_Find; Text := Osint.Read_Library_Info (Dep_Path); end; end if; if Text /= null then FN_Source.The_ALI := Scan_ALI (F => File_Name_Type (Source.Dep_Path), T => Text, Ignore_ED => False, Err => True, Read_Lines => "WD", Object_Path => File_Name_Type (Source.Object_Path)); Free (Text); else FN_Source.The_ALI := No_ALI_Id; if Very_Verbose_Mode then -- With switch -V, when the ALI file is not found, this -- will be reported in the output later. null; else Put_Line (Standard_Error, "Can't find ALI file for " & Get_Name_String_Safe (Source.Path.Display_Name)); end if; end if; end; end if; end loop; end Look_For_Sources; -------------- -- Scan_Arg -- -------------- procedure Scan_Arg (Argv : String) is FD : File_Descriptor; Len : Integer; OK : Boolean; begin pragma Assert (Argv'First = 1); if Argv'Length = 0 then return; end if; OK := True; -- -P xxx if Project_File_Name_Expected then if Argv (1) = '-' then Fail ("project file name missing"); else File_Set := True; Project_File_Name := new String'(Argv); Project_File_Name_Expected := False; end if; -- -aP xxx elsif Search_Project_Dir_Expected then if Argv (1) = '-' then Fail ("directory name missing after -aP"); else Search_Project_Dir_Expected := False; Add_Directories (Root_Environment.Project_Path, Argv, Prepend => True); end if; elsif Argv (1) = '-' then if Argv'Length = 1 then Fail ("switch character '-' cannot be followed by a blank"); -- Forbid -?- or -??- where ? is any character elsif (Argv'Length = 3 and then Argv (3) = '-') or else (Argv'Length = 4 and then Argv (4) = '-') then Fail ("Trailing ""-"" at the end of " & Argv & " forbidden."); -- Processing for -aP elsif Argv'Length >= 3 and then Argv (1 .. 3) = "-aP" then if Argv'Length = 3 then Search_Project_Dir_Expected := True; else Add_Directories (Root_Environment.Project_Path, Argv (4 .. Argv'Last), Prepend => True); end if; -- Processing for --unchecked-shared-lib-imports elsif Argv = "--unchecked-shared-lib-imports" then Opt.Unchecked_Shared_Lib_Imports := True; elsif Argv = "--closure" then Closure := True; -- Processing for one character switches elsif Argv'Length = 2 then case Argv (2) is when 'a' => null; -- ??? To be implemented when 'h' => Print_Usage := True; when 'u' => Reset_Print; Print_Unit := True; when 'U' => All_Projects := True; when 's' => Reset_Print; Print_Source := True; when 'o' => Reset_Print; Print_Object := True; when 'v' => Verbose_Mode := True; Verbosity_Level := High; when 'd' => Dependable := True; when 'V' => Very_Verbose_Mode := True; when 'P' => if File_Set then Fail ("only one -P switch may be specified"); end if; Project_File_Name_Expected := True; when others => OK := False; end case; elsif Argv'Length = 4 and then Argv (2 .. 3) = "vP" then case Argv (4) is when '0' => Current_Verbosity := Default; when '1' => Current_Verbosity := Medium; when '2' => Current_Verbosity := High; when others => OK := False; end case; -- -Pxxx elsif Argv'Length > 2 and then Argv (2) = 'P' then if File_Set then Fail ("only one -P switch may be specified"); end if; File_Set := True; Project_File_Name := new String'(Argv (3 .. Argv'Last)); -- Processing for -files=file elsif Argv'Length > 7 and then Argv (1 .. 7) = "-files=" then FD := Open_Read (Argv (8 .. Argv'Last), GNAT.OS_Lib.Text); if FD = Invalid_FD then Osint.Fail ("could not find text file """ & Argv (8 .. Argv'Last) & '"'); end if; Len := Integer (File_Length (FD)); declare Buffer : String (1 .. Len + 1); Index : Positive := 1; Last : Positive; begin -- Read the file Len := Read (FD, Buffer (1)'Address, Len); Buffer (Buffer'Last) := ASCII.NUL; Close (FD); -- Scan the file line by line while Index < Buffer'Last loop -- Find the end of line Last := Index; while Last <= Buffer'Last and then Buffer (Last) /= ASCII.LF and then Buffer (Last) /= ASCII.CR loop Last := Last + 1; end loop; -- Ignore empty lines if Last > Index then Add_File (Buffer (Index .. Last - 1), No_Project_Tree); end if; -- Find the beginning of the next line Index := Last; while Buffer (Index) = ASCII.CR or else Buffer (Index) = ASCII.LF loop Index := Index + 1; end loop; end loop; end; elsif Argv'Length > Target_Project_Option'Length and then Argv (1 .. Target_Project_Option'Length) = Target_Project_Option then if Target_Name /= null then if Target_Name.all /= Argv (Target_Project_Option'Length + 1 .. Argv'Last) then Fail_Program (Project_Tree, "several target switches " & "cannot be specified"); end if; else Target_Name := new String' (Argv (Target_Project_Option'Length + 1 .. Argv'Last)); end if; -- Processing for --RTS=path elsif Argv'Length >= 5 and then Argv (1 .. 5) = "--RTS" then if Argv'Length <= 6 or else Argv (6) /= '='then Osint.Fail ("missing path for --RTS"); else -- Check that it is the first time we see this switch or, if -- it is not the first time, the same path is specified. if RTS_Specified = null then RTS_Specified := new String'(Argv (7 .. Argv'Last)); Set_Runtime_For (Snames.Name_Ada, Argv (7 .. Argv'Last)); elsif RTS_Specified.all /= Argv (7 .. Argv'Last) then Osint.Fail ("--RTS cannot be specified multiple times"); end if; end if; elsif Argv'Length >= 3 and then Argv (2) = 'X' and then Is_External_Assignment (Root_Environment, Argv) then -- Is_External_Assignment has side effects when it returns True null; else OK := False; end if; -- If not a switch, it must be a file name else Add_File (Argv, No_Project_Tree); end if; if not OK then Put ("warning: unknown switch """); Put (Argv); Put_Line (""""); end if; end Scan_Arg; --------------------- -- Swap_File_Names -- --------------------- procedure Swap_File_Names (Left, Right : Positive) is begin File_Names.Swap (Left, Right); end Swap_File_Names; ----------- -- Usage -- ----------- procedure Usage is begin -- Usage line Put_Line ("Usage: gprls switches [list of object files]"); New_Line; -- GPRLS switches Put_Line ("switches:"); Display_Usage_Version_And_Help; -- Line for -Pproj Put_Line (" -Pproj Use project file proj"); -- Line for -a Put_Line (" -a Also output relevant predefined units"); -- Line for -u Put_Line (" -u Output only relevant unit names"); -- Line for -U Put_Line (" -U List sources for all projects"); -- Line for -h Put_Line (" -h Output this help message"); -- Line for -s Put_Line (" -s Output only relevant source names"); -- Line for -o Put_Line (" -o Output only relevant object names"); -- Line for -d Put_Line (" -d Output sources on which specified units " & "depend"); -- Line for -v Put_Line (" -v Verbose output, full path and unit " & "information"); -- Line for -vPx Put_Line (" -vPx Specify verbosity when parsing project " & "files (x = 0/1/2)"); -- Line for --closure Put_Line (" --closure List paths of sources in closures of mains"); New_Line; -- Line for -files= Put_Line (" -files=fil Files are listed in text file 'fil'"); -- Line for -aP switch Put_Line (" -aP dir Add directory dir to project search path"); -- Line for --target= Put_Line (" --target=xxx Specify target xxx"); -- Line for --RTS Put_Line (" --RTS=dir Specify the Ada runtime"); -- Line for --unchecked-shared-lib-imports Put_Line (" --unchecked-shared-lib-imports"); Put_Line (" Shared library projects may import any project"); -- Line for -X Put_Line (" -Xnm=val Specify an external reference for " & "project files"); -- File Status explanation New_Line; Put_Line (" File status can be:"); for ST in File_Status loop Put (" "); Output_Status (ST, Verbose => False); Put (" ==> "); Output_Status (ST, Verbose => True); New_Line; end loop; end Usage; procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage); ---------------- -- Initialize -- ---------------- procedure Initialize is begin if not Initialized then Initialized := True; -- Initialize some packages Snames.Initialize; Set_Program_Name ("gprls"); GPR.Tree.Initialize (Root_Environment, Gprls_Flags); GPR.Tree.Initialize (Project_Node_Tree); GPR.Initialize (Project_Tree); GPR.Tree.Initialize (Tree); end if; end Initialize; -------------- -- _Do_List -- -------------- procedure Do_List (Project : Project_Id; Tree : Project_Tree_Ref) is Iter : Source_Iterator := For_Each_Source (Tree); Source : GPR.Source_Id; begin loop Source := Element (Iter); exit when Source = No_Source; Initialize_Source_Record (Source); Next (Iter); end loop; if Closure and then No_Files_In_Command_Line then -- Get the mains declared in the main project declare Mains : String_List_Id := Project.Mains; Elem : String_Element; begin while Mains /= Nil_String loop Elem := Tree.Shared.String_Elements.Table (Mains); Add_File (Get_Name_String (Elem.Value), Tree); Mains := Elem.Next; end loop; end; end if; if No_Files_In_Command_Line and not Closure then -- Get all the compilable sources of the project declare Unit : GPR.Unit_Index; Subunit : Boolean := False; begin Unit := Units_Htable.Get_First (Tree.Units_HT); while Unit /= No_Unit_Index loop -- We only need to put the library units, body or spec, but not -- the subunits. if Unit.File_Names (Impl) /= null and then not Unit.File_Names (Impl).Locally_Removed then -- There is a body, check if it is for this project if All_Projects or else Unit.File_Names (Impl).Project = Project then Subunit := False; if Unit.File_Names (Spec) = null or else Unit.File_Names (Spec).Locally_Removed then -- We have a body with no spec: we need to check if -- this is a subunit, because gnatls will complain -- about subunits. Subunit := Is_Subunit (Unit.File_Names (Impl)); end if; if not Subunit then Add_File (Get_Name_String (Unit.File_Names (Impl).Object), Tree, Source => Unit.File_Names (Impl)); end if; end if; elsif Unit.File_Names (Spec) /= null and then not Unit.File_Names (Spec).Locally_Removed and then -- We have a spec with no body. Check if it is for this project (All_Projects or else Unit.File_Names (Spec).Project = Project) then Add_File (Get_Name_String (Unit.File_Names (Spec).Object), Tree, Source => Unit.File_Names (Spec)); end if; Unit := Units_Htable.Get_Next (Tree.Units_HT); end loop; end; else -- Find the sources in the project files for FN_Source of File_Names loop declare File_Name : String renames FN_Source.File_Name; Unit : GPR.Unit_Index; Subunit : Boolean := False; begin Canonical_Case_File_Name (File_Name); Unit := Units_Htable.Get_First (Tree.Units_HT); Unit_Loop : while Unit /= No_Unit_Index loop -- We only need to put the library units, body or spec, but -- not the subunits. if Unit.File_Names (Impl) /= null and then not Unit.File_Names (Impl).Locally_Removed then -- There is a body, check if it is for this project if All_Projects or else Ultimate_Extending_Project_Of (Unit.File_Names (Impl).Project) = Project then Subunit := False; if Unit.File_Names (Spec) = null or else Unit.File_Names (Spec).Locally_Removed then -- We have a body with no spec: we need to check if -- this is a subunit, because gnatls will complain -- about subunits. Subunit := Is_Subunit (Unit.File_Names (Impl)); end if; if not Subunit then declare Object_Name : String := Get_Name_String (Unit.File_Names (Impl).Object); Dep_Name : String := Get_Name_String (Unit.File_Names (Impl).Dep_Name); begin Canonical_Case_File_Name (Object_Name); Canonical_Case_File_Name (Dep_Name); if Dep_Name in File_Name | File_Name & ".ali" or else File_Name in Object_Name | Get_Name_String (Unit.File_Names (Impl).File) | Get_Name_String (Unit.File_Names (Impl) .Display_File) then FN_Source.Source := Unit.File_Names (Impl); FN_Source.Tree := Tree; exit Unit_Loop; end if; end; end if; end if; elsif Unit.File_Names (Spec) /= null and then not Unit.File_Names (Spec).Locally_Removed and then -- We have a spec with no body. Check if it is for this -- project. (All_Projects or else Unit.File_Names (Spec).Project = Project) then declare Object_Name : String := Get_Name_String (Unit.File_Names (Spec).Object); Dep_Name : String := Get_Name_String (Unit.File_Names (Spec).Dep_Name); begin Canonical_Case_File_Name (Object_Name); Canonical_Case_File_Name (Dep_Name); if Dep_Name in File_Name | File_Name & ".ali" or else File_Name in Object_Name | Get_Name_String (Unit.File_Names (Spec).File) | Get_Name_String (Unit.File_Names (Spec).Display_File) then FN_Source.Source := Unit.File_Names (Spec); FN_Source.Tree := Tree; end if; end; end if; Unit := Units_Htable.Get_Next (Tree.Units_HT); end loop Unit_Loop; end; end loop; end if; -- Create mapping of ALI files to Source_Id -- Get all the compilable sources of the projects declare Unit : GPR.Unit_Index; Subunit : Boolean := False; begin Unit := Units_Htable.Get_First (Tree.Units_HT); while Unit /= No_Unit_Index loop -- We only need to put the library units, body or spec, but not -- the subunits. if Unit.File_Names (Impl) /= null and then not Unit.File_Names (Impl).Locally_Removed then Subunit := False; if Unit.File_Names (Spec) = null or else Unit.File_Names (Spec).Locally_Removed then -- We have a body with no spec: we need to check if this is -- a subunit. Subunit := Is_Subunit (Unit.File_Names (Impl)); end if; if not Subunit then Add_ALI (Unit.File_Names (Impl).File, Spec => False, Source => Unit.File_Names (Impl)); end if; end if; if Unit.File_Names (Spec) /= null and then not Unit.File_Names (Spec).Locally_Removed then Add_ALI (Unit.File_Names (Spec).File, Spec => True, Source => Unit.File_Names (Spec)); end if; Unit := Units_Htable.Get_Next (Tree.Units_HT); end loop; end; end Do_List; procedure For_All_And_Aggregated is new For_Project_And_Aggregated (Do_List); begin Initialize; -- Add the external variable GPR_TOOL (default value "gprbuild") Add_Gpr_Tool_External; Check_Version_And_Help ("GPRLS", "2015"); Project_File_Name_Expected := False; -- Loop to scan out arguments Next_Arg := 1; Scan_Args : while Next_Arg <= Argument_Count loop declare Next_Argv : constant String := Argument (Next_Arg); begin Scan_Arg (Next_Argv); end; Next_Arg := Next_Arg + 1; end loop Scan_Args; No_Files_In_Command_Line := File_Names.Is_Empty; if Very_Verbose_Mode then Closure := False; Dependable := False; if not File_Names.Is_Empty then All_Projects := True; end if; elsif Closure then Dependable := False; end if; if Project_File_Name_Expected then Fail ("project file name missing"); elsif Search_Project_Dir_Expected then Fail ("directory name missing after -aP"); end if; -- Output usage information when requested if Print_Usage then Usage; end if; if Project_File_Name = null and then File_Names.Is_Empty and then not Verbose_Mode then if Argument_Count = 0 then Usage; else Try_Help; Exit_Status := E_Fatal; end if; Exit_Program (Exit_Status); end if; Save_Verbose := Verbose_Mode; Save_Verbosity_Level := Verbosity_Level; No_Project_File_Specified := Project_File_Name = null; if Verbose_Mode and then No_Project_File_Specified and then File_Names.Is_Empty then Verbose_Mode := False; Verbosity_Level := None; Quiet_Output := True; end if; if Load_Standard_Base then Knowledge.Parse_Knowledge_Base (Project_Tree); end if; if Target_Name = null then GPR.Env.Initialize_Default_Project_Path (Root_Environment.Project_Path, Target_Name => Knowledge.Normalized_Hostname, Runtime_Name => Runtime_Name_For (Snames.Name_Ada)); else GPR.Env.Initialize_Default_Project_Path (Root_Environment.Project_Path, Target_Name => Target_Name.all, Runtime_Name => Runtime_Name_For (Snames.Name_Ada)); end if; if Project_File_Name = null then Look_For_Default_Project (Never_Fail => True); end if; if Project_File_Name = null then Try_Help; Fail_Program (null, "no project file specified"); end if; Path_Name := new String (1 .. Project_File_Name'Length + Project_File_Extension'Length); Path_Last := Project_File_Name'Length; if File_Names_Case_Sensitive then Path_Name (1 .. Path_Last) := Project_File_Name.all; else Path_Name (1 .. Path_Last) := To_Lower (Project_File_Name.all); end if; Path_Name (Path_Last + 1 .. Path_Name'Last) := Project_File_Extension; if Path_Last < Project_File_Extension'Length + 1 or else Path_Name (Path_Last - Project_File_Extension'Length + 1 .. Path_Last) /= Project_File_Extension then Path_Last := Path_Name'Last; end if; Output_Name := new String'(Path_Name (1 .. Path_Last)); if Target_Name = null then Target_Name := new String'(""); end if; if Config_Project_File_Name = null then Config_Project_File_Name := new String'(""); end if; Opt.Warning_Mode := Suppress; begin Main_Project := No_Project; Parse_Project_And_Apply_Config (Main_Project => Main_Project, User_Project_Node => User_Project_Node, Config_File_Name => Config_Project_File_Name.all, Autoconf_Specified => False, Project_File_Name => Output_Name.all, Project_Tree => Project_Tree, Project_Node_Tree => Project_Node_Tree, Packages_To_Check => Packages_To_Check, Env => Root_Environment, Allow_Automatic_Generation => True, Automatically_Generated => Delete_Autoconf_File, Config_File_Path => Configuration_Project_Path, Target_Name => Target_Name.all, Normalized_Hostname => Knowledge.Normalized_Hostname, Implicit_Project => No_Project_File_Found); exception when E : GPR.Conf.Invalid_Config => Fail_Program (Project_Tree, Exception_Message (E)); end; if Main_Project = No_Project then Fail_Program (Project_Tree, "unable to process project file " & Output_Name.all); end if; Verbose_Mode := Save_Verbose; Verbosity_Level := Save_Verbosity_Level; Quiet_Output := False; if Verbose_Mode then Display_Paths; if No_Project_File_Specified and then File_Names.Is_Empty then Finish_Program (Project_Tree); end if; end if; Set_Gprls_Mode; For_All_And_Aggregated (Main_Project, Project_Tree); if No_Files_In_Command_Line then Sort_File_Names (File_Names.First_Index, File_Names.Last_Index); -- Remove duplicates declare Idx : Natural := File_Names.First_Index + 1; function Same_Path (Left, Right : GPR.Source_Id) return Boolean is (No_Source not in Left | Right and then (Left = Right or else Left.Path = Right.Path)); begin while Idx <= File_Names.Last_Index loop if Same_Path (File_Names (Idx - 1).Source, File_Names (Idx).Source) and then File_Names (Idx - 1).Source.Project.Name = File_Names (Idx).Source.Project.Name then File_Names.Delete (Idx); else Idx := Idx + 1; end if; end loop; end; end if; Look_For_Sources; if Closure then Display_Closures; else Display_Output; end if; Finish_Program (Project_Tree); end Gprls.Main; gprbuild-25.0.0/src/gprls.adb000066400000000000000000000647651470075373400160300ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2015-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; use Ada.Text_IO; with GPR.Names; use GPR.Names; with GPR.Output; use GPR.Output; with GPR.Util; package body Gprls is No_Obj : constant String := ""; use GPR.Stamps; procedure Find_Status (Source : GPR.Source_Id; Stamp : Time_Stamp_Type; Checksum : Word; Status : out File_Status); -- Determine the file status (Status) of the file represented by FS with -- the expected Stamp and checksum given as argument. FS will be updated -- to the full file name if available. --------- -- Add -- --------- procedure Add (Path : String; To : in out Paths) is Cur : Path_Access := To.First; begin while Cur /= null loop if Cur.Path.all = Path then return; end if; Cur := Cur.Next; end loop; declare New_Path : constant Path_Access := new Path_Record'(Path => new String'(Path), Next => null); begin if To = No_Paths then To := (New_Path, New_Path); else To.Last.Next := New_Path; To.Last := New_Path; end if; end; end Add; ------------- -- Add_ALI -- ------------- procedure Add_ALI (ALI_Name : File_Name_Type; Spec : Boolean; Source : GPR.Source_Id) is A : constant ALI_Kind := (File => ALI_Name, Spec => Spec); begin ALI_Names.Set (A, Source); end Add_ALI; -------------- -- Add_File -- -------------- procedure Add_File (File_Name : String; Tree : Project_Tree_Ref; Source : GPR.Source_Id := No_Source) is begin if Current_Verbosity = High then Put_Line ("adding file """ & File_Name & '"'); end if; File_Names.Append (File_Name_Source' (Name_Len => File_Name'Length, File_Name => File_Name, Tree => Tree, Source => Source, The_ALI => No_ALI_Id)); end Add_File; ------------------------------ -- Corresponding_Sdep_Entry -- ------------------------------ function Corresponding_Sdep_Entry (A : ALI_Id; U : Unit_Id) return Sdep_Id is begin for D in ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep loop if Sdep.Table (D).Sfile = Units.Table (U).Sfile then return D; end if; end loop; return No_Sdep_Id; end Corresponding_Sdep_Entry; -------------- -- Find_ALI -- -------------- function Find_ALI (Source : GPR.Source_Id) return ALI_Id is Text : Text_Buffer_Ptr; Result : ALI_Id; begin Text := Osint.Read_Library_Info (File_Name_Type (Source.Dep_Path)); if Text /= null then Result := Scan_ALI (F => File_Name_Type (Source.Dep_Path), T => Text, Ignore_ED => False, Err => True, Read_Lines => "WD"); Free (Text); return Result; else return No_ALI_Id; end if; end Find_ALI; ----------------- -- Find_Source -- ----------------- function Find_Source (ALI_Name : File_Name_Type; Spec : Boolean) return GPR.Source_Id is A : constant ALI_Kind := (File => ALI_Name, Spec => Spec); begin return ALI_Names.Get (A); end Find_Source; ----------------- -- Find_Status -- ----------------- procedure Find_Status (Source : GPR.Source_Id; ALI : ALI_Id; Status : out File_Status) is U : Unit_Id; begin if ALI = No_ALI_Id then Status := Not_Found; else if Source.Kind = Spec then U := ALIs.Table (ALI).Last_Unit; else U := ALIs.Table (ALI).First_Unit; end if; Find_Status (Source, ALI, U, Status); end if; end Find_Status; procedure Find_Status (Source : GPR.Source_Id; ALI : ALI_Id; U : Unit_Id; Status : out File_Status) is SD : constant Sdep_Id := Corresponding_Sdep_Entry (ALI, U); begin if File_Stamp (Source.Path.Name) = Sdep.Table (SD).Stamp then Status := OK; elsif Util.Calculate_Checksum (Source) and then Source.Checksum = Sdep.Table (SD).Checksum then Status := Checksum_OK; else Status := Not_Same; end if; end Find_Status; procedure Find_Status (Source : GPR.Source_Id; Stamp : Time_Stamp_Type; Checksum : Word; Status : out File_Status) is begin if Source = No_Source then Status := Not_Found; elsif File_Stamp (Source.Path.Name) = Stamp then Status := OK; elsif Util.Calculate_Checksum (Source) and then Source.Checksum = Checksum then Status := Checksum_OK; else Status := Not_Same; end if; end Find_Status; ----------------------------- -- Get_Runtime_Source_Dirs -- ----------------------------- procedure Get_Runtime_Source_Dirs (Project : Project_Id; Tree : Project_Tree_Ref; With_State : in out Paths) is List : Language_Ptr := Project.Languages; Dirs : Name_List_Index; Nam_Nod : Name_Node; begin while List /= No_Language_Index loop Dirs := List.Config.Runtime_Source_Dirs; while Dirs /= No_Name_List loop Nam_Nod := Tree.Shared.Name_Lists.Table (Dirs); Add (Get_Name_String (Nam_Nod.Name), With_State); Dirs := Nam_Nod.Next; end loop; List := List.Next; end loop; end Get_Runtime_Source_Dirs; ---------- -- Hash -- ---------- function Hash (A : ALI_Kind) return GPR.Header_Num is begin return GPR.Hash (A.File); end Hash; ------------------- -- Output_Object -- ------------------- procedure Output_Object (O : File_Name_Type) is begin if Print_Object then if O /= No_File then Put_Line (Get_Name_String (O)); else Put_Line (No_Obj); end if; end if; end Output_Object; ------------------- -- Output_Source -- ------------------- procedure Output_Source (Source : GPR.Source_Id; Sdep_I : Sdep_Id) is Stamp : GPR.Stamps.Time_Stamp_Type; Checksum : Word; Status : File_Status; Sfile : File_Name_Type; Src : GPR.Source_Id; begin if Sdep_I = No_Sdep_Id or else Source = No_Source then return; end if; Stamp := Sdep.Table (Sdep_I).Stamp; Checksum := Sdep.Table (Sdep_I).Checksum; Sfile := Sdep.Table (Sdep_I).Sfile; -- Find the real source if Sfile = Source.File then Src := Source; else -- Check if it may be a spec Src := ALI_Names.Get ((Sfile, True)); if Src = No_Source then Src := ALI_Names.Get ((Sfile, False)); if Src = No_Source then Src := Source; end if; end if; end if; if Print_Source then Find_Status (Src, Stamp, Checksum, Status); if Verbose_Mode then Put (" Source => "); Put (Get_Name_String (Src.Path.Display_Name)); Output_Status (Status, True); New_Line; else if not Selective_Output then Put (" "); Output_Status (Status, Verbose => False); end if; Put_Line (Get_Name_String (Source.Path.Display_Name)); end if; end if; end Output_Source; procedure Output_Source (Tree : Project_Tree_Ref; Sdep_I : Sdep_Id) is function Get_Source (Tree : Project_Tree_Ref; Project : Project_Id; FS : File_Name_Type) return GPR.Source_Id; ---------------- -- Get_Source -- ---------------- function Get_Source (Tree : Project_Tree_Ref; Project : Project_Id; FS : File_Name_Type) return GPR.Source_Id is Aggr : Aggregated_Project_List; Got : GPR.Source_Id; begin if Project.Qualifier = Aggregate then Aggr := Project.Aggregated_Projects; while Aggr /= null loop Got := Get_Source (Aggr.Tree, Aggr.Project, FS); if Got /= No_Source then return Got; end if; Aggr := Aggr.Next; end loop; return No_Source; else return Source_Files_Htable.Get (Tree.Source_Files_HT, FS); end if; end Get_Source; begin if Sdep_I /= No_Sdep_Id then if Tree /= No_Project_Tree then Output_Source (Source_Files_Htable.Get (Tree.Source_Files_HT, Sdep.Table (Sdep_I).Sfile), Sdep_I); else Output_Source (Get_Source (Project_Tree, Util.Main_Project, Sdep.Table (Sdep_I).Sfile), Sdep_I); end if; end if; end Output_Source; ------------------- -- Output_Status -- ------------------- procedure Output_Status (FS : File_Status; Verbose : Boolean) is begin if Verbose then case FS is when OK => Put (" unchanged"); when Checksum_OK => Put (" slightly modified"); when Not_Found => Put (" dependency file not found"); when Not_Same => Put (" modified"); end case; else case FS is when OK => Put (" OK "); when Checksum_OK => Put (" MOK "); when Not_Found => Put (" ??? "); when Not_Same => Put (" DIF "); end case; end if; end Output_Status; ----------------- -- Output_Unit -- ----------------- procedure Output_Unit (U_Id : Unit_Id) is Kind : Character; U : Unit_Record renames Units.Table (U_Id); begin Get_Name_String (U.Uname); Kind := Name_Buffer (Name_Len); Name_Len := Name_Len - 2; Set_Casing (Mixed_Case); if not Verbose_Mode then Put_Line (" " & Name_Buffer (1 .. Name_Len)); else Put (" Unit => "); New_Line; Put (" Name => "); Put (Name_Buffer (1 .. Name_Len)); New_Line; Put (" Kind => "); if Units.Table (U_Id).Unit_Kind = 'p' then Put ("package "); else Put ("subprogram "); end if; if Kind = 's' then Put_Line ("spec"); else Put_Line ("body"); end if; end if; if Verbose_Mode then if U.Preelab or else U.No_Elab or else U.Pure or else U.Dynamic_Elab or else U.Has_RACW or else U.Remote_Types or else U.Shared_Passive or else U.RCI or else U.Predefined or else U.Is_Generic or else U.Init_Scalars or else U.SAL_Interface or else U.Body_Needed_For_SAL or else U.Elaborate_Body then Put (" Flags =>"); if U.Preelab then Put (" Preelaborable"); end if; if U.No_Elab then Put (" No_Elab_Code"); end if; if U.Pure then Put (" Pure"); end if; if U.Dynamic_Elab then Put (" Dynamic_Elab"); end if; if U.Has_RACW then Put (" Has_RACW"); end if; if U.Remote_Types then Put (" Remote_Types"); end if; if U.Shared_Passive then Put (" Shared_Passive"); end if; if U.RCI then Put (" RCI"); end if; if U.Predefined then Put (" Predefined"); end if; if U.Is_Generic then Put (" Is_Generic"); end if; if U.Init_Scalars then Put (" Init_Scalars"); end if; if U.SAL_Interface then Put (" SAL_Interface"); end if; if U.Body_Needed_For_SAL then Put (" Body_Needed_For_SAL"); end if; if U.Elaborate_Body then Put (" Elaborate Body"); end if; if U.Remote_Types then Put (" Remote_Types"); end if; if U.Shared_Passive then Put (" Shared_Passive"); end if; if U.Predefined then Put (" Predefined"); end if; New_Line; end if; end if; end Output_Unit; ----------------- -- Reset_Print -- ----------------- procedure Reset_Print is begin if not Selective_Output then Selective_Output := True; Print_Source := False; Print_Object := False; Print_Unit := False; end if; end Reset_Print; -------------- -- GNATDIST -- -------------- package body GNATDIST is Runtime_Source_Dirs : Paths := No_Paths; N_Flags : Natural; N_Indents : Natural := 0; type Token_Type is (T_No_ALI, T_ALI, T_Unit, T_With, T_Source, T_Afile, T_Ofile, T_Sfile, T_Name, T_Main, T_Kind, T_Flags, T_Preelaborated, T_Pure, T_Has_RACW, T_Remote_Types, T_Shared_Passive, T_RCI, T_Predefined, T_Internal, T_Is_Generic, T_Procedure, T_Function, T_Package, T_Subprogram, T_Spec, T_Body); Image : constant array (Token_Type) of String_Access := (T_No_ALI => new String'("No_ALI"), T_ALI => new String'("ALI"), T_Unit => new String'("Unit"), T_With => new String'("With"), T_Source => new String'("Source"), T_Afile => new String'("Afile"), T_Ofile => new String'("Ofile"), T_Sfile => new String'("Sfile"), T_Name => new String'("Name"), T_Main => new String'("Main"), T_Kind => new String'("Kind"), T_Flags => new String'("Flags"), T_Preelaborated => new String'("Preelaborated"), T_Pure => new String'("Pure"), T_Has_RACW => new String'("Has_RACW"), T_Remote_Types => new String'("Remote_Types"), T_Shared_Passive => new String'("Shared_Passive"), T_RCI => new String'("RCI"), T_Predefined => new String'("Predefined"), T_Internal => new String'("Internal"), T_Is_Generic => new String'("Is_Generic"), T_Procedure => new String'("procedure"), T_Function => new String'("function"), T_Package => new String'("package"), T_Subprogram => new String'("subprogram"), T_Spec => new String'("spec"), T_Body => new String'("body")); procedure Output_Name (N : Name_Id); -- Remove any encoding info (%b and %s) and output N procedure Output_Afile (A : File_Name_Type); procedure Output_Ofile (FNS : File_Name_Source); procedure Output_Sfile (Src : GPR.Source_Id); procedure Output_Sfile (S : File_Name_Type); -- Output various names. Check that the name is different from no name. -- Otherwise, skip the output. procedure Output_Token (T : Token_Type); -- Output token using specific format. That is several indentations and: -- -- T_No_ALI .. T_With : & " =>" & NL -- T_Source .. T_Kind : & " => " -- T_Flags : & " =>" -- T_Preelab .. T_Body : " " & procedure Output_Sdep (S : Sdep_Id); procedure Output_Unit (Unit : GPR.Unit_Index; U : Unit_Id); procedure Output_With (W : With_Id); -- Output this entry as a global section (like ALIs) ------------------ -- Output_Afile -- ------------------ procedure Output_Afile (A : File_Name_Type) is begin Output_Token (T_Afile); Write_Name (Name_Id (A)); Write_Eol; end Output_Afile; ---------------- -- Output_ALI -- ---------------- procedure Output_ALI (FNS : File_Name_Source) is Src : constant GPR.Source_Id := FNS.Source; A : constant ALI_Id := FNS.The_ALI; begin Output_Token (T_ALI); N_Indents := N_Indents + 1; Output_Afile (FNS.Source.Dep_Name); Output_Ofile (FNS); Output_Sfile (FNS.Source); -- Output Main if ALIs.Table (A).Main_Program /= None then Output_Token (T_Main); if ALIs.Table (A).Main_Program = Proc then Output_Token (T_Procedure); else Output_Token (T_Function); end if; Write_Eol; end if; -- Output Units for U in ALIs.Table (A).First_Unit .. ALIs.Table (A).Last_Unit loop Output_Unit (Src.Unit, U); end loop; -- Output Sdeps for S in ALIs.Table (A).First_Sdep .. ALIs.Table (A).Last_Sdep loop Output_Sdep (S); end loop; N_Indents := N_Indents - 1; end Output_ALI; ----------------- -- Output_Name -- ----------------- procedure Output_Name (N : Name_Id) is begin -- Remove any encoding info (%s or %b) Get_Name_String (N); if Name_Len > 2 and then Name_Buffer (Name_Len - 1) = '%' then Name_Len := Name_Len - 2; end if; Output_Token (T_Name); Write_Str (Name_Buffer (1 .. Name_Len)); Write_Eol; end Output_Name; ------------------- -- Output_No_ALI -- ------------------- procedure Output_No_ALI (FNS : File_Name_Source) is begin Output_Token (T_No_ALI); N_Indents := N_Indents + 1; Output_Afile (FNS.Source.Dep_Name); N_Indents := N_Indents - 1; end Output_No_ALI; ------------------ -- Output_Ofile -- ------------------ procedure Output_Ofile (FNS : File_Name_Source) is Src : constant GPR.Source_Id := FNS.Source; begin if Src.Object_Path /= No_Path then Output_Token (T_Ofile); Write_Name (Name_Id (Src.Object_Path)); Write_Eol; elsif Src.Object /= No_File then Output_Token (T_Ofile); Write_Name (Name_Id (Src.Object_Path)); Write_Eol; end if; end Output_Ofile; ----------------- -- Output_Sdep -- ----------------- procedure Output_Sdep (S : Sdep_Id) is begin Output_Token (T_Source); Write_Name (Sdep.Table (S).Sfile); Write_Eol; end Output_Sdep; ------------------ -- Output_Sfile -- ------------------ procedure Output_Sfile (Src : GPR.Source_Id) is begin Output_Token (T_Sfile); Write_Name (Name_Id (Src.Path.Display_Name)); Write_Eol; end Output_Sfile; procedure Output_Sfile (S : File_Name_Type) is begin Output_Token (T_Sfile); Write_Name (Name_Id (S)); Write_Eol; end Output_Sfile; ------------------ -- Output_Token -- ------------------ procedure Output_Token (T : Token_Type) is begin if T in T_No_ALI .. T_Flags then for J in 1 .. N_Indents loop Write_Str (" "); end loop; Write_Str (Image (T).all); for J in Image (T)'Length .. 12 loop Write_Char (' '); end loop; Write_Str ("=>"); if T in T_No_ALI .. T_With then Write_Eol; elsif T in T_Source .. T_Name then Write_Char (' '); end if; elsif T in T_Preelaborated .. T_Body then if T in T_Preelaborated .. T_Is_Generic then if N_Flags = 0 then Output_Token (T_Flags); end if; N_Flags := N_Flags + 1; end if; Write_Char (' '); Write_Str (Image (T).all); else Write_Str (Image (T).all); end if; end Output_Token; ----------------- -- Output_Unit -- ----------------- procedure Output_Unit (Unit : GPR.Unit_Index; U : Unit_Id) is UR : constant Unit_Record := Units.Table (U); begin Output_Token (T_Unit); N_Indents := N_Indents + 1; -- Output Name Output_Name (Unit.Name); -- Output Kind Output_Token (T_Kind); if Units.Table (U).Unit_Kind = 'p' then Output_Token (T_Package); else Output_Token (T_Subprogram); end if; Get_Name_String (UR.Uname); if Name_Buffer (Name_Len) = 's' then Output_Token (T_Spec); Write_Eol; Output_Sfile (Unit.File_Names (Spec)); elsif Unit.File_Names (Impl) /= No_Source then Output_Token (T_Body); Write_Eol; Output_Sfile (Unit.File_Names (Impl)); elsif Unit.File_Names (Spec) /= No_Source then Output_Token (T_Body); Write_Eol; Output_Sfile (Unit.File_Names (Spec)); end if; -- Output Flags N_Flags := 0; if Units.Table (U).Preelab then Output_Token (T_Preelaborated); end if; if Units.Table (U).Pure then Output_Token (T_Pure); end if; if Units.Table (U).Has_RACW then Output_Token (T_Has_RACW); end if; if Units.Table (U).Remote_Types then Output_Token (T_Remote_Types); end if; if Units.Table (U).Shared_Passive then Output_Token (T_Shared_Passive); end if; if Units.Table (U).RCI then Output_Token (T_RCI); end if; if Units.Table (U).Predefined then Output_Token (T_Predefined); end if; if Units.Table (U).Is_Generic then Output_Token (T_Is_Generic); end if; if N_Flags > 0 then Write_Eol; end if; -- Output Withs for W in Units.Table (U).First_With .. Units.Table (U).Last_With loop Output_With (W); end loop; N_Indents := N_Indents - 1; end Output_Unit; ----------------- -- Output_With -- ----------------- procedure Output_With (W : With_Id) is Afile : constant File_Name_Type := Withs.Table (W).Afile; Sfile : File_Name_Type := Withs.Table (W).Sfile; Source_2 : GPR.Source_Id; Path : Path_Access := null; begin Output_Token (T_With); N_Indents := N_Indents + 1; Output_Name (Name_Id (Withs.Table (W).Uname)); -- Output Kind Output_Token (T_Kind); Get_Name_String (Withs.Table (W).Uname); if Name_Buffer (Name_Len) = 's' then Output_Token (T_Spec); else Output_Token (T_Body); end if; Write_Eol; if Afile /= No_File then Output_Afile (Afile); end if; if Sfile /= No_File then Source_2 := Source_Files_Htable.Get (Project_Tree.Source_Files_HT, Sfile); if Source_2 /= No_Source then Output_Sfile (Sfile); else if Runtime_Source_Dirs = No_Paths then Get_All_Runtime_Source_Dirs (GPR.Util.Main_Project, Project_Tree, Runtime_Source_Dirs); end if; Path := Runtime_Source_Dirs.First; declare Fname : constant String := Get_Name_String (Sfile); begin while Path /= null loop Set_Name_Buffer (Path.Path.all); Add_Char_To_Name_Buffer (Directory_Separator); Add_Str_To_Name_Buffer (Fname); if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then Sfile := Name_Find; exit; end if; Path := Path.Next; end loop; end; Output_Sfile (Sfile); end if; end if; N_Indents := N_Indents - 1; end Output_With; end GNATDIST; end Gprls; gprbuild-25.0.0/src/gprls.ads000066400000000000000000000215001470075373400160250ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2015-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ with Ada.Containers.Indefinite_Vectors; with GNAT.HTable; with GNAT.OS_Lib; use GNAT.OS_Lib; with GPR; use GPR; with GPR.ALI; use GPR.ALI; with GPR.Env; with GPR.Opt; use GPR.Opt; with GPR.Osint; use GPR.Osint; with GPR.Tree; package Gprls is private type ALI_Kind is record File : File_Name_Type; Spec : Boolean; end record; function Hash (A : ALI_Kind) return GPR.Header_Num; package ALI_Names is new GNAT.HTable.Simple_HTable (Header_Num => GPR.Header_Num, Element => GPR.Source_Id, No_Element => GPR.No_Source, Key => ALI_Kind, Hash => Hash, Equal => "="); Initialized : Boolean := False; -- Set to True by the first call to Initialize. -- To avoid reinitialization of some packages. Save_Verbose : Boolean := False; Save_Verbosity_Level : Verbosity_Level_Type; Very_Verbose_Mode : Boolean := False; -- Set to True with switch -V Project_Search_Path : constant String := "Project Search Path:"; -- Label displayed in verbose mode before the directories in the project -- search path. Do not modify without checking NOTE above. Prj_Path : GPR.Env.Project_Search_Path; Max_Column : constant := 80; No_Runtime : Boolean := False; -- Set to True if there is no default runtime and --RTS= is not specified type File_Status is ( OK, -- matching timestamp Checksum_OK, -- only matching checksum Not_Found, -- file not found on source PATH Not_Same); -- neither checksum nor timestamp matching type Dir_Data; type Dir_Ref is access Dir_Data; type Dir_Data is record Value : String_Access; Next : Dir_Ref; end record; -- Simply linked list of dirs First_Source_Dir : Dir_Ref; Last_Source_Dir : Dir_Ref; -- The list of source directories from the command line. -- These directories are added using Osint.Add_Src_Search_Dir -- after those of the GNAT Project File, if any. First_Lib_Dir : Dir_Ref; Last_Lib_Dir : Dir_Ref; -- The list of object directories from the command line. -- These directories are added using Osint.Add_Lib_Search_Dir -- after those of the GNAT Project File, if any. Main_File : File_Name_Type; Ali_File : File_Name_Type; Text : Text_Buffer_Ptr; Next_Arg : Positive; Selective_Output : Boolean := False; Print_Usage : Boolean := False; Print_Unit : Boolean := True; Print_Source : Boolean := True; Print_Object : Boolean := True; -- Flags controlling the form of the output Dependable : Boolean := False; -- -d -- Command line flags Closure : Boolean := False; -- --closure -- Get the closures of mains RTS_Specified : String_Access := null; -- Used to detect multiple use of --RTS= switch Exit_Status : Exit_Code_Type := E_Success; -- Reset to E_Fatal if bad error found type File_Name_Source (Name_Len : Natural) is record Source : GPR.Source_Id; Tree : Project_Tree_Ref; The_ALI : ALI_Id; File_Name : String (1 .. Name_Len); end record; package File_Name_Vectors is new Ada.Containers.Indefinite_Vectors (Positive, File_Name_Source); File_Names : File_Name_Vectors.Vector; -- As arguments are scanned, file names are stored in this array. The array -- is extensible, because there may be more files than arguments on the -- command line. No_Files_In_Command_Line : Boolean; -- Set this flag just after command line parsing from File_Names.Is_Empty Tree : constant GPR.Project_Node_Tree_Ref := new Project_Node_Tree_Data; -- The project tree where the project file is parsed Root_Environment : GPR.Tree.Environment; -- Packages of project files where unknown attributes are errors Naming_String : aliased String := "naming"; Builder_String : aliased String := "builder"; Compiler_String : aliased String := "compiler"; Binder_String : aliased String := "binder"; Linker_String : aliased String := "linker"; -- Name of packages to be checked when parsing/processing project files List_Of_Packages : aliased String_List := (Naming_String'Access, Builder_String'Access, Compiler_String'Access, Binder_String'Access, Linker_String'Access); Packages_To_Check : constant String_List_Access := List_Of_Packages'Access; -- List of the packages to be checked when parsing/processing project files procedure Add_ALI (ALI_Name : File_Name_Type; Spec : Boolean; Source : GPR.Source_Id); -- Add ALI_Name to hash table ALI_Names procedure Add_File (File_Name : String; Tree : Project_Tree_Ref; Source : GPR.Source_Id := No_Source); -- Add File_Name to File_Names function Find_ALI (Source : GPR.Source_Id) return ALI_Id; -- Get the ALI_Id for the source function Find_Source (ALI_Name : File_Name_Type; Spec : Boolean) return GPR.Source_Id; -- Find the source corresponding to an ALI file name procedure Find_Status (Source : GPR.Source_Id; ALI : ALI_Id; Status : out File_Status); procedure Find_Status (Source : GPR.Source_Id; ALI : ALI_Id; U : Unit_Id; Status : out File_Status); -- Determine the file status (Status) of a source file function Corresponding_Sdep_Entry (A : ALI_Id; U : Unit_Id) return Sdep_Id; -- Give the Sdep entry corresponding to the unit U in ali record A procedure Output_Object (O : File_Name_Type); -- Print out the name of the object when requested procedure Output_Source (Tree : Project_Tree_Ref; Sdep_I : Sdep_Id); -- Print out the name and status of the source corresponding to this -- sdep entry. procedure Output_Source (Source : GPR.Source_Id; Sdep_I : Sdep_Id); procedure Output_Status (FS : File_Status; Verbose : Boolean); -- Print out FS either in a coded form if verbose is false or in an -- expanded form otherwise. procedure Output_Unit (U_Id : Unit_Id); -- Print out information on the unit when requested procedure Reset_Print; -- Reset Print flags properly when selective output is chosen -- procedure Search_RTS (Name : String); -- Find include and objects path for the RTS name. Project_Tree : constant Project_Tree_Ref := new Project_Tree_Data (Is_Root_Tree => True); -- The project tree type Path_Record; type Path_Access is access Path_Record; type Path_record is record Path : String_Access := null; Next : Path_Access := null; end record; type Paths is record First : Path_Access := null; Last : Path_Access := null; end record; No_Paths : constant Paths := (null, null); procedure Add (Path : String; To : in out Paths); procedure Get_Runtime_Source_Dirs (Project : Project_Id; Tree : Project_Tree_Ref; With_State : in out Paths); procedure Get_All_Runtime_Source_Dirs is new For_Every_Project_Imported (Paths, Get_Runtime_Source_Dirs); package GNATDIST is -- Any modification to this subunit requires synchronization with the -- GNATDIST sources. procedure Output_ALI (FNS : File_Name_Source); -- Output the unit information for GNATDIST procedure Output_No_ALI (FNS : File_Name_Source); -- Indicate that an ALI file cannot be found end GNATDIST; end Gprls; gprbuild-25.0.0/src/gprmunch.sh000077500000000000000000000032341470075373400163730ustar00rootroot00000000000000#!/bin/sh if [ $# != 1 ]; then echo "Bad number of arguments"; exit 2 fi exch_file=$1 cp $exch_file $exch_file.saved # Save stdin and use exchange file as input. exec >&3 exec < $exch_file # Save and set IFS to new line. OLD_IFS=$IFS IFS=" " # Parse exchange file. section='Unknown' dep_files="" bindsec='Unknown' nm="nm-not-defined" cc="cc-not-defined" verbose="" while read line; do case $line in "[MAIN BASE NAME]") section="base name" ;; "[COMPILER PATH]") section="discard" ;; "[COMPILER OPTIONS]") section="discard" ;; "[DEPENDENCY FILES]") section="dependency" ;; "[BINDING OPTIONS]") section="options" ;; "[VERBOSE]") verbose=y; section="Unknown" ;; \[*) echo "Unknown section ($line)"; exit 1 ;; *) case $section in "discard") ;; "Unknown") echo "Malformed exchange file"; exit 1 ;; "base name") basename=$line ;; "dependency") dep_files="$dep_files $line" ;; "options") case $line in --nm=*) nm=`echo $line | sed -e "s/^--nm=//"` ;; --cc=*) cc=`echo $line | sed -e "s/^--cc=//"` ;; *) echo "Unknown binder option ($line)" ;; esac ;; *) echo "Internal error (section $section) unhandled"; exit 1 ;; esac esac done # Restore IFS and stdin. IFS=$OLD_IFS exec 3>&1 exec 3>&- # Convert dependancy files to object files. object_files=`echo $dep_files | sed -e 's/\\.d\$/.o/'` # Do the real work. $nm $object_files | munch > cpp__$basename.c $cc -c cpp__$basename.c # Generate the exchange file. cat > $1 <. -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Command_Line; use Ada.Command_Line; with Ada.Containers.Indefinite_Vectors; with Ada.Containers.Vectors; with Ada.Exceptions; use Ada.Exceptions; with Ada.Text_IO; use Ada.Text_IO; with GNAT.Command_Line; use GNAT.Command_Line; with GNAT.OS_Lib; use GNAT.OS_Lib; with GPR; with GPR.Conf; with GPR.Env; with GPR.Names; use GPR.Names; with GPR.Opt; with GPR.Osint; use GPR.Osint; with GPR.Snames; use GPR.Snames; with GPR.Tree; use GPR.Tree; with GPR.Util; use GPR.Util; with Gpr_Build_Util; use Gpr_Build_Util; with System.Regexp; use System.Regexp; procedure GPRName.Main is Usage_Output : Boolean := False; -- Set to True when usage is output, to avoid multiple output Usage_Needed : Boolean := False; -- Set to True by -h switch Version_Output : Boolean := False; -- Set to True when version is output, to avoid multiple output Very_Verbose : Boolean := False; -- Set to True with -v -v File_Path : String_Access := null; -- Path name of the file specified -P switch File_Set : Boolean := False; -- Set to True by -P switch. -- Used to detect multiple -P switches. Project_File_Name_Expected : Boolean := False; -- True when switch "-P" has just been scanned Directory_Expected : Boolean := False; -- True when switch "-d" has just been scanned Dir_File_Name_Expected : Boolean := False; -- True when switch "-D" has just been scanned Foreign_Pattern_Expected : Boolean := False; -- True when switch "-f" has just been scanned Foreign_Language : Name_Id := No_Name; Excluded_Pattern_Expected : Boolean := False; -- True when switch "-x" has just been scanned type Foreign_Pattern (Ptrn_Len : Natural) is record Language : Name_Id := No_Name; Pattern : String (1 .. Ptrn_Len); end record; package Foreign_Patterns is new Ada.Containers.Indefinite_Vectors (Positive, Foreign_Pattern); -- Table to accumulate the patterns for non Ada sources type Argument_Data is record Directories : String_Vectors.Vector; Name_Patterns : String_Vectors.Vector; Excluded_Patterns : String_Vectors.Vector; Foreign_Sources_Patterns : Foreign_Patterns.Vector; end record; package Argument_Data_Vectors is new Ada.Containers.Vectors (Positive, Argument_Data); Arguments : Argument_Data_Vectors.Vector; -- Table to accumulate directories and patterns Preprocessor_Switches : String_Vectors.Vector; -- Table to store the preprocessor switches to be used in the call -- to the compiler. procedure Add_Source_Directory (S : String); -- Add S in the Source_Directories table procedure Check_Regular_Expression (S : String); -- Compile string S into a Regexp, fail if any error procedure Get_Directories (From_File : String); -- Read a source directory text file procedure Initialize; -- Do the necessary package intialization and process the command line -- arguments. procedure Output_Version; -- Print name and version procedure Scan_Arg (Arg : String); -- Process on of the command line argument procedure Usage; -- Print usage -------------------------- -- Add_Source_Directory -- -------------------------- procedure Add_Source_Directory (S : String) is procedure Update (List : in out Argument_Data); procedure Update (List : in out Argument_Data) is begin List.Directories.Append (S); end Update; begin Argument_Data_Vectors.Update_Element (Arguments, Arguments.Last_Index, Update'Access); end Add_Source_Directory; ----------------------------- -- Check_Regular_Expression-- ----------------------------- procedure Check_Regular_Expression (S : String) is Dummy : Regexp; pragma Warnings (Off, Dummy); begin Dummy := Compile (S, Glob => True); exception when Error_In_Regexp => Fail ("invalid regular expression """ & S & """"); end Check_Regular_Expression; --------------------- -- Get_Directories -- --------------------- procedure Get_Directories (From_File : String) is File : Ada.Text_IO.File_Type; Line : String (1 .. 2_000); Last : Natural; begin Open (File, In_File, From_File); while not End_Of_File (File) loop Get_Line (File, Line, Last); if Last /= 0 then Add_Source_Directory (Line (1 .. Last)); end if; end loop; Close (File); exception when Name_Error => Fail ("cannot open source directory file """ & From_File & '"'); end Get_Directories; ---------------- -- Initialize -- ---------------- procedure Initialize is procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage); User_Project_Node : Project_Node_Id; -- Used to call Parse_Project_And_Apply_Config begin -- Do some necessary package initializations GPR.Snames.Initialize; Set_Program_Name ("gprname"); GPR.Tree.Initialize (Root_Environment, Gprname_Flags); GPR.Tree.Initialize (Project_Node_Tree); GPR.Initialize (Project_Tree); -- Initialize tables Arguments.Clear; Arguments.Append (Argument_Data'(others => <>)); Preprocessor_Switches.Clear; -- First check for --version or --help Check_Version_And_Help ("GPRNAME", "2001"); -- Now scan the other switches Project_File_Name_Expected := False; Directory_Expected := False; Dir_File_Name_Expected := False; Foreign_Pattern_Expected := False; Excluded_Pattern_Expected := False; for Next_Arg in 1 .. Argument_Count loop Scan_Arg (Argument (Next_Arg)); end loop; if Project_File_Name_Expected or else not File_Set then Fail ("project file name missing"); elsif File_Path = null then Try_Help; Fail_Program (null, "no project file specified"); elsif Directory_Expected then Fail ("directory name missing"); elsif Dir_File_Name_Expected then Fail ("directory list file name missing"); elsif Foreign_Pattern_Expected then Fail ("foreign pattern missing"); elsif Excluded_Pattern_Expected then Fail ("excluded pattern missing"); end if; GPR.Env.Initialize_Default_Project_Path (Root_Environment.Project_Path, Target_Name => "-"); if Load_Standard_Base then -- We need to parse the knowledge base so that we are able to -- normalize the target names. Unfortunately, if we have to spawn -- gprconfig, it will also have to parse that knowledge base on -- its own. Knowledge.Parse_Knowledge_Base (Project_Tree); end if; if Target_Name = null then Target_Name := new String'(""); end if; if Config_Project_File_Name = null then Config_Project_File_Name := new String'(""); end if; -- Check if the project file already exists declare Path_Name : constant String := Normalize_Pathname (Ensure_Extension (File_Path.all, Project_File_Extension), Case_Sensitive => False); begin Free (File_Path); File_Path := new String'(Path_Name); end; if Is_Regular_File (File_Path.all) then if Opt.Verbose_Mode then Put_Line ("Parsing already existing project file """ & File_Path.all & ""); end if; else -- The project file does not exist; create an empty one declare File : File_Type; File_Name_Start : Positive := File_Path'First; File_Name_Last : constant Positive := File_Path'Last - Project_File_Extension'Length; begin for J in reverse File_Path'Range loop if File_Path (J) = Directory_Separator then File_Name_Start := J + 1; exit; end if; end loop; Create (File, Out_File, File_Path.all); Put (File, "project "); Put (File, File_Path (File_Name_Start .. File_Name_Last)); Put_Line (File, " is"); Put (File, "end "); Put (File, File_Path (File_Name_Start .. File_Name_Last)); Put_Line (File, ";"); Close (File); exception when others => Fail ("could not create project file " & File_Path.all); end; end if; begin GPR.Opt.Warning_Mode := GPR.Opt.Suppress; GPR.Conf.Parse_Project_And_Apply_Config (Main_Project => Main_Project, User_Project_Node => User_Project_Node, Config_File_Name => Config_Project_File_Name.all, Autoconf_Specified => Autoconf_Specified, Project_File_Name => File_Path.all, Project_Tree => Project_Tree, Env => Root_Environment, Project_Node_Tree => Project_Node_Tree, Packages_To_Check => Packages_To_Check, Allow_Automatic_Generation => Autoconfiguration, Automatically_Generated => Delete_Autoconf_File, Config_File_Path => Configuration_Project_Path, Target_Name => Target_Name.all, Normalized_Hostname => Knowledge.Normalized_Hostname); exception when E : GPR.Conf.Invalid_Config => Fail_Program (Project_Tree, Exception_Message (E)); end; if Main_Project = No_Project then -- Don't flush messages in case of parsing error. This has already -- been taken care when parsing the tree. Otherwise, it results in -- the same message being displayed twice. Fail_Program (Project_Tree, """" & File_Path.all & """ processing failed", Flush_Messages => Present (User_Project_Node)); else declare Ada_Lang : constant Language_Ptr := Get_Language_From_Name (Main_Project, "ada"); begin if Ada_Lang /= No_Language_Index then Gcc_Path := Get_Compiler_Driver_Path (Main_Project, Ada_Lang); end if; end; end if; end Initialize; -------------------- -- Output_Version -- -------------------- procedure Output_Version is begin if not Version_Output then Version_Output := True; New_Line; Display_Version ("GPRNAME", "2001"); end if; end Output_Version; -------------- -- Scan_Arg -- -------------- procedure Scan_Arg (Arg : String) is pragma Assert (Arg'First = 1); procedure Add_Foreign_Source (Argument : in out Argument_Data); ------------------------ -- Add_Foreign_Source -- ------------------------ procedure Add_Foreign_Source (Argument : in out Argument_Data) is begin Argument.Foreign_Sources_Patterns.Append (Foreign_Pattern' (Ptrn_Len => Arg'Length, Language => Foreign_Language, Pattern => Arg)); end Add_Foreign_Source; begin if Arg'Length > 0 then -- -P xxx if Project_File_Name_Expected then if Arg (1) = '-' then Fail ("project file name missing"); else File_Set := True; File_Path := new String'(Arg); Project_File_Name_Expected := False; end if; -- -d xxx elsif Directory_Expected then Add_Source_Directory (Arg); Directory_Expected := False; -- -D xxx elsif Dir_File_Name_Expected then Get_Directories (Arg); Dir_File_Name_Expected := False; -- -f xxx elsif Foreign_Pattern_Expected then Arguments.Update_Element (Arguments.Last_Index, Add_Foreign_Source'Access); Check_Regular_Expression (Arg); Foreign_Pattern_Expected := False; -- -x xxx elsif Excluded_Pattern_Expected then Arguments.Reference (Arguments.Last).Element.Excluded_Patterns.Append (Arg); Check_Regular_Expression (Arg); Excluded_Pattern_Expected := False; -- There must be at least one Ada pattern or one foreign pattern for -- the previous section. -- --and elsif Arg = "--and" then if Arguments.Last_Element.Name_Patterns.Is_Empty and then Arguments.Last_Element.Foreign_Sources_Patterns.Is_Empty then Try_Help; return; end if; -- If no directory were specified for the previous section, then -- the directory is the project directory. if Arguments.Last_Element.Directories.Is_Empty then Arguments.Reference (Arguments.Last).Element.Directories.Append ("."); end if; -- Add and initialize another component to Arguments table declare New_Arguments : Argument_Data; pragma Warnings (Off, New_Arguments); -- Declaring this defaulted initialized object ensures that -- the new allocated component of table Arguments is correctly -- initialized. begin Arguments.Append (New_Arguments); end; -- --ignore-predefined-units elsif Arg = "--ignore-predefined-units" then Opt.Ignore_Predefined_Units := True; -- --ignore-duplicate-files elsif Arg = "--ignore-duplicate-files" then Opt.Ignore_Duplicate_Files := True; -- --no-backup elsif Arg = "--no-backup" then Opt.No_Backup := True; -- --target= elsif Arg'Length > Target_Project_Option'Length and then Arg (1 .. Target_Project_Option'Length) = Target_Project_Option then if Target_Name = null then Target_Name := new String' (Arg (Target_Project_Option'Length + 1 .. Arg'Last)); elsif Target_Name.all /= Arg (Target_Project_Option'Length + 1 .. Arg'Last) then Fail ("multiple targets"); end if; -- --RTS=path elsif Arg'Length >= 5 and then Arg (1 .. 5) = "--RTS" then if Arg'Length <= 6 or else Arg (6) /= '='then Osint.Fail ("missing path for --RTS"); else -- Check that it is the first time we see this switch or, if -- it is not the first time, the same path is specified. if RTS_Specified = null then RTS_Specified := new String'(Arg (7 .. Arg'Last)); GPR.Conf.Set_Runtime_For (Snames.Name_Ada, Arg (7 .. Arg'Last)); elsif RTS_Specified.all /= Arg (7 .. Arg'Last) then Osint.Fail ("--RTS cannot be specified multiple times"); end if; end if; -- -d elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-d" then if Arg'Length = 2 then Directory_Expected := True; else Add_Source_Directory (Arg (3 .. Arg'Last)); end if; -- -D elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-D" then if Arg'Length = 2 then Dir_File_Name_Expected := True; else Get_Directories (Arg (3 .. Arg'Last)); end if; -- -eL elsif Arg = "-eL" then Opt.Follow_Links_For_Files := True; Opt.Follow_Links_For_Dirs := True; -- -f elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-f" then if Arg'Length = 2 then Foreign_Pattern_Expected := True; Foreign_Language := Name_C; elsif Arg (3) = ':' then if Arg'Length = 3 then Fail ("wrong switch: " & Arg); else Name_Len := Arg'Length - 3; Name_Buffer (1 .. Name_Len) := To_Lower (Arg (4 .. Arg'Last)); Foreign_Language := Name_Find; Foreign_Pattern_Expected := True; end if; else Arguments.Reference (Arguments.Last).Element.Foreign_Sources_Patterns.Append (Foreign_Pattern' (Ptrn_Len => Arg'Length - 2, Language => Name_C, Pattern => Arg (3 .. Arg'Last))); Check_Regular_Expression (Arg (3 .. Arg'Last)); end if; -- -gnatep or -gnateD elsif Arg'Length > 7 and then Arg (1 .. 7) in "-gnatep" | "-gnateD" then Preprocessor_Switches.Append (Arg); -- -h elsif Arg = "-h" then Usage_Needed := True; -- -P elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-P" then if File_Set then Fail ("only one -P switch may be specified"); end if; if Arg'Length = 2 then Project_File_Name_Expected := True; else File_Set := True; File_Path := new String'(Arg (3 .. Arg'Last)); end if; -- -v elsif Arg = "-v" then if Opt.Verbose_Mode then Very_Verbose := True; else Opt.Verbose_Mode := True; Opt.Verbosity_Level := Opt.High; end if; -- -vP? elsif Arg'Length = 4 and then Arg (1 .. 3) = "-vP" and then Arg (4) in '0' .. '2' then case Arg (4) is when '0' => Current_Verbosity := Default; when '1' => Current_Verbosity := Medium; when '2' => Current_Verbosity := High; when others => null; end case; -- -x elsif Arg'Length >= 2 and then Arg (1 .. 2) = "-x" then if Arg'Length = 2 then Excluded_Pattern_Expected := True; else Arguments.Reference (Arguments.Last).Element.Excluded_Patterns.Append (Arg (3 .. Arg'Last)); Check_Regular_Expression (Arg (3 .. Arg'Last)); end if; -- -X elsif Arg'Length >= 3 and then Arg (1 .. 2) = "-X" and then Is_External_Assignment (Root_Environment, Arg) then -- Is_External_Assignment has side effects when it returns True null; -- Junk switch starting with minus elsif Arg (1) = '-' then Fail ("wrong switch: " & Arg); -- Not a recognized switch, assume file name else declare File_Name : String := Arg; begin Canonical_Case_File_Name (File_Name); Arguments.Reference (Arguments.Last).Element.Name_Patterns.Append (File_Name); Check_Regular_Expression (File_Name); end; end if; end if; end Scan_Arg; ----------- -- Usage -- ----------- procedure Usage is begin if not Usage_Output then Usage_Needed := False; Usage_Output := True; Put_Line ("Usage: gprname [switches] naming-pattern [naming-patterns]"); Put_Line (" {--and [switches] naming-pattern [naming-patterns]}"); New_Line; Put_Line ("switches:"); Display_Usage_Version_And_Help; Put_Line (" --target= indicates the target of the GNAT compiler"); New_Line; Put_Line (" --RTS=dir specify the Ada runtime"); Put_Line (" --no-backup do not create backup of project file"); New_Line; Put_Line (" --ignore-duplicate-files ignore duplicate basenames"); Put_Line (" --ignore-predefined-units ignore predefined units"); New_Line; Put_Line (" --and use different patterns"); New_Line; Put_Line (" -ddir use dir as one of the source " & "directories"); Put_Line (" -Dfile get source directories from file"); Put_Line (" -eL follow symbolic links when processing " & "project files"); Put_Line (" -fpat pattern for C source"); Put_Line (" -f:lang pat pattern for source of language lang"); Put_Line (" -gnateDsym=v preprocess with symbol definition"); Put_Line (" -gnatep=data preprocess files with data file"); Put_Line (" -h output this help message"); Put_Line (" -Pproj update or create project file proj"); Put_Line (" -v verbose output"); Put_Line (" -v -v very verbose output"); Put_Line (" -vPx " & "Specify verbosity when parsing Project Files (x = 0/1/2)"); Put_Line (" -xpat exclude pattern pat"); end if; end Usage; -- Start of processing for Gnatname begin -- Add the external variable GPR_TOOL (default value "gprbuild") Add_Gpr_Tool_External; Initialize; if Opt.Verbose_Mode then Output_Version; end if; if Usage_Needed then Usage; end if; -- If no Ada or foreign pattern was specified, print the usage and return if Arguments.Last_Element.Name_Patterns.Is_Empty and then Arguments.Last_Element.Foreign_Sources_Patterns.Is_Empty then if Argument_Count = 0 then Usage; elsif not Usage_Output then Try_Help; end if; return; end if; -- If no source directory was specified, use the current directory as the -- unique directory. Note that if a file was specified with directory -- information, the current directory is the directory of the specified -- file. if Arguments.Last_Element.Directories.Is_Empty then Arguments.Reference (Arguments.Last).Element.Directories.Append ("."); end if; -- Initialize Initialize (File_Path => File_Path.all, Preproc_Switches => Preprocessor_Switches, Very_Verbose => Very_Verbose, Flags => Gprname_Flags); -- Process each section successively for Arg of Arguments loop declare Name_Patterns : Regexp_List; Excl_Patterns : Regexp_List; Frgn_Patterns : Foreign_Regexp_List; begin for Name of Arg.Name_Patterns loop Name_Patterns.Append (Compile (Name, Glob => True)); end loop; for Excl of Arg.Excluded_Patterns loop Excl_Patterns.Append (Compile (Excl, Glob => True)); end loop; for Frgn of Arg.Foreign_Sources_Patterns loop Frgn_Patterns.Append (Foreign_Regexp' (Language => Frgn.Language, Pattern => Compile (Frgn.Pattern, Glob => True))); end loop; Process (Directories => Arg.Directories, Name_Patterns => Name_Patterns, Excluded_Patterns => Excl_Patterns, Foreign_Patterns => Frgn_Patterns); end; end loop; -- Finalize Finalize; if Opt.Verbose_Mode then New_Line; end if; Finish_Program (Project_Tree); end GPRName.Main; gprbuild-25.0.0/src/gprname.adb000066400000000000000000001771641470075373400163300ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2023, AdaCore -- -- -- -- 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 Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING3. If not, go to -- -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Ada.Containers.Ordered_Maps; with Ada.Text_IO; use Ada.Text_IO; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GPR.Attr.PM; with GPR.Com; with GPR.Env; with GPR.Names; use GPR.Names; with GPR.Opt; with GPR.Osint; use GPR.Osint; with GPR.Part; with GPR.PP; with GPR.Tree; use GPR.Tree; with GPR.Snames; use GPR.Snames; with GPR.Tempdir; with Gpr_Build_Util; use Gpr_Build_Util; with GPR.Sdefault; with System.CRTL; with System.HTable; package body GPRName is use GPR.Util.Project_Output; -- Packages of project files where unknown attributes are errors -- All the following need comments ??? All global variables and -- subprograms must be fully commented. Very_Verbose : Boolean := False; -- Set in call to Initialize to indicate very verbose output Tree : constant GPR.Project_Node_Tree_Ref := new Project_Node_Tree_Data; -- The project tree where the project file is parsed Args : Argument_List_Access; -- The list of arguments for calls to the compiler to get the unit names -- and kinds (spec or body) in the Ada sources. Path_Name : String_Access; Directory_Last : Natural := 0; Output_Name : String_Access; Output_Name_Last : Natural; Output_Name_Id : Name_Id; Project_Naming_File_Name : String_Access; -- String (1 .. Output_Name'Length + Naming_File_Suffix'Length); Project_Naming_Last : Natural; Project_Naming_Id : Name_Id := No_Name; Source_List_Path : String_Access; -- (1 .. Output_Name'Length + Source_List_File_Suffix'Length); Source_List_Last : Natural; Source_List_FD : File_Descriptor; Project_Node : Project_Node_Id := Empty_Project_Node; Project_Declaration : Project_Node_Id := Empty_Project_Node; Source_Dirs_List : Project_Node_Id := Empty_Project_Node; Languages_List : Project_Node_Id := Empty_Project_Node; Project_Naming_Node : Project_Node_Id := Empty_Project_Node; Project_Naming_Decl : Project_Node_Id := Empty_Project_Node; Naming_Package : Project_Node_Id := Empty_Project_Node; Naming_Package_Comments : Project_Node_Id := Empty_Project_Node; Source_Files_Comments : Project_Node_Id := Empty_Project_Node; Source_Dirs_Comments : Project_Node_Id := Empty_Project_Node; Source_List_File_Comments : Project_Node_Id := Empty_Project_Node; Languages_Comments : Project_Node_Id := Empty_Project_Node; function Dup (Fd : File_Descriptor) return File_Descriptor; -- Create a copy of Fd and returns it procedure Dup2 (Old_Fd, New_Fd : File_Descriptor); -- Close New_Fd if necessary and copy Old_Fd into New_Fd Non_Empty_Node : constant Project_Node_Id := 1; -- Used for the With_Clause of the naming project type Matched_Type is (Match, No_Match, Excluded); Naming_File_Suffix : constant String := "_naming"; Source_List_File_Suffix : constant String := "_source_list.txt"; Processed_Directories : String_Vectors.Vector; -- The list of already processed directories for each section, to avoid -- processing several times the same directory in the same section. Source_Directories : String_Vectors.Vector; -- The complete list of directories to be put in attribute Source_Dirs in -- the project file. type Source is record File_Name : Name_Id; Unit_Name : Name_Id; Index : Int := 0; Spec : Boolean; Position : Natural; -- Used to preserve the file search order end record; function "<" (Left, Right : Source) return Boolean is ("<" (Get_Name_String (Left.File_Name) & Left.Position'Image, Get_Name_String (Right.File_Name) & Right.Position'Image)); package Source_Vectors is new Ada.Containers.Vectors (Positive, Source); Sources : Source_Vectors.Vector; -- The list of Ada sources found, with their unit name and kind, to be put -- in the source attribute and package Naming of the project file, or in -- the pragmas Source_File_Name in the configuration pragmas file. type Foreign_Source is record Language : Name_Id; File_Name : Name_Id; Position : Natural; -- Used to preserve the file search order end record; function "<" (Left, Right : Foreign_Source) return Boolean is ("<" (Get_Name_String (Left.File_Name) & Left.Position'Image, Get_Name_String (Right.File_Name) & Right.Position'Image)); package Foreign_Source_Vectors is new Ada.Containers.Vectors (Positive, Foreign_Source); Foreign_Sources : Foreign_Source_Vectors.Vector; package Source_Files is new System.HTable.Simple_HTable (Header_Num => GPR.Header_Num, Element => Boolean, No_Element => False, Key => Name_Id, Hash => GPR.Hash, Equal => "="); -- Hash table to keep track of source file names, to avoid putting several -- times the same file name in case of multi-unit files. package Source_Count_Package is new Ada.Containers.Ordered_Maps (Key_Type => Name_Id, Element_Type => Natural); Source_Count : Source_Count_Package.Map; -- For a source file name (without path information), keep track of the -- number of homonyms. function Get_Source_Position (N : Name_Id) return Natural; type Name_Index_Pair is record Name : Name_Id; Index : Int; end record; function "<" (Left, Right : Name_Index_Pair) return Boolean; function "<" (Left, Right : Name_Index_Pair) return Boolean is ((if Left.Name /= Right.Name then Left.Name < Right.Name else Left.Index < Right.Index)); package First_Index_Package is new Ada.Containers.Ordered_Maps (Key_Type => Name_Index_Pair, Element_Type => Positive); First_Index : First_Index_Package.Map; -- For a source file name (without path information), keep track of the -- index in Sources for its first occurrence. Languages : Name_Vectors.Vector; procedure Add_Language (Lang : Name_Id); -- Add Lang to the list of languages ------------------ -- Add_Language -- ------------------ procedure Add_Language (Lang : Name_Id) is begin if not Languages.Contains (Lang) then Languages.Append (Lang); end if; end Add_Language; ------------------------- -- Get_Source_Position -- ------------------------- function Get_Source_Position (N : Name_Id) return Natural is Result : Natural := 1; begin if Source_Count.Contains (N) then Result := Source_Count.Element (N) + 1; Source_Count.Replace (N, Result); else Source_Count.Insert (N, 1); end if; return Result; end Get_Source_Position; --------- -- Dup -- --------- function Dup (Fd : File_Descriptor) return File_Descriptor is begin return File_Descriptor (System.CRTL.dup (Integer (Fd))); end Dup; ---------- -- Dup2 -- ---------- procedure Dup2 (Old_Fd, New_Fd : File_Descriptor) is Fd : Integer; pragma Warnings (Off, Fd); begin Fd := System.CRTL.dup2 (Integer (Old_Fd), Integer (New_Fd)); end Dup2; -------------- -- Finalize -- -------------- procedure Finalize is Discard : Boolean; pragma Warnings (Off, Discard); Current_Source_Dir : Project_Node_Id := Empty_Project_Node; Current_Language_Node : Project_Node_Id := Empty_Project_Node; Naming_Decl_Item : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Declarative_Item, In_Tree => Tree); Naming : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Package_Declaration, In_Tree => Tree); begin -- If there were no already existing project file, or if the parsing was -- unsuccessful, create an empty project node with the correct name and -- its project declaration node. if No (Project_Node) then Project_Node := Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree); Set_Name_Of (Project_Node, Tree, To => Output_Name_Id); Set_Project_Declaration_Of (Project_Node, Tree, To => Default_Project_Node (Of_Kind => N_Project_Declaration, In_Tree => Tree)); end if; -- Delete the file if it already exists Delete_File (Path_Name.all, Success => Discard); -- Create a new one if Opt.Verbose_Mode then Put ("Creating new file """); Put (Path_Name (Directory_Last + 1 .. Path_Name'Last)); Put_Line (""""); end if; Output_FD := Create_New_File (Path_Name.all, Fmode => Text); -- Fails if project file cannot be created if Output_FD = Invalid_FD then GPR.Com.Fail ("cannot create new """ & Path_Name.all & """"); end if; -- Delete the source list file, if it already exists declare Discard : Boolean; pragma Warnings (Off, Discard); begin Delete_File (Source_List_Path (1 .. Source_List_Last), Success => Discard); end; -- And create a new source list file, fail if file cannot be created Source_List_FD := Create_New_File (Name => Source_List_Path (1 .. Source_List_Last), Fmode => Text); if Source_List_FD = Invalid_FD then GPR.Com.Fail ("cannot create file """ & Source_List_Path (1 .. Source_List_Last) & """"); end if; if Opt.Verbose_Mode then Put ("Naming project file name is """); Put (Project_Naming_File_Name (1 .. Project_Naming_Last)); Put_Line (""""); end if; -- Sort the ada/foreign source vectors to have deterministic -- content in the source list and naming project files. declare package Sources_Sorting is new Source_Vectors.Generic_Sorting; package Foreign_Sources_Sorting is new Foreign_Source_Vectors.Generic_Sorting; begin Sources_Sorting.Sort (Sources); Foreign_Sources_Sorting.Sort (Foreign_Sources); end; -- Create the naming project node Project_Naming_Node := Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree); Set_Name_Of (Project_Naming_Node, Tree, To => Project_Naming_Id); Project_Naming_Decl := Default_Project_Node (Of_Kind => N_Project_Declaration, In_Tree => Tree); Set_Project_Declaration_Of (Project_Naming_Node, Tree, Project_Naming_Decl); Naming_Package := Default_Project_Node (Of_Kind => N_Package_Declaration, In_Tree => Tree); Set_Name_Of (Naming_Package, Tree, To => Name_Naming); -- Add an attribute declaration for Source_Files as an empty list (to -- indicate there are no sources in the naming project) and a package -- Naming (that will be filled later). declare Decl_Item : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Declarative_Item, In_Tree => Tree); Attribute : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Attribute_Declaration, In_Tree => Tree, And_Expr_Kind => List); Expression : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Expression, In_Tree => Tree, And_Expr_Kind => List); Term : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Term, In_Tree => Tree, And_Expr_Kind => List); Empty_List : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Literal_String_List, In_Tree => Tree); begin Set_First_Declarative_Item_Of (Project_Naming_Decl, Tree, To => Decl_Item); Set_Next_Declarative_Item (Decl_Item, Tree, Naming_Package); Set_Current_Item_Node (Decl_Item, Tree, To => Attribute); Set_Name_Of (Attribute, Tree, To => Name_Source_Files); Set_Expression_Of (Attribute, Tree, To => Expression); Set_First_Term (Expression, Tree, To => Term); Set_Current_Term (Term, Tree, To => Empty_List); end; -- Add a with clause on the naming project in the main project, if -- there is not already one. declare With_Clause : Project_Node_Id := First_With_Clause_Of (Project_Node, Tree); begin while Present (With_Clause) loop exit when GPR.Tree.Name_Of (With_Clause, Tree) = Project_Naming_Id; With_Clause := Next_With_Clause_Of (With_Clause, Tree); end loop; if No (With_Clause) then With_Clause := Default_Project_Node (Of_Kind => N_With_Clause, In_Tree => Tree); Set_Next_With_Clause_Of (With_Clause, Tree, To => First_With_Clause_Of (Project_Node, Tree)); Set_First_With_Clause_Of (Project_Node, Tree, To => With_Clause); Set_Name_Of (With_Clause, Tree, To => Project_Naming_Id); -- We set the project node to something different than Empty_Node, -- so that GPR.PP does not generate a limited with clause. Set_Project_Node_Of (With_Clause, Tree, Non_Empty_Node); Name_Len := Project_Naming_Last; Name_Buffer (1 .. Name_Len) := Project_Naming_File_Name (1 .. Project_Naming_Last); Set_String_Value_Of (With_Clause, Tree, To => Name_Find); end if; end; Project_Declaration := Project_Declaration_Of (Project_Node, Tree); -- Add a package Naming in the main project declare begin Set_Next_Declarative_Item (Naming_Decl_Item, Tree, To => First_Declarative_Item_Of (Project_Declaration, Tree)); Set_First_Declarative_Item_Of (Project_Declaration, Tree, To => Naming_Decl_Item); Set_Current_Item_Node (Naming_Decl_Item, Tree, To => Naming); Set_Name_Of (Naming, Tree, To => Name_Naming); -- Attach the comments, if any, that were saved for package -- Naming. Tree.Project_Nodes.Table (Naming).Comments := Naming_Package_Comments; end; -- Package Naming is a renaming of package Naming in the naming project Set_Project_Of_Renamed_Package_Of (Naming, Tree, To => Project_Naming_Node); -- Add an attribute declaration for Languages, initialized as an -- empty list. declare Decl_Item : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Declarative_Item, In_Tree => Tree); Attribute : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Attribute_Declaration, In_Tree => Tree, And_Expr_Kind => List); Expression : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Expression, In_Tree => Tree, And_Expr_Kind => List); Term : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Term, In_Tree => Tree, And_Expr_Kind => List); begin Set_Next_Declarative_Item (Decl_Item, Tree, To => First_Declarative_Item_Of (Project_Declaration, Tree)); Set_First_Declarative_Item_Of (Project_Declaration, Tree, To => Decl_Item); Set_Current_Item_Node (Decl_Item, Tree, To => Attribute); Set_Name_Of (Attribute, Tree, To => Name_Languages); Set_Expression_Of (Attribute, Tree, To => Expression); Set_First_Term (Expression, Tree, To => Term); Languages_List := Default_Project_Node (Of_Kind => N_Literal_String_List, In_Tree => Tree, And_Expr_Kind => List); Set_Current_Term (Term, Tree, To => Languages_List); -- Attach the comments, if any, that were saved for attribute -- Source_Dirs. Tree.Project_Nodes.Table (Attribute).Comments := Languages_Comments; end; -- Put the languages in attribute Languages for Lang of Languages loop declare Expression : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Expression, In_Tree => Tree, And_Expr_Kind => Single); Term : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Term, In_Tree => Tree, And_Expr_Kind => Single); Value : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Literal_String, In_Tree => Tree, And_Expr_Kind => Single); begin if No (Current_Language_Node) then Set_First_Expression_In_List (Languages_List, Tree, To => Expression); else Set_Next_Expression_In_List (Current_Language_Node, Tree, To => Expression); end if; Current_Language_Node := Expression; Set_First_Term (Expression, Tree, To => Term); Set_Current_Term (Term, Tree, To => Value); Set_String_Value_Of (Value, Tree, To => Lang); end; end loop; -- Add an attribute declaration for Source_Dirs, initialized as an -- empty list. declare Decl_Item : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Declarative_Item, In_Tree => Tree); Attribute : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Attribute_Declaration, In_Tree => Tree, And_Expr_Kind => List); Expression : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Expression, In_Tree => Tree, And_Expr_Kind => List); Term : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Term, In_Tree => Tree, And_Expr_Kind => List); begin Set_Next_Declarative_Item (Decl_Item, Tree, To => First_Declarative_Item_Of (Project_Declaration, Tree)); Set_First_Declarative_Item_Of (Project_Declaration, Tree, To => Decl_Item); Set_Current_Item_Node (Decl_Item, Tree, To => Attribute); Set_Name_Of (Attribute, Tree, To => Name_Source_Dirs); Set_Expression_Of (Attribute, Tree, To => Expression); Set_First_Term (Expression, Tree, To => Term); Source_Dirs_List := Default_Project_Node (Of_Kind => N_Literal_String_List, In_Tree => Tree, And_Expr_Kind => List); Set_Current_Term (Term, Tree, To => Source_Dirs_List); -- Attach the comments, if any, that were saved for attribute -- Source_Dirs. Tree.Project_Nodes.Table (Attribute).Comments := Source_Dirs_Comments; end; -- Put the source directories in attribute Source_Dirs for Source_Dir of Source_Directories loop declare Expression : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Expression, In_Tree => Tree, And_Expr_Kind => Single); Term : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Term, In_Tree => Tree, And_Expr_Kind => Single); Value : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Literal_String, In_Tree => Tree, And_Expr_Kind => Single); begin if No (Current_Source_Dir) then Set_First_Expression_In_List (Source_Dirs_List, Tree, To => Expression); else Set_Next_Expression_In_List (Current_Source_Dir, Tree, To => Expression); end if; Current_Source_Dir := Expression; Set_First_Term (Expression, Tree, To => Term); Set_Current_Term (Term, Tree, To => Value); Set_Name_Buffer (Source_Dir); Set_String_Value_Of (Value, Tree, To => Name_Find); end; end loop; -- Add an attribute declaration for Source_Files or Source_List_File -- with the source list file name that will be created. declare Decl_Item : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Declarative_Item, In_Tree => Tree); Attribute : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Attribute_Declaration, In_Tree => Tree, And_Expr_Kind => Single); Expression : Project_Node_Id; Term : Project_Node_Id; Value : Project_Node_Id; begin Set_Next_Declarative_Item (Decl_Item, Tree, To => First_Declarative_Item_Of (Project_Declaration, Tree)); Set_First_Declarative_Item_Of (Project_Declaration, Tree, To => Decl_Item); Set_Current_Item_Node (Decl_Item, Tree, To => Attribute); Set_Name_Of (Attribute, Tree, To => Name_Source_List_File); Expression := Default_Project_Node (Of_Kind => N_Expression, In_Tree => Tree, And_Expr_Kind => Single); Set_Expression_Of (Attribute, Tree, To => Expression); Term := Default_Project_Node (Of_Kind => N_Term, In_Tree => Tree, And_Expr_Kind => Single); Value := Default_Project_Node (Of_Kind => N_Literal_String, In_Tree => Tree, And_Expr_Kind => Single); Set_First_Term (Expression, Tree, To => Term); Set_Current_Term (Term, Tree, To => Value); Name_Len := Source_List_Last; Name_Buffer (1 .. Name_Len) := Source_List_Path (1 .. Source_List_Last); Set_String_Value_Of (Value, Tree, To => Name_Find); -- If there was no comments for attribute Source_List_File, put those -- for Source_Files, if they exist. if Present (Source_List_File_Comments) then Tree.Project_Nodes.Table (Attribute).Comments := Source_List_File_Comments; else Tree.Project_Nodes.Table (Attribute).Comments := Source_Files_Comments; end if; -- Put the foreign source file names in the source list file for Source of Foreign_Sources loop Get_Name_String (Source.File_Name); Add_Char_To_Name_Buffer (ASCII.LF); if Write (Source_List_FD, Name_Buffer (1)'Address, Name_Len) /= Name_Len then GPR.Com.Fail ("disk full"); end if; end loop; -- Put the exception declarations in package Naming for Lang of Languages loop if Lang /= Name_Ada then -- Add an attribute declaration for -- Implementation_Exceptions for the language. declare Decl_Item : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Declarative_Item, In_Tree => Tree); Attribute : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Attribute_Declaration, In_Tree => Tree, And_Expr_Kind => List); Expression : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Expression, In_Tree => Tree, And_Expr_Kind => List); Term : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Term, In_Tree => Tree, And_Expr_Kind => List); Source_List : Project_Node_Id; Expr : Project_Node_Id; Prev_Expr : Project_Node_Id; Trm : Project_Node_Id; Value : Project_Node_Id; begin Set_Next_Declarative_Item (Decl_Item, To => First_Declarative_Item_Of (Naming_Package, Tree), In_Tree => Tree); Set_First_Declarative_Item_Of (Naming_Package, Tree, To => Decl_Item); Set_Current_Item_Node (Decl_Item, Tree, To => Attribute); Set_Name_Of (Attribute, Tree, To => Name_Implementation_Exceptions); Set_Associative_Array_Index_Of (Attribute, Tree, To => Lang); Set_Expression_Of (Attribute, Tree, To => Expression); Set_First_Term (Expression, Tree, To => Term); Source_List := Default_Project_Node (Of_Kind => N_Literal_String_List, In_Tree => Tree, And_Expr_Kind => List); Set_Current_Term (Term, Tree, To => Source_List); Prev_Expr := Empty_Project_Node; -- Put all the sources for this language in the list for Source of Foreign_Sources loop if Source.Language = Lang then Expr := Default_Project_Node (Of_Kind => N_Expression, In_Tree => Tree, And_Expr_Kind => Single); if No (Prev_Expr) then Set_First_Expression_In_List (Node => Source_List, In_Tree => Tree, To => Expr); else Set_Next_Expression_In_List (Node => Prev_Expr, In_Tree => Tree, To => Expr); end if; Prev_Expr := Expr; Trm := Default_Project_Node (Of_Kind => N_Term, In_Tree => Tree, And_Expr_Kind => Single); Set_First_Term (Expr, Tree, To => Trm); Value := Default_Project_Node (Of_Kind => N_Literal_String, And_Expr_Kind => Single, In_Tree => Tree); Set_String_Value_Of (Node => Value, In_Tree => Tree, To => Source.File_Name); Set_Current_Term (Trm, Tree, To => Value); end if; end loop; end; end if; end loop; -- Set the Source_Files entries so that, for every Ada source, we -- have an easy access to the index of its first occurrence in -- Sources. for Source_Index in 1 .. Sources.Last_Index loop declare Current_Source : constant Source := Sources (Source_Index); begin if not First_Index.Contains ((Current_Source.File_Name, Current_Source.Index)) then First_Index.Insert ((Current_Source.File_Name, Current_Source.Index), Source_Index); end if; end; end loop; -- Put the sources in the source list files (or attribute -- Source_Files) and in the naming project (or the Naming package). -- Use reverse order to make up for the AST construction method that -- assembles things in reverse. for Source_Index in reverse 1 .. Sources.Last_Index loop -- Add the corresponding attribute in the Naming package declare Current_Source : constant Source := Sources (Source_Index); Decl_Item : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Declarative_Item, In_Tree => Tree); Attribute : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Attribute_Declaration, In_Tree => Tree); Expression : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Expression, And_Expr_Kind => Single, In_Tree => Tree); Term : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Term, And_Expr_Kind => Single, In_Tree => Tree); Value : constant Project_Node_Id := Default_Project_Node (Of_Kind => N_Literal_String, And_Expr_Kind => Single, In_Tree => Tree); Process_File : Boolean := True; Index : Natural; begin if Opt.Ignore_Predefined_Units and then Current_Source.Unit_Name /= No_Name then Get_Name_String (Current_Source.Unit_Name); if Is_Ada_Predefined_Unit (Name_Buffer (1 .. Name_Len)) then Process_File := False; end if; end if; if Process_File then -- Add source file name to the source list file (or the -- attribute Source_Files) if it is not already there. -- If already there, check for duplicate filenames+source -- index and emit warnings accordingly. Index := First_Index.Element ((Current_Source.File_Name, Current_Source.Index)); if Index /= Source_Index then -- Means we have several elements in Sources with the -- same (File_Name, Index). if Opt.Ignore_Duplicate_Files then Process_File := False; elsif Sources (Index).Unit_Name = Current_Source.Unit_Name then Put_Line ("warning: duplicate file " & Get_Name_String (Current_Source.File_Name) & " for unit " & Get_Name_String (Current_Source.Unit_Name) & " will be ignored"); Process_File := False; else Put_Line ("warning: duplicate file " & Get_Name_String (Current_Source.File_Name) & " for units " & Get_Name_String (Current_Source.Unit_Name) & " and " & Get_Name_String (Sources (Index).Unit_Name)); Put_Line ("warning: generated Naming package needs " & "to be reviewed manually"); end if; else Source_Files.Set (Current_Source.File_Name, True); end if; -- Do not write it to the source list file yet, as it -- would result in a weird reverse ordering. end if; if Process_File then -- For an Ada source, add entry in package Naming if Current_Source.Unit_Name /= No_Name then Set_Next_Declarative_Item (Decl_Item, To => First_Declarative_Item_Of (Naming_Package, Tree), In_Tree => Tree); Set_First_Declarative_Item_Of (Naming_Package, To => Decl_Item, In_Tree => Tree); Set_Current_Item_Node (Decl_Item, To => Attribute, In_Tree => Tree); -- Is it a spec or a body? if Current_Source.Spec then Set_Name_Of (Attribute, Tree, To => Name_Spec); else Set_Name_Of (Attribute, Tree, To => Name_Body); end if; -- Get the name of the unit Set_Associative_Array_Index_Of (Attribute, Tree, To => Get_Lower_Name_Id (Get_Name_String (Current_Source.Unit_Name))); Set_Expression_Of (Attribute, Tree, To => Expression); Set_First_Term (Expression, Tree, To => Term); Set_Current_Term (Term, Tree, To => Value); -- And set the name of the file Set_String_Value_Of (Value, Tree, To => Current_Source.File_Name); Set_Source_Index_Of (Value, Tree, To => Current_Source.Index); end if; end if; end; end loop; -- Now add source file names to the source list file, in direct order -- this time. Reuse Source_Files to avoid duplicates. for Current_Source of Sources loop if Source_Files.Get (Current_Source.File_Name) then Get_Name_String (Current_Source.File_Name); Add_Char_To_Name_Buffer (ASCII.LF); if Write (Source_List_FD, Name_Buffer (1)'Address, Name_Len) /= Name_Len then GPR.Com.Fail ("disk full"); end if; Source_Files.Set (Current_Source.File_Name, False); end if; end loop; end; -- Close the source list file Close (Source_List_FD); -- Output the project file GPR.PP.Pretty_Print (Project_Node, Tree, W_Char => Write_A_Char'Access, W_Eol => Write_Eol'Access, W_Str => Write_A_String'Access, Backward_Compatibility => False, Max_Line_Length => 79); Close (Output_FD); -- Delete the naming project file if it already exists Delete_File (Project_Naming_File_Name (1 .. Project_Naming_Last), Success => Discard); -- Create a new one if Opt.Verbose_Mode then Put ("Creating new naming project file """); Put (Project_Naming_File_Name (1 .. Project_Naming_Last)); Put_Line (""""); end if; Output_FD := Create_New_File (Project_Naming_File_Name (1 .. Project_Naming_Last), Fmode => Text); -- Fails if naming project file cannot be created if Output_FD = Invalid_FD then GPR.Com.Fail ("cannot create new """ & Project_Naming_File_Name (1 .. Project_Naming_Last) & """"); end if; -- Output the naming project file GPR.PP.Pretty_Print (Project_Naming_Node, Tree, W_Char => Write_A_Char'Access, W_Eol => Write_Eol'Access, W_Str => Write_A_String'Access, Backward_Compatibility => False); Close (Output_FD); -- The args are now unused: let's free the list Free (Args); end Finalize; ---------------- -- Initialize -- ---------------- procedure Initialize (File_Path : String; Preproc_Switches : String_Vectors.Vector; Very_Verbose : Boolean; Flags : Processing_Flags) is begin GPRName.Very_Verbose := Initialize.Very_Verbose; -- Do some needed initializations Snames.Initialize; Set_Program_Name ("gprname"); GPR.Initialize (No_Project_Tree); GPR.Tree.Initialize (Root_Environment, Flags); GPR.Env.Initialize_Default_Project_Path (Root_Environment.Project_Path, Target_Name => Sdefault.Hostname); GPR.Tree.Initialize (Tree); Source_Count.Clear; First_Index.Clear; Sources.Clear; Source_Directories.Clear; Foreign_Sources.Clear; Languages.Clear; -- Initialize the compiler switches Args := new Argument_List (1 .. Natural (Preproc_Switches.Length) + 6); Args (1) := new String'("-c"); Args (2) := new String'("-gnats"); Args (3) := new String'("-gnatu"); for J in 1 .. Preproc_Switches.Last_Index loop Args (3 + J) := new String'(Preproc_Switches (J)); end loop; Args (4 + Preproc_Switches.Last_Index) := new String'("-x"); Args (5 + Preproc_Switches.Last_Index) := new String'("ada"); -- Get the path and file names Path_Name := new String'(File_Path); -- Get the end of directory information, if any for Index in reverse Path_Name'Range loop if Path_Name (Index) = Directory_Separator then Directory_Last := Index; exit; end if; end loop; Output_Name := new String'(Path_Name.all); Output_Name_Last := Output_Name'Last - 4; pragma Assert (Is_Regular_File (Output_Name.all)); GPR.Attr.PM.Remove_Unknown_Packages; Part.Parse (In_Tree => Tree, Project => Project_Node, Project_File_Name => Output_Name.all, Errout_Handling => Part.Finalize_If_Error, Store_Comments => True, Is_Config_File => False, Env => Root_Environment, Current_Directory => Get_Current_Dir, Packages_To_Check => Packages_To_Check_By_Gprname); -- Fail if parsing was not successful if No (Project_Node) then GPR.Com.Fail ("parsing of existing project file failed"); elsif Project_Qualifier_Of (Project_Node, Tree) = Aggregate then GPR.Com.Fail ("aggregate projects are not supported"); elsif Project_Qualifier_Of (Project_Node, Tree) = Aggregate_Library then GPR.Com.Fail ("aggregate library projects are not supported"); else -- If parsing was successful, remove the components that are -- automatically generated, if any, so that they will be -- unconditionally added later. -- Remove the with clause for the naming project file declare With_Clause : Project_Node_Id := First_With_Clause_Of (Project_Node, Tree); Previous : Project_Node_Id := Empty_Project_Node; begin while Present (With_Clause) loop if GPR.Tree.Name_Of (With_Clause, Tree) = Project_Naming_Id then if No (Previous) then Set_First_With_Clause_Of (Project_Node, Tree, To => Next_With_Clause_Of (With_Clause, Tree)); else Set_Next_With_Clause_Of (Previous, Tree, To => Next_With_Clause_Of (With_Clause, Tree)); end if; exit; end if; Previous := With_Clause; With_Clause := Next_With_Clause_Of (With_Clause, Tree); end loop; end; -- Remove attribute declarations of Source_Files, -- Source_List_File, Source_Dirs, Languages and the declaration of -- package Naming, if they exist, but preserve the comments -- attached to these nodes. declare Declaration : Project_Node_Id := First_Declarative_Item_Of (Project_Declaration_Of (Project_Node, Tree), Tree); Previous : Project_Node_Id := Empty_Project_Node; Current_Node : Project_Node_Id := Empty_Project_Node; Name : Name_Id; Kind_Of_Node : Project_Node_Kind; Comments : Project_Node_Id; begin while Present (Declaration) loop Current_Node := Current_Item_Node (Declaration, Tree); Kind_Of_Node := Kind_Of (Current_Node, Tree); if Kind_Of_Node = N_Attribute_Declaration or else Kind_Of_Node = N_Package_Declaration then Name := GPR.Tree.Name_Of (Current_Node, Tree); if Name in Name_Source_Files | Name_Source_List_File | Name_Source_Dirs | Name_Languages | Name_Naming then Comments := Tree.Project_Nodes.Table (Current_Node).Comments; if Name = Name_Source_Files then Source_Files_Comments := Comments; elsif Name = Name_Source_List_File then Source_List_File_Comments := Comments; elsif Name = Name_Source_Dirs then Source_Dirs_Comments := Comments; elsif Name = Name_Languages then Languages_Comments := Comments; elsif Name = Name_Naming then Naming_Package_Comments := Comments; end if; if No (Previous) then Set_First_Declarative_Item_Of (Project_Declaration_Of (Project_Node, Tree), Tree, To => Next_Declarative_Item (Declaration, Tree)); else Set_Next_Declarative_Item (Previous, Tree, To => Next_Declarative_Item (Declaration, Tree)); end if; else Previous := Declaration; end if; end if; Declaration := Next_Declarative_Item (Declaration, Tree); end loop; end; end if; if Directory_Last /= 0 then Output_Name (1 .. Output_Name_Last - Directory_Last) := Output_Name (Directory_Last + 1 .. Output_Name_Last); Output_Name_Last := Output_Name_Last - Directory_Last; end if; -- Get the project name id Output_Name_Id := Get_Name_Id (Output_Name (1 .. Output_Name_Last)); -- Create the project naming file name Project_Naming_Last := Output_Name_Last; Project_Naming_File_Name := new String' (Output_Name (1 .. Output_Name_Last) & Naming_File_Suffix & Project_File_Extension); Project_Naming_Last := Project_Naming_Last + Naming_File_Suffix'Length; -- Get the project naming id Project_Naming_Id := Get_Name_Id (Project_Naming_File_Name (1 .. Project_Naming_Last)); Project_Naming_Last := Project_Naming_Last + Project_File_Extension'Length; -- Create the source list file name Source_List_Last := Output_Name_Last; Source_List_Path := new String' (Output_Name (1 .. Output_Name_Last) & Source_List_File_Suffix); Source_List_Last := Output_Name_Last + Source_List_File_Suffix'Length; -- Add the project file extension to the project name Output_Name (Output_Name_Last + 1 .. Output_Name_Last + Project_File_Extension'Length) := Project_File_Extension; Output_Name_Last := Output_Name_Last + Project_File_Extension'Length; -- Back up project file if it already exists if not Opt.No_Backup and then Is_Regular_File (Path_Name.all) then declare Discard : Boolean; Saved_Path : constant String := Path_Name.all & ".saved_"; Nmb : Natural; begin Nmb := 0; loop declare Img : constant String := Nmb'Img; FN : constant String := Saved_Path & Img (2 .. Img'Last); begin if not Is_Regular_File (FN) then Copy_File (Name => Path_Name.all, Pathname => FN, Mode => Overwrite, Success => Discard); exit; end if; Nmb := Nmb + 1; end; end loop; end; end if; -- Change the current directory to the directory of the project file, -- if any directory information is specified. if Directory_Last /= 0 then begin Change_Dir (Path_Name (1 .. Directory_Last)); exception when Directory_Error => GPR.Com.Fail ("unknown directory """ & Path_Name (1 .. Directory_Last) & '"'); end; end if; end Initialize; ------------- -- Process -- ------------- procedure Process (Directories : String_Vectors.Vector; Name_Patterns : Regexp_List; Excluded_Patterns : Regexp_List; Foreign_Patterns : Foreign_Regexp_List) is procedure Process_Directory (Dir_Name : String; Recursively : Boolean); -- Look for Ada and foreign sources in a directory, according to the -- patterns. When Recursively is True, after looking for sources in -- Dir_Name, look also in its subdirectories, if any. ----------------------- -- Process_Directory -- ----------------------- procedure Process_Directory (Dir_Name : String; Recursively : Boolean) is Matched : Matched_Type := No_Match; Str : String (1 .. 2_000); Canon : String (1 .. 2_000); Last : Natural; Dir : Dir_Type; Do_Process : Boolean := True; Temp_File_Name : String_Access := null; Save_Last_Source_Index : Natural := 0; File_Name_Id : Name_Id := No_Name; Current_Source : Source; Current_Language : Name_Id; begin -- Avoid processing the same directory more than once Do_Process := not Processed_Directories.Contains (Dir_Name); if Do_Process then if Opt.Verbose_Mode then Put ("Processing directory """); Put (Dir_Name); Put_Line (""""); end if; Processed_Directories.Append (Dir_Name); -- Get the source file names from the directory. Fails if the -- directory does not exist. begin Open (Dir, Dir_Name); exception when Directory_Error => GPR.Com.Fail ("cannot open directory """ & Dir_Name & """"); end; -- Process each regular file in the directory File_Loop : loop Read (Dir, Str, Last); exit File_Loop when Last = 0; -- Copy the file name and put it in canonical case to match -- against the patterns that have themselves already been put -- in canonical case. Canon (1 .. Last) := Str (1 .. Last); Canonical_Case_File_Name (Canon (1 .. Last)); if Is_Regular_File (Dir_Name & Directory_Separator & Str (1 .. Last)) then Matched := Match; Name_Len := Last; Name_Buffer (1 .. Name_Len) := Str (1 .. Last); File_Name_Id := Name_Find; -- First, check if the file name matches at least one of -- the excluded expressions; for Ptrn of Excluded_Patterns loop if Match (Canon (1 .. Last), Ptrn) then Matched := Excluded; exit; end if; end loop; -- If it does not match any of the excluded expressions, -- check if the file name matches at least one of the -- regular expressions. if Matched = Match then Matched := No_Match; for Ptrn of Name_Patterns loop if Match (Canon (1 .. Last), Ptrn) then Matched := Match; exit; end if; end loop; end if; if Very_Verbose or else (Matched = Match and then Opt.Verbose_Mode) then Put (" Checking """); Put (Str (1 .. Last)); Put_Line (""": "); end if; -- If the file name matches one of the regular expressions, -- parse it to get its unit name. if Matched = Match then declare FD : File_Descriptor; Success : Boolean; Saved_Output : File_Descriptor; Saved_Error : File_Descriptor; Tmp_File : Path_Name_Type; begin -- If we don't have the path of the compiler yet, -- get it now. The compiler name may have a prefix, -- so we get the potentially prefixed name. if Gcc_Path = null then Gcc_Path := Locate_Exec_On_Path (Gcc); if Gcc_Path = null then GPR.Com.Fail ("could not locate " & Gcc); end if; end if; -- Create the temporary file Tempdir.Create_Temp_File (FD, Tmp_File); if FD = Invalid_FD then GPR.Com.Fail ("could not create temporary file"); else Temp_File_Name := new String'(Get_Name_String (Tmp_File)); end if; Args (Args'Last) := new String' (Dir_Name & Directory_Separator & Str (1 .. Last)); -- Save the standard output and error Saved_Output := Dup (Standout); Saved_Error := Dup (Standerr); -- Set standard output and error to the temporary file Dup2 (FD, Standout); Dup2 (FD, Standerr); -- And spawn the compiler if Very_Verbose then Put (Gcc_Path.all); for J in Args'Range loop if Args (J)'Length > 0 then Put (" " & Args (J).all); end if; end loop; New_Line; end if; Spawn (Gcc_Path.all, Args.all, Success); Free (Args (Args'Last)); -- Restore the standard output and error Dup2 (Saved_Output, Standout); Dup2 (Saved_Error, Standerr); -- Close the temporary file Close (FD); -- And close the saved standard output and error to -- avoid too many file descriptors. Close (Saved_Output); Close (Saved_Error); -- Now that standard output is restored, check if -- the compiler ran correctly. -- Read the lines of the temporary file: -- they should contain the kind and name of the unit. declare File : Text_File; Text_Line : String (1 .. 1_000); Text_Last : Natural; begin Open (File, Temp_File_Name.all); if not Is_Valid (File) then GPR.Com.Fail ("could not read temporary file " & Temp_File_Name.all); end if; Save_Last_Source_Index := Sources.Last_Index; if End_Of_File (File) then if Opt.Verbose_Mode then if not Success then Put (" (process died) "); end if; end if; else Line_Loop : while not End_Of_File (File) loop Get_Line (File, Text_Line, Text_Last); if Very_Verbose then Put_Line (Text_Line (1 .. Text_Last)); end if; -- Find the first closing parenthesis Char_Loop : for J in 1 .. Text_Last loop if Text_Line (J) = ')' then if J >= 13 and then Text_Line (1 .. 4) = "Unit" then -- Add entry to Sources table Name_Len := J - 12; Name_Buffer (1 .. Name_Len) := Text_Line (6 .. J - 7); Current_Source := (Unit_Name => Name_Find, Position => Get_Source_Position (File_Name_Id), File_Name => File_Name_Id, Index => 0, Spec => Text_Line (J - 5 .. J) = "(spec)"); Sources.Append (Current_Source); end if; exit Char_Loop; end if; end loop Char_Loop; end loop Line_Loop; end if; if Save_Last_Source_Index = Sources.Last_Index then if Opt.Verbose_Mode then Put_Line (" not a unit"); end if; else Add_Language (Name_Ada); if Sources.Last_Index > Save_Last_Source_Index + 1 then for Index in Save_Last_Source_Index + 1 .. Sources.Last_Index loop declare Value : Source := Sources.Element (Index); begin Value.Index := Int (Index - Save_Last_Source_Index); Sources.Replace_Element (Index, Value); end; end loop; end if; for Index in Save_Last_Source_Index + 1 .. Sources.Last_Index loop Current_Source := Sources (Index); if Opt.Verbose_Mode then if Current_Source.Spec then Put (" spec of "); else Put (" body of "); end if; Put_Line (Get_Name_String (Current_Source.Unit_Name)); end if; end loop; end if; Close (File); Delete_File (Temp_File_Name.all, Success); end; end; -- File name matches none of the regular expressions else -- If file is not excluded, see if this is foreign source if Matched /= Excluded then for Ptrn of Foreign_Patterns loop if Match (Canon (1 .. Last), Ptrn.Pattern) then Matched := Match; Current_Language := Ptrn.Language; Add_Language (Current_Language); exit; end if; end loop; end if; if Very_Verbose then case Matched is when No_Match => Put_Line ("no match"); when Excluded => Put_Line ("excluded"); when Match => Put_Line ("foreign source"); end case; end if; if Matched = Match then -- Add foreign source file name Set_Name_Buffer (Canon (1 .. Last)); Foreign_Sources.Append ((File_Name => Name_Find, Position => Get_Source_Position (File_Name_Id), Language => Current_Language), 1); end if; end if; end if; end loop File_Loop; Close (Dir); end if; -- If Recursively is True, call itself for each subdirectory. -- We do that, even when this directory has already been processed, -- because all of its subdirectories may not have been processed. if Recursively then Open (Dir, Dir_Name); loop Read (Dir, Str, Last); exit when Last = 0; -- Do not call itself for "." or ".." if Is_Directory (Dir_Name & Directory_Separator & Str (1 .. Last)) and then Str (1 .. Last) /= "." and then Str (1 .. Last) /= ".." then Process_Directory (Dir_Name & Directory_Separator & Str (1 .. Last), Recursively => True); end if; end loop; Close (Dir); end if; end Process_Directory; -- Start of processing for Process begin Processed_Directories.Clear; -- Process each directory for Dir_Name of Directories loop declare Last : Natural := Dir_Name'Last; Recursively : Boolean := False; Canonical : String (1 .. Dir_Name'Length) := Dir_Name; begin Canonical_Case_File_Name (Canonical); if not Source_Directories.Contains (Canonical) then Source_Directories.Append (Canonical); end if; if Dir_Name'Length >= 4 and then Dir_Name (Last - 1 .. Last) = "**" and then Is_Directory_Separator (Dir_Name (Last - 2)) then Last := Last - 3; Recursively := True; end if; Process_Directory (Dir_Name (Dir_Name'First .. Last), Recursively); end; end loop; end Process; end GPRName; gprbuild-25.0.0/src/gprname.ads000066400000000000000000000104641470075373400163360ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR PROJECT MANAGER -- -- -- -- Copyright (C) 2001-2023, AdaCore -- -- -- -- 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 Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING3. If not, go to -- -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Ada.Containers.Vectors; with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.Regexp; use GNAT.Regexp; with GPR; use GPR; with GPR.Util; use GPR.Util; package GPRName is Project_Tree : constant Project_Tree_Ref := new Project_Tree_Data (Is_Root_Tree => True); -- The project tree procedure Initialize (File_Path : String; Preproc_Switches : String_Vectors.Vector; Very_Verbose : Boolean; Flags : Processing_Flags); -- Start the creation or modification of a project file, for gprname. -- -- File_Path is the name of a project file to create if it does not exist -- or to modify if it already exists. -- -- Preproc_Switches is a list of switches to be used when invoking the -- compiler to get the name and kind of unit of a source file. -- -- Very_Verbose controls the verbosity of the output, in conjunction with -- GPR.Opt.Verbose_Mode. package Regexp_Vectors is new Ada.Containers.Vectors (Positive, Regexp); subtype Regexp_List is Regexp_Vectors.Vector; type Foreign_Regexp is record Language : Name_Id; Pattern : Regexp; end record; package Frgn_Regexp_Vectors is new Ada.Containers.Vectors (Positive, Foreign_Regexp); subtype Foreign_Regexp_List is Frgn_Regexp_Vectors.Vector; procedure Process (Directories : String_Vectors.Vector; Name_Patterns : Regexp_List; Excluded_Patterns : Regexp_List; Foreign_Patterns : Foreign_Regexp_List); -- Look for source files in the specified directories, with the specified -- patterns. -- -- Directories is the list of source directories where to look for sources -- -- Name_Patterns is a potentially empty list of file name patterns to check -- for Ada Sources. -- -- Excluded_Patterns is a potentially empty list of file name patterns that -- should not be checked for Ada or non Ada sources. -- -- Foreign_Patterns is a potentially empty list of file name patterns to -- check for non Ada sources. -- -- At least one of Name_Patterns and Foreign_Patterns is not empty -- -- Note that this procedure currently assumes that it is only used -- by gnatname. If other processes start using it, then an additional -- parameter would need to be added, and call to Osint.Program_Name -- updated accordingly in the body. procedure Finalize; -- Write the project file indicated in a call to procedure Initialize, -- after one or several calls to procedure Process. private RTS_Specified : String_Access := null; -- Used to detect multiple use of --RTS= switch Gcc : constant String := "gcc"; Gcc_Path : String_Access := null; -- Path of the Ada compiler end GPRName; gprbuild-25.0.0/src/gprslave.adb000066400000000000000000002500711470075373400165070ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2012-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ with Ada.Calendar.Formatting; with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Containers.Indefinite_Hashed_Maps; with Ada.Containers.Indefinite_Vectors; with Ada.Containers.Ordered_Sets; with Ada.Containers.Vectors; with Ada.Directories; use Ada.Directories; with Ada.Exceptions; use Ada.Exceptions; with Ada.Finalization; use Ada.Finalization; with Ada.Strings.Equal_Case_Insensitive; with Ada.Strings.Fixed; use Ada.Strings; with Ada.Strings.Hash_Case_Insensitive; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with Ada.Text_IO; use Ada.Text_IO; with Ada.Unchecked_Deallocation; with System.Multiprocessors; use System; with GNAT.Command_Line; use GNAT; with GNAT.CRC32; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.Exception_Traces; with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.Sockets; use GNAT.Sockets; with GNAT.String_Split; use GNAT.String_Split; with GNAT.Strings; with GNAT.Traceback.Symbolic; use GNAT.Traceback; use GNAT.Traceback.Symbolic; with GPR.Compilation; use GPR.Compilation; with GPR.Compilation.Protocol; use GPR.Compilation.Protocol; with GPR.Compilation.Sync; use GPR.Compilation.Sync; with GPR.Util; use GPR.Util; with GPR.Version; with GPR; use GPR; with GPR.Env; with GPR.Knowledge; use GPR.Knowledge; with GPR.Names; use GPR.Names; with GPR.Opt; use GPR.Opt; with GPR.Part; use GPR.Part; with GPR.Proc; with GPR.Snames; use GPR.Snames; with GPR.Tree; use GPR.Tree; procedure Gprslave is use Ada; type UID is mod 9999; -- The Status is shared by the same build master object. It first has a -- reference counter to free the memory associated with this status and -- a boolean used a a mutex to lock/unlock the object to allow proper -- concurrent access. type Data is record Channel : Communication_Channel; -- Communication with build master Project_Name : Unbounded_String; Target : Unbounded_String; Build_Env : Unbounded_String; Included_Artifact_Patterns : String_Split.Slice_Set; Id : UID; Locked : Boolean := False; Count : Natural := 0; end record; type Shared_Data is access Data; -- Data for a build master type Build_Master is new Finalization.Controlled with record Sync : Boolean; D : Shared_Data; end record; overriding procedure Initialize (Builder : in out Build_Master); overriding procedure Adjust (Builder : in out Build_Master); overriding procedure Finalize (Builder : in out Build_Master); -- Controlled_Build_Master is to ensure that the Build_Master controlled -- object can be used concurrently. protected Controlled_Build_Master is procedure Initialize (Builder : in out Build_Master); procedure Adjust (Builder : in out Build_Master); procedure Finalize (Builder : in out Build_Master); end Controlled_Build_Master; function Sock (Builder : Build_Master'Class) return Socket_Type is (Protocol.Sock (Builder.D.Channel)); package Builder is function "<" (B1, B2 : Build_Master) return Boolean is (To_C (Sock (B1)) < To_C (Sock (B2))); function "=" (B1, B2 : Build_Master) return Boolean is (Sock (B1) = Sock (B2)); package Set is new Containers.Ordered_Sets (Build_Master); end Builder; package Builder_Set renames Builder.Set; -- Representation of a job data type Stages is (J_None, J_Created, J_Waiting, J_Running, J_Terminated, J_Killed); type Job_Data is record Cmd : Command; Id : Remote_Id := -1; -- job id must be uniq across all slaves Pid : Process_Id := OS_Lib.Invalid_Pid; -- the OS process id Dep_Dir : Unbounded_String; Dep_File : Unbounded_String; Obj_File : Unbounded_String; Output : Unbounded_String; Build_Sock : Socket_Type; -- key used to get the corresponding builder Stage : Stages := J_None; end record with Dynamic_Predicate => (case Job_Data.Stage is when J_None => Job_Data.Id = -1, when J_Created | J_Waiting => Job_Data.Pid = OS_Lib.Invalid_Pid and then Kind (Job_Data.Cmd) in EX | CU and then Job_Data.Build_Sock /= No_Socket, when J_Running | J_Terminated | J_Killed => Job_Data.Pid /= OS_Lib.Invalid_Pid and then Kind (Job_Data.Cmd) in EX | CU and then Job_Data.Build_Sock /= No_Socket); function "<" (J1, J2 : Job_Data) return Boolean is (Pid_To_Integer (J1.Pid) < Pid_To_Integer (J2.Pid)); function "=" (J1, J2 : Job_Data) return Boolean is (Pid_To_Integer (J1.Pid) = Pid_To_Integer (J2.Pid)); No_Job : constant Job_Data := (Id => -1, Pid => OS_Lib.Invalid_Pid, Stage => J_None, others => <>); package Job_Data_Set is new Containers.Ordered_Sets (Job_Data); package To_Run_Set is new Containers.Vectors (Positive, Job_Data); function Get_Arg (Builder : Build_Master; Value : String) return String with Inline; -- Returns Value with possible translation of the local repositories function Get_Args (Builder : Build_Master; Slices : Slice_Set) return Argument_List; -- Returns an Argument_List corresponding to the Slice_Set function Image (Value : Long_Integer) return String; -- Return Value string representation without the leading space function Work_Directory (Builder : Build_Master) return String; -- Directory where compilation are to be done, this is the directory named -- after the project under the Root_Directory. procedure Parse_Command_Line; -- Parse the command line options, set variables below accordingly function Get_Slave_Id return Remote_Id; function Is_Active_Build_Master (Builder : Build_Master) return Boolean is (Builder.D /= null and then Builder.D.Project_Name /= Null_Unbounded_String); procedure Close_Builder (Builder : in out Build_Master; Ack : Boolean); -- Close the channel and socket and remove the builder from the slave. This -- procedure never fails. Send a OK message if Ack is True. procedure Display (Builder : Build_Master; Str : String; Is_Debug : Boolean := False; Force : Boolean := False) with Inline; procedure Display (Str : String; Is_Debug : Boolean := False; Force : Boolean := False) with Inline; -- Display messages if needed (depending on the current mode) procedure Activate_Symbolic_Traceback; -- Activate symbolic trace-back -- -- Belows are the main objects which handle the concurrent requests -- procedure Wait_For_Master; -- Wait for a build master to connect, initialize the global communication -- channel. This procedure is run under the environment task. Send the -- slave config to the build master. Either a builder object is created and -- inserted into the Builders protected object or the builder is rejected -- because of inconsistent state: -- -- 1. the builder and the slave are not using the same compiler. -- 2. the slave is already handling compilation for this project -- environment. task Wait_Requests; -- Waiting for incoming requests from the masters, take corresponding -- actions. Three actions are handled here: -- -- 1. EX - execute a compilation -- A compilation request is inserted into To_Run protected object. -- -- 2. CU - execute a clean-up -- A clean-up request is inserted into To_Run protected object. -- -- 3. EC - stop execution for the given builder task Execute_Job; -- Task running a maximum of Max_Process compilation simultaneously. These -- jobs are taken from the To_Run protected object (a FIFO list). -- -- Jobs taken from To_Run protected object are removed, executed -- asynchronously and inserted into the Running protected object with -- the corresponding process Id and builder. -- -- IMPORTANT NOTE : this is the only task that can change the working -- directory (Set_Directory for example). This makes locking circuitry -- lighter and more efficient. task type Wait_Completion; -- Waiting for completion of compilation jobs. The Pid is retreived with -- the corresponding builder, then it sends back the response to the build -- masters. The response is OK or NOK depending on compilation result. If -- OK the auxiliaries files (.ali, .o) are sent back to the build master. -- -- This is the only task with multiple instance. As sending back resulting -- objects and ALI files can take some time haaving multiple instance -- permit to send results to different builders simultaneously. protected Builders is -- Protected builders data set (used by environment task and the -- Protocol_Handler). -- -- The list of builder, one for each build master. Inserted here when a -- compilation starts and removed when an end-of-compilation message is -- received or a master is interrupted. procedure Insert (Builder : Build_Master); -- Add Builder into the set procedure Remove (Builder : in out Build_Master); -- Remove Builder from the set function Get (Socket : Socket_Type) return Build_Master; -- Get the builder using Socket function Exists (Socket : Socket_Type) return Boolean; -- Returns True if the build master corresponding to socket is found. -- False otherwise. entry Get_Socket_Set (Socket_Set : out Socket_Set_Type); -- Get a socket set for all builders procedure Initialize (Builder : in out Build_Master); -- Set the UID for this build master. This Id is only used in log -- message to identify a specific build. function Working_Dir_Exists (Directory : String) return Boolean; -- Returns True if Directory is already used by a registered build -- master. This is to ensure that a unique build will happen in a -- given directory. entry Lock (Builder : in out Build_Master); -- Lock builder against concurrent use, must be released procedure Release (Builder : in out Build_Master); -- Release builder locked with entry above private entry Try_Lock (Builder : in out Build_Master); -- The lock is already taken, the tasks are queued here to wait for the -- builder to be released. Current_Id : UID := 0; Builders : Builder_Set.Set; To_Check : Natural := 0; -- number of task to let go through Try_Lock end Builders; protected To_Run is -- Queue of Job to run, A FIFO list of jobs comming from all registered -- builders. procedure Push (Job : Job_Data) with Pre => Job.Stage = J_Created; entry Pop (Job : out Job_Data) with Post => Job.Stage = J_Waiting; private Set : To_Run_Set.Vector; end To_Run; protected Running is -- Set of running jobs. Removed when the compilation terminates or when -- killed because of a builder is interrupted. procedure Start (Job : in out Job_Data; Driver : String; Options : Argument_List; Out_File : String; Obj_File : String; Dep_File : String; Dep_Dir : String; Pid : out Process_Id) with Pre => Job.Stage = J_Waiting, Post => Job.Stage = J_Running; -- Start and register a new running job procedure Get (Job : out Job_Data; Pid : Process_Id) with Post => Job = No_Job or else Job.Stage = J_Terminated; -- Get Job having the given Pid procedure Set_Max (Max : Positive); -- Set the maximum running processes simultaneously entry Wait_Slot; -- Wait for a running slot to be available entry Wait; -- Wait for at least one running process procedure Kill_Processes (Socket : Socket_Type); -- Kill all processes whose builder is registered with Socket. This -- is used when a builder is interrupted to kill all corresponding -- processes. function Count return Natural; -- Number of job running private Set : Job_Data_Set.Set; Dead : Job_Data_Set.Set; -- job which failed to start N_Count : Natural := 0; -- actual number of running process Max : Natural := 0; end Running; -- Ensure that all IO are serialized, especially the spawn of process which -- must never happen during other IO. This is needed as the spawned process -- will inherit the standard IO descriptors. protected IO is procedure Message (Builder : Build_Master; Str : String; Is_Debug : Boolean := False); procedure Message (Str : String; Is_Debug : Boolean := False); -- Display a message (in verbose mode) and adds a leading timestamp. -- Also display the message in debug mode if Is_Debug is set. procedure Spawn (Driver : String; Options : Argument_List; Out_File : String; Pid : out Process_Id); end IO; Compiler_Path : constant OS_Lib.String_Access := Locate_Exec_On_Path ("gprls"); Slave_Id : Remote_Id; -- Host Id used to compose a unique job id across all running slaves -- Command line parameters statuses Port : aliased Integer; Max_Processes : aliased Integer; Max_Responses : aliased Integer; Help : aliased Boolean := False; Verbose : aliased Boolean := False; Debug : aliased Boolean := False; Root_Directory : aliased GNAT.Strings.String_Access := new String'(Get_Current_Dir); -- Root directoty for the gprslave environment. All projects sources and -- compilations are done under this directory. Hash : aliased GNAT.Strings.String_Access; -- Running instances statuses Address : Sock_Addr_Type; Server : Socket_Type; Index : Long_Integer := 0; -- Knowledge base Base : Knowledge_Base; Selected_Targets_Set : Targets_Set_Id; -- Handle response type Response_Handler_Set is array (Positive range <>) of Wait_Completion; type Response_Handler_Set_Access is access Response_Handler_Set; Response_Handlers : Response_Handler_Set_Access with Unreferenced; -- Sending response to a build master may take some time as the object file -- is sent back over the socket with the corresponding dependency file. ------------ -- Adjust -- ------------ overriding procedure Adjust (Builder : in out Build_Master) is begin Controlled_Build_Master.Adjust (Builder); end Adjust; --------------------------------- -- Activate_Symbolic_Traceback -- --------------------------------- procedure Activate_Symbolic_Traceback is begin Exception_Traces.Trace_On (Exception_Traces.Unhandled_Raise); Exception_Traces.Set_Trace_Decorator (Traceback.Symbolic.Symbolic_Traceback'Access); end Activate_Symbolic_Traceback; -------------- -- Builders -- -------------- protected body Builders is ------------ -- Exists -- ------------ function Exists (Socket : Socket_Type) return Boolean is Builder : Build_Master; begin Builder.D.Channel := Protocol.Create (Socket, Virtual => True); return Builder_Set.Has_Element (Builders.Find (Builder)); end Exists; --------- -- Get -- --------- function Get (Socket : Socket_Type) return Build_Master is Builder : Build_Master; Pos : Builder_Set.Cursor; begin Builder.D.Channel := Protocol.Create (Socket, Virtual => True); Pos := Builders.Find (Builder); if Builder_Set.Has_Element (Pos) then Builder := Builder_Set.Element (Pos); end if; return Builder; end Get; -------------------- -- Get_Socket_Set -- -------------------- entry Get_Socket_Set (Socket_Set : out Socket_Set_Type) when not Builders.Is_Empty is begin Empty (Socket_Set); for B of Builders loop Set (Socket_Set, Sock (B)); end loop; end Get_Socket_Set; ---------------- -- Initialize -- ---------------- procedure Initialize (Builder : in out Build_Master) is begin Builder.D.Id := Current_Id; Current_Id := Current_Id + 1; end Initialize; ------------ -- Insert -- ------------ procedure Insert (Builder : Build_Master) is begin Builders.Insert (Builder); end Insert; ---------- -- Lock -- ---------- entry Lock (Builder : in out Build_Master) when True is begin if Builder.D.Locked then requeue Try_Lock; else Builder.D.Locked := True; end if; end Lock; ------------- -- Release -- ------------- procedure Release (Builder : in out Build_Master) is begin Builder.D.Locked := False; if Try_Lock'Count > 0 then To_Check := To_Check + Try_Lock'Count; end if; end Release; ------------ -- Remove -- ------------ procedure Remove (Builder : in out Build_Master) is begin Builders.Exclude (Builder); Release (Builder); end Remove; -------------- -- Try_Lock -- -------------- entry Try_Lock (Builder : in out Build_Master) when To_Check > 0 is begin To_Check := To_Check - 1; if Builder.D.Locked then requeue Try_Lock; else Builder.D.Locked := True; end if; end Try_Lock; ------------------------ -- Working_Dir_Exists -- ------------------------ function Working_Dir_Exists (Directory : String) return Boolean is begin for B of Builders loop if Work_Directory (B) = Directory then return True; end if; end loop; return False; end Working_Dir_Exists; end Builders; ------------------- -- Close_Builder -- ------------------- procedure Close_Builder (Builder : in out Build_Master; Ack : Boolean) is begin -- First unregister the builder Builders.Remove (Builder); Running.Kill_Processes (Sock (Builder)); -- Send an Ack message before closing if requested if Ack then begin Send_Ok (Builder.D.Channel); exception when others => null; end; end if; -- Now shutdown the socket. This routine is used when the builder -- has encountered an error, so the associated socket may be in a bad -- state. Make sure we do not fail here. Close (Builder.D.Channel); end Close_Builder; ----------------------------- -- Controlled_Build_Master -- ----------------------------- protected body Controlled_Build_Master is ------------ -- Adjust -- ------------ procedure Adjust (Builder : in out Build_Master) is begin Builder.D.Count := Builder.D.Count + 1; end Adjust; -------------- -- Finalize -- -------------- procedure Finalize (Builder : in out Build_Master) is procedure Unchecked_Free is new Unchecked_Deallocation (Data, Shared_Data); S : Shared_Data := Builder.D; begin Builder.D := null; S.Count := S.Count - 1; if S.Count = 0 then Unchecked_Free (S); end if; end Finalize; ---------------- -- Initialize -- ---------------- procedure Initialize (Builder : in out Build_Master) is begin Builder.D := new Data' (Channel => No_Channel, Project_Name => Null_Unbounded_String, Target => Null_Unbounded_String, Build_Env => Null_Unbounded_String, Included_Artifact_Patterns => <>, Id => 0, Locked => False, Count => 1); end Initialize; end Controlled_Build_Master; ------------- -- Display -- ------------- procedure Display (Str : String; Is_Debug : Boolean := False; Force : Boolean := False) is begin if Force or (Verbose and not Is_Debug) or (Debug and Is_Debug) then IO.Message (Str, Is_Debug); end if; end Display; procedure Display (Builder : Build_Master; Str : String; Is_Debug : Boolean := False; Force : Boolean := False) is begin if Force or (Verbose and not Is_Debug) or (Debug and Is_Debug) then IO.Message (Builder, Str, Is_Debug); end if; end Display; -------------- -- Finalize -- -------------- overriding procedure Finalize (Builder : in out Build_Master) is begin Controlled_Build_Master.Finalize (Builder); end Finalize; ------------- -- Get_Arg -- ------------- function Get_Arg (Builder : Build_Master; Value : String) return String is P : constant Natural := Fixed.Index (Value, WD_Path_Tag); begin if P = 0 then return Value; else return Value (Value'First .. P - 1) & Work_Directory (Builder) & Directory_Separator & Get_Arg (Builder, Value (P + WD_Path_Tag'Length .. Value'Last)); end if; end Get_Arg; -------------- -- Get_Args -- -------------- function Get_Args (Builder : Build_Master; Slices : Slice_Set) return Argument_List is Args : Argument_List (1 .. Integer (Slice_Count (Slices))); begin for K in Args'Range loop Args (K) := new String' (Get_Arg (Builder, Slice (Slices, Slice_Number (K)))); end loop; return Args; end Get_Args; ----------------- -- Get_Slave_Id -- ----------------- function Get_Slave_Id return Remote_Id is use GNAT.CRC32; CRC : GNAT.CRC32.CRC32; begin Initialize (CRC); -- Add host name Update (CRC, Host_Name); -- Add root directory Update (CRC, Root_Directory.all); -- Add port Update (CRC, Integer'Image (Port)); -- Set the host id as the 32 higher bits return Remote_Id (Get_Value (CRC)) * 2 ** 32; end Get_Slave_Id; ----------- -- Image -- ----------- function Image (Value : Long_Integer) return String is I : constant String := Long_Integer'Image (Value); begin return (if I (I'First) = '-' then I else I (I'First + 1 .. I'Last)); end Image; ---------------- -- Initialize -- ---------------- overriding procedure Initialize (Builder : in out Build_Master) is begin Controlled_Build_Master.Initialize (Builder); end Initialize; -------- -- IO -- -------- protected body IO is ------------- -- Message -- ------------- procedure Message (Str : String; Is_Debug : Boolean := False) is begin Put_Line ('[' & Calendar.Formatting.Image (Calendar.Clock) & "] " & (if Is_Debug then "# " else " ") & Str); end Message; procedure Message (Builder : Build_Master; Str : String; Is_Debug : Boolean := False) is package UID_IO is new Text_IO.Modular_IO (UID); begin UID_IO.Put (Builder.D.Id, Width => 4); Put (' '); Message (Str, Is_Debug); end Message; ----------- -- Spawn -- ----------- procedure Spawn (Driver : String; Options : Argument_List; Out_File : String; Pid : out Process_Id) is begin Pid := OS_Lib.Non_Blocking_Spawn (Driver, Options, Out_File); end Spawn; end IO; ------------------------ -- Parse_Command_Line -- ------------------------ procedure Parse_Command_Line is use GNAT.Command_Line; procedure Usage; procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage); Config : Command_Line_Configuration; ----------- -- Usage -- ----------- procedure Usage is begin Display_Help (Config); end Usage; begin Define_Switch (Config, Help'Access, "-h", Long_Switch => "--help", Help => "display this help message and exit"); Define_Switch (Config, Verbose'Access, "-V", Long_Switch => "--version", Help => "display version and exit"); Define_Switch (Config, Max_Processes'Access, "-j:", Long_Switch => "--jobs=", Initial => Integer (Multiprocessors.Number_Of_CPUs), Default => Integer (Multiprocessors.Number_Of_CPUs), Help => "set the maximum simultaneous compilation"); Define_Switch (Config, Max_Responses'Access, "-r:", Long_Switch => "--response-handler=", Initial => Integer (2), Default => Integer (2), Help => "maximum number of simultaneous responses sent back"); Define_Switch (Config, Root_Directory'Access, "-d:", Long_Switch => "--directory=", Help => "set the root directory"); Define_Switch (Config, Port'Access, "-p:", Long_Switch => "--port=", Initial => Integer (Default_Port), Default => Integer (Default_Port), Help => "set the port the slave will listen to"); Define_Switch (Config, Verbose'Access, "-v", Long_Switch => "--verbose", Help => "verbose mode, display extra information"); Define_Switch (Config, Debug'Access, "-vv", Long_Switch => "--debug", Help => "debug mode, display lot of information (imply -v)"); Define_Switch (Config, Hash'Access, "-s:", Long_Switch => "--hash=", Help => "specify a hash, must match with master"); Set_Usage (Config, Usage => "[switches]"); Check_Version_And_Help ("GPRSLAVE", "2013"); Getopt (Config); if Debug then Verbose := True; end if; -- To avoid error messages for unknown languages that are not described -- in the XML database, use the quiet mode if Verbose is not set. if not Verbose then Opt.Quiet_Output := True; end if; -- First ensure Root_Directory is an absolute path-name. This is -- needed to be able to create directory for a specific builder without -- enforcing that the current directory be in a critical section. -- Indeed, it is then possible to create a directory under this -- absolute path-name directly. if not Is_Absolute_Path (Root_Directory.all) then -- Not an absolute path, this means that we have passed a directory -- relative to the current directory with option -d/--directory. declare RD : constant String := Root_Directory.all; begin Free (Root_Directory); Root_Directory := new String'(Get_Current_Dir & RD); end; end if; -- Ensure Root_Directory does not ends with a directory separator if Root_Directory (Root_Directory'Last) in '/' | '\' then Delete_Last : declare RD : constant String := Root_Directory (Root_Directory'First .. Root_Directory'Last - 1); begin Free (Root_Directory); Root_Directory := new String'(RD); end Delete_Last; end if; Running.Set_Max (Max_Processes); Free (Config); exception when Invalid_Switch => OS_Exit (1); when Exit_From_Command_Line => OS_Exit (1); end Parse_Command_Line; ------------------- -- Wait_Requests -- ------------------- task body Wait_Requests is procedure Close_Socket_Set (Set : in out Socket_Set_Type); -- Close all sockets in the given Set. The corresponding build masters -- are closed too. ---------------------- -- Close_Sokcet_Set -- ---------------------- procedure Close_Socket_Set (Set : in out Socket_Set_Type) is Builder : Build_Master; Socket : Socket_Type; begin loop Get (Set, Socket); exit when Socket = No_Socket; Builder := Builders.Get (Socket); Close_Builder (Builder, Ack => False); Display (Builder, "error socket ", Force => True); end loop; end Close_Socket_Set; type Job_Number is mod 2**32; -- A 32bits integer which wrap around. This is no problem as we want -- to be able to identify running process. There won't be 2**32 process -- running at the same time. So it is safe restart numbering at 0. Selector : Selector_Type; R_Socket_Set : Socket_Set_Type; E_Socket_Set : Socket_Set_Type; Empty_Set : Socket_Set_Type; Status : Selector_Status; Builder : Build_Master; Socket : Socket_Type; Jid : Job_Number := 0; begin -- Create selector Create_Selector (Selector); Empty (Empty_Set); -- For now do not check write status Handle_Commands : loop -- Wait for some commands from one of the build master Builders.Get_Socket_Set (R_Socket_Set); Copy (R_Socket_Set, E_Socket_Set); Wait_Incoming_Data : loop begin Check_Selector (Selector, R_Socket_Set, Empty_Set, E_Socket_Set, Status); exit Wait_Incoming_Data; exception when E : Socket_Error => if Resolve_Exception (E) /= Interrupted_System_Call then Status := Aborted; exit Wait_Incoming_Data; end if; end; end loop Wait_Incoming_Data; -- Check for socket errors first, if a socket is in error just -- close the corresponding builder and remove it from the list. -- From there we abort any further actions for those builders. Close_Socket_Set (E_Socket_Set); if Status = Aborted then -- Either the selector has been aborted or the Socket was not -- found in the response. We can suppose that in this case the -- client is killed and we do not have to keep it in the registry. Close_Socket_Set (R_Socket_Set); else -- Now, check for socket ready for reading. Just get the first -- one, other requests will be handled in next iteration. Get (R_Socket_Set, Socket); if Socket /= No_Socket then Builder := Builders.Get (Socket); if Is_Active_Build_Master (Builder) then Builders.Lock (Builder); declare Cmd : constant Command := Get_Command (Builder.D.Channel); begin if Debug then declare List : constant Argument_List_Access := Args (Cmd); V : Unbounded_String; begin V := To_Unbounded_String ("command: " & Command_Kind'Image (Kind (Cmd))); if List /= null then for K in List'Range loop Append (V, ", " & List (K).all); end loop; end if; Display (Builder, To_String (V), Is_Debug => True); end; end if; if Kind (Cmd) = EX then Record_Job : declare Id : constant Remote_Id := Slave_Id + Remote_Id (Jid); -- Note that the Id above should be unique across -- all running slaves. This is not the process -- id, but an id sent back to the build master -- to identify the actual job. begin Jid := Jid + 1; Display (Builder, "register compilation " & Image (Id), True); Send_Ack (Builder.D.Channel, Id); To_Run.Push (Job_Data'(Cmd, Id, OS_Lib.Invalid_Pid, Null_Unbounded_String, Null_Unbounded_String, Null_Unbounded_String, Null_Unbounded_String, Sock (Builder), J_Created)); end Record_Job; elsif Kind (Cmd) = FL then null; elsif Kind (Cmd) = CU then Clean_Up_Request : begin To_Run.Push (Job_Data'(Cmd, 0, OS_Lib.Invalid_Pid, Null_Unbounded_String, Null_Unbounded_String, Null_Unbounded_String, Null_Unbounded_String, Sock (Builder), J_Created)); end Clean_Up_Request; elsif Kind (Cmd) in EC | SI then -- No more compilation for this project. Send an -- Ack only if we are not handling a kill signal -- (receiving SI means that the socket has been -- detected to be closed). Close_Builder (Builder, Ack => (Kind (Cmd) = EC)); Display (Builder, "End project : " & To_String (Builder.D.Project_Name)); elsif Kind (Cmd) = SY then -- Synchronization requested declare Empty : Sync.Str_Vect.Vector; begin Compilation.Sync.Send_Files (Builder.D.Channel, Work_Directory (Builder), Empty, Empty, Mode => Sync.To_Master); end; elsif Kind (Cmd) = IR then -- Information requested Send_Info_Response (Builder.D.Channel, GPR.Version.Gpr_Version_String, UTC_Time, "toto"); -- Gprslave.Hash.all); else raise Constraint_Error with "unexpected command " & Command_Kind'Image (Kind (Cmd)); end if; exception when Socket_Error => -- The build master has probably been killed. We -- cannot communicate with it. Just close the channel. Close_Builder (Builder, Ack => False); Display (Builder, "Interrupted project : " & To_String (Builder.D.Project_Name)); when E : others => -- In case of an exception, communication endded -- prematurately or some wrong command received, make -- sure we clean the slave state and we listen to new -- commands. Not doing that could make the slave -- unresponsive. Close_Builder (Builder, Ack => False); Display (Builder, "Error: " & Exception_Information (E), Force => True); end; -- The lock is released and freed if we have an EC command Builders.Release (Builder); else Display ("build master not found, cannot handle request.", Is_Debug => True); end if; end if; end if; end loop Handle_Commands; exception when E : others => Display (Builder, "Unrecoverable error: Protocol_Handler.", Force => True); Display (Builder, Symbolic_Traceback (E), Force => True); OS_Exit (1); end Wait_Requests; ----------------- -- Execute_Job -- ----------------- task body Execute_Job is function Get_Driver (Builder : Build_Master; Language : String; Target, Runtime : String; Project : String) return String; -- Returns the compiler driver for the given language and the current -- target as retreived from the initial handshake context exchange. function Get_Output_File (Builder : Build_Master) return String; -- Returns a unique output file procedure Output_Compilation (Builder : Build_Master; File : String); -- Output compilation information procedure Do_Compile (Job : in out Job_Data); -- Run a compilation job procedure Do_Clean (Job : Job_Data); -- Run a clean job package Drivers_Cache is new Containers.Indefinite_Hashed_Maps (String, String, Ada.Strings.Hash_Case_Insensitive, Ada.Strings.Equal_Case_Insensitive); Cache : Drivers_Cache.Map; ---------------- -- Get_Driver -- ---------------- function Get_Driver (Builder : Build_Master; Language : String; Target, Runtime : String; Project : String) return String is procedure Look_Driver (Project_Name : String; Is_Config : Boolean); -- Set Driver with the found driver for the Language Config_Filename : constant String := "slave_tmp-" & Language & ".cgpr"; Key : constant String := To_String (Builder.D.Target) & '+' & Language & "+" & Runtime; Position : constant Drivers_Cache.Cursor := Cache.Find (Key); Compilers, Filters : Compiler_Lists.List; Requires_Comp : Boolean; Comp : Compiler_Access; Env : Environment; Success : Boolean; Driver : Unbounded_String := To_Unbounded_String (Key); ----------------- -- Look_Driver -- ----------------- procedure Look_Driver (Project_Name : String; Is_Config : Boolean) is Project_Node_Tree : GPR.Project_Node_Tree_Ref; Project_Node : Project_Node_Id := Empty_Project_Node; Project_Tree : Project_Tree_Ref; Project : Project_Id; begin Project_Node_Tree := new Project_Node_Tree_Data; GPR.Tree.Initialize (Project_Node_Tree); GPR.Part.Parse (Project_Node_Tree, Project_Node, Project_Name, Errout_Handling => GPR.Part.Finalize_If_Error, Packages_To_Check => null, Is_Config_File => Is_Config, Target_Name => To_String (Builder.D.Target), Env => Env); Project_Tree := new Project_Tree_Data; GPR.Initialize (Project_Tree); Proc.Process (Project_Tree, Project, null, Success, Project_Node, Project_Node_Tree, Env); if not Success then return; end if; declare Pcks : Package_Table.Table_Ptr renames Project_Tree.Shared.Packages.Table; Pck : Package_Id := Project.Decl.Packages; begin Look_Compiler_Package : while Pck /= No_Package loop if Pcks (Pck).Decl /= No_Declarations and then Pcks (Pck).Name = Name_Compiler then -- Look for the Driver ("") attribute declare Id : Array_Id := Pcks (Pck).Decl.Arrays; begin while Id /= No_Array loop declare V : constant Array_Data := Project_Tree.Shared.Arrays.Table (Id); begin if V.Name = Name_Driver and then V.Value /= No_Array_Element then -- Check if element is for the given -- language, and if so return the -- corresponding value. declare E : constant Array_Element := Project_Tree.Shared. Array_Elements.Table (V.Value); begin if Get_Name_String (E.Index) = To_Lower (Language) then Driver := To_Unbounded_String (Get_Name_String (E.Value.Value)); exit Look_Compiler_Package; end if; end; end if; end; Id := Project_Tree.Shared.Arrays.Table (Id).Next; end loop; end; end if; Pck := Pcks (Pck).Next; end loop Look_Compiler_Package; end; Free (Project_Node_Tree); Free (Project_Tree); end Look_Driver; begin if Drivers_Cache.Has_Element (Position) then return Drivers_Cache.Element (Position); else -- Generate the configuration project for this language and target Parse_Config_Parameter (Base => Base, Config => Language & ",," & Runtime, Compiler => Comp, Requires_Compiler => Requires_Comp); if Requires_Comp then Filters.Append (Comp); else Compilers.Append (Comp); end if; Get_Targets_Set (Base, Target, Selected_Targets_Set); declare Used_Target : Unbounded_String := To_Unbounded_String (Target); begin Complete_Command_Line_Compilers (Base, Selected_Targets_Set, Filters, Compilers, Target_Specified => True, Selected_Target => Used_Target); end; -- Generate configuration project file Generate_Configuration (Base, Compilers, Config_Filename, To_String (Builder.D.Target), Selected_Targets_Set); GPR.Tree.Initialize (Env, GPR.Gprbuild_Flags); GPR.Initialize (GPR.No_Project_Tree); GPR.Env.Initialize_Default_Project_Path (Env.Project_Path, Target_Name => To_String (Builder.D.Target)); -- Parse it to find the driver for this language Look_Driver (Config_Filename, Is_Config => True); Directories.Delete_File (Config_Filename); -- Language is not found in the knowledge base, check the project -- to see if there is a definition for the language. if Driver = Key then Look_Driver (Project, Is_Config => False); -- Ensure that we have a full-path name if Driver = Key then -- Driver not found, use -gcc if it exists Driver := Builder.D.Target & "-gcc"; end if; declare Exe : OS_Lib.String_Access := Locate_Exec_On_Path (To_String (Driver)); begin if Exe = null then Display (Builder, "Can't locate " & To_String (Driver) & " in path", Is_Debug => True); return Key; end if; Driver := To_Unbounded_String (Exe.all); Free (Exe); end; end if; -- Record this driver for the language and target into the cache Cache.Insert (Key, To_String (Driver)); -- Clean-up and free project structure Display (Builder, "driver for " & Language & " is : " & To_String (Driver), Is_Debug => True); return To_String (Driver); end if; exception when E : others => Display (Builder, Ada.Exceptions.Exception_Information (E) & ASCII.LF & "on get driver for " & Language & " by key " & Key, Is_Debug => True); -- Be sure we never propagate an exception from this routine, in -- case of problem we just return the key, this will be used as an -- executable and will be reported to the master as a proper build -- failure. return Key; end Get_Driver; --------------------- -- Get_Output_File -- --------------------- function Get_Output_File (Builder : Build_Master) return String is Filename : constant String := "output.slave." & Image (Index); begin Index := Index + 1; return Compose (Work_Directory (Builder), Filename); end Get_Output_File; ------------------------ -- Output_Compilation -- ------------------------ procedure Output_Compilation (Builder : Build_Master; File : String) is function Prefix return String; -- Returns a prefix for the display with a progress indication ------------ -- Prefix -- ------------ function Prefix return String is Active : constant String := Natural'Image (Running.Count + 1); Max : constant String := Natural'Image (Max_Processes); begin return "Compiling (" & Active (Active'First + 1 .. Active'Last) & '/' & Max (Max'First + 1 .. Max'Last) & ") : "; end Prefix; RDL : constant Natural := Root_Directory'Length; begin if Verbose then if File'Length > RDL and then File (File'First .. File'First + RDL - 1) = Root_Directory.all then Display (Builder, Prefix & File (File'First + RDL + 1 .. File'Last)); else Display (Builder, Prefix & File); end if; end if; end Output_Compilation; ---------------- -- Do_Compile -- ---------------- procedure Do_Compile (Job : in out Job_Data) is Builder : constant Build_Master := Builders.Get (Job.Build_Sock); Dir : constant String := Args (Job.Cmd)(2).all; List : Slice_Set; begin -- Enter a critical section to: -- - move to directory where the command is executed -- - execute the compilation command -- - register a new job and acknowledge -- - move back to working directory Display (Builder, "move to work directory " & Work_Directory (Builder), Is_Debug => True); -- It is safe to change directory here without a lock as this is -- the only place where it happens and there is a single instance -- of this task. Set_Directory (Work_Directory (Builder)); -- Create/Move to object dir if any, note that if we -- have an absolute path name here it is because the -- Build_Root is probably not properly set. Try to fail -- gracefully to report a proper error message to the -- build master. -- -- If we have an absolute pathname, just start the -- process into the to directory. The output file will -- be created there and will be reported to the master. -- -- Note that the following block should never fail otherwise the -- process won't be started. Even if we know the compilation will -- fail we need to move forward as the result for this compilation -- is waited for by the build master. begin if Dir /= "" then if not Is_Absolute_Path (Dir) and then not Is_Directory (Dir) then Create_Directory (Dir); end if; Display (Builder, "move to directory " & Dir, Is_Debug => True); Set_Directory (Dir); end if; exception when others => Display (Builder, "cannot move to object directory", Is_Debug => True); end; Create (List, Args (Job.Cmd) (8).all, String'(1 => Opts_Sep)); Execute : declare Project : constant String := Get_Arg (Builder, Args (Job.Cmd) (1).all); Language : constant String := Args (Job.Cmd) (3).all; Target : constant String := Args (Job.Cmd) (4).all; Runtime : constant String := Args (Job.Cmd) (5).all; Out_File : constant String := Get_Output_File (Builder); Obj_File : constant String := Args (Job.Cmd) (6).all; Dep_File : constant String := Args (Job.Cmd) (7).all; Env : constant String := Get_Arg (Builder, Args (Job.Cmd) (9).all); O : Argument_List := Get_Args (Builder, List); First_Opt : Positive := O'First; Pid : Process_Id; Driver : Unbounded_String; begin Output_Compilation (Builder, O (O'Last).all); -- Set compiler environment Set_Env (Env, Fail => False, Force => True); -- It is critical to ensure that no IO is done while spawning -- the process. -- If there is now language set, we are not calling a compiler -- but a tool directly (gprbuild from GPRremote for example). In -- this case the driver is taken from the first option in the -- list. -- -- When language is not null we compute the driver to be used -- based on the project setting for this specific language. if Language = "" then declare Drv : OS_Lib.String_Access := Locate_Exec_On_Path (O (O'First).all); begin Driver := To_Unbounded_String (Drv.all); Free (Drv); end; -- And skip first option which was the driver First_Opt := First_Opt + 1; else Driver := To_Unbounded_String (Get_Driver (Builder, Language, Target, Runtime, Project)); end if; Running.Start (Job => Job, Driver => To_String (Driver), Options => O (First_Opt .. O'Last), Out_File => Out_File, Obj_File => Obj_File, Dep_File => Dep_File, Dep_Dir => (if Is_Absolute_Path (Dir) then "" else Dir), Pid => Pid); Display (Builder, " pid" & Integer'Image (Pid_To_Integer (Pid)), Is_Debug => True); Display (Builder, " obj_file " & Obj_File, Is_Debug => True); Display (Builder, " dep_file " & Dep_File, Is_Debug => True); Display (Builder, " out_file " & Out_File, Is_Debug => True); for K in O'Range loop Free (O (K)); end loop; end Execute; exception when E : others => Display (Builder, "Error in Execute_Job: " & Symbolic_Traceback (E), Is_Debug => True); end Do_Compile; -------------- -- Do_Clean -- -------------- procedure Do_Clean (Job : Job_Data) is Builder : constant Build_Master := Builders.Get (Job.Build_Sock); begin Builder.D.Project_Name := To_Unbounded_String (Args (Job.Cmd)(1).all); declare WD : constant String := Work_Directory (Builder); begin if Exists (WD) then Display (Builder, "Delete " & WD); -- Cannot delete if the process is still under -- the working directory, so move to the slave -- root directory. Set_Directory (Root_Directory.all); Delete_Tree (WD); end if; end; Send_Ok (Builder.D.Channel); exception when E : others => Display (Builder, "clean-up error " & Symbolic_Traceback (E), True); Send_Ko (Builder.D.Channel); end Do_Clean; Job : Job_Data; begin loop -- Launch a new compilation only if the maximum of simultaneous -- process has not yet been reached. Running.Wait_Slot; To_Run.Pop (Job); -- Only launch the job if the corresponding builder is still active. -- It could be the case that the builder has been interrupted -- (ctrl-c) and so removed from the set. if Builders.Exists (Job.Build_Sock) then if Kind (Job.Cmd) = EX then -- Note that we do not release the job here as it will -- get recorded as running job. The release will happen -- in Wait_Completion. Do_Compile (Job); else Do_Clean (Job); end if; end if; end loop; exception when E : others => Display ("Unrecoverable error: Execute_Job.", Force => True); Display (Exception_Information (E), Force => True); OS_Exit (1); end Execute_Job; ------------- -- Running -- ------------- protected body Running is procedure Register (Job : Job_Data) with Pre => Job.Stage = J_Running; -- Register a running Job ----------- -- Count -- ----------- function Count return Natural is begin return N_Count; end Count; -------------------- -- Kill_Processes -- -------------------- procedure Kill_Processes (Socket : Socket_Type) is To_Kill : Job_Data_Set.Set; C : Job_Data_Set.Cursor; begin -- First pass, record all job for the given builder for Job of Set loop if Job.Build_Sock = Socket then To_Kill.Insert (Job); end if; end loop; -- Second pass, kill processes and mark them as killed. Those jobs -- are interrupted and the builder removed, so there is no point to -- try to send back the compilation result to the master. -- -- This also ensure a faster termination of the build master. for Job of To_Kill loop -- Mark job as killed into the set C := Set.Find (Job); Set (C).Stage := J_Killed; Kill_Process_Tree (Job.Pid, Hard_Kill => True); Display ("kill job" & Integer'Image (Pid_To_Integer (Job.Pid)), Is_Debug => True); end loop; end Kill_Processes; -------------- -- Register -- -------------- procedure Register (Job : Job_Data) is begin -- Let's ensure that while the job was prepared the builder was not -- hard-killed. If so we kill the process right now. The result won't -- be used anyway and we do not want it to linger here and possibly -- corrupt a new launched compilation for the same object file. -- -- Note that it is still inserted into the job set for the job exit -- status to be read. This ensure that the job is properly terminated -- by the OS (on Linux the process would stay as for -- example). if not Builders.Exists (Job.Build_Sock) then Display ("kill job (missing builder)" & Integer'Image (Pid_To_Integer (Job.Pid)), Is_Debug => True); Kill (Job.Pid, Hard_Kill => True); Insert_Killed_Job : declare Killed_Job : Job_Data := Job; begin Killed_Job.Stage := J_Killed; Set.Insert (Killed_Job); end Insert_Killed_Job; elsif Job.Pid = OS_Lib.Invalid_Pid then Dead.Insert (Job); else Set.Insert (Job); end if; N_Count := N_Count + 1; end Register; ----------- -- Start -- ----------- procedure Start (Job : in out Job_Data; Driver : String; Options : Argument_List; Out_File : String; Obj_File : String; Dep_File : String; Dep_Dir : String; Pid : out Process_Id) is begin if Debug then Put (Driver); Put (' '); for O of Options loop Put (O.all); Put (' '); end loop; New_Line; end if; IO.Spawn (Driver, Options, Out_File, Pid); Job.Pid := Pid; Job.Dep_File := To_Unbounded_String (Dep_File); Job.Obj_File := To_Unbounded_String (Obj_File); Job.Output := To_Unbounded_String (Out_File); Job.Dep_Dir := To_Unbounded_String (Dep_Dir); Job.Stage := J_Running; -- Note that we want to register the job even if Pid is -- Invalid_Process. We want it to be recorded into the running -- process to be able to be retrieved by the Wait_Completion -- task and a proper NOK message to be sent to the builder. Register (Job); end Start; --------- -- Get -- --------- procedure Get (Job : out Job_Data; Pid : Process_Id) is Pos : Job_Data_Set.Cursor; begin if Dead.Is_Empty then Job := No_Job; Job.Pid := Pid; Pos := Set.Find (Job); -- Not that a job could be not found here because the Pid is one -- of gprconfig runned to generate a configuration file for a -- specific language. if Job_Data_Set.Has_Element (Pos) then Job := Job_Data_Set.Element (Pos); Set.Delete (Job); N_Count := N_Count - 1; -- If this is a job which has been killed (see Kill_Processes -- above), set to No_Job. We do this as the Wait_Completion -- task must not do anything with such a process (no need to -- send back answers as anyway the build master is not running -- anymore). if Job.Stage = J_Killed then Job := No_Job; else Job.Stage := J_Terminated; end if; else Job := No_Job; end if; else Job := Dead.First_Element; Job.Stage := J_Terminated; Dead.Delete_First; N_Count := N_Count - 1; end if; end Get; ------------- -- Set_Max -- ------------- procedure Set_Max (Max : Positive) is begin Running.Max := Max; end Set_Max; ---------- -- Wait -- ---------- entry Wait when Count > 0 is begin null; end Wait; --------------- -- Wait_Slot -- --------------- entry Wait_Slot when Count < Max is begin null; end Wait_Slot; end Running; ------------ -- To_Run -- ------------ protected body To_Run is ---------- -- Push -- ---------- procedure Push (Job : Job_Data) is J : Job_Data := Job; begin -- Always adds the clean-up job in front of the queue, this is -- friendler as we do not want the user to wait for all current -- compilation to terminate. J.Stage := J_Waiting; if Kind (Job.Cmd) = CU then Set.Prepend (J); else Set.Append (J); end if; end Push; --------- -- Pop -- --------- entry Pop (Job : out Job_Data) when not Set.Is_Empty is begin Job := Set.First_Element; Set.Delete_First; end Pop; end To_Run; --------------------- -- Wait_Completion -- --------------------- task body Wait_Completion is Pid : Process_Id; Success : Boolean; Job : Job_Data; Builder : Build_Master; package String_Set is new Containers.Indefinite_Vectors (Positive, String); function Expand_Artifacts (Root : String; Base_Name : String; Patterns : String_Split.Slice_Set) return String_Set.Vector; -- Returns the set of artifacts for the Base_Name based on the patterns -- given by attribute Included_Artifact_Patterns. ---------------------- -- Expand_Artifacts -- ---------------------- function Expand_Artifacts (Root : String; Base_Name : String; Patterns : String_Split.Slice_Set) return String_Set.Vector is Count : constant Slice_Number := Slice_Count (Patterns); Result : String_Set.Vector; begin for K in 1 .. Count loop declare Item : constant String := String_Split.Slice (Patterns, K); Star : constant Natural := Fixed.Index (Item, "*"); Name : Unbounded_String; begin if Item'Length > 0 then -- No start to replace, this is a plain file-name if Star = 0 then Name := To_Unbounded_String (Item); else -- We have a star, replace it with the base name Name := To_Unbounded_String (Item (Item'First .. Star - 1) & Base_Name & Item (Star + 1 .. Item'Last)); end if; if Exists (Root & To_String (Name)) then Result.Append (Root & To_String (Name)); end if; end if; end; end loop; return Result; end Expand_Artifacts; begin loop -- Wait for a job to complete only if there is job running Running.Wait; Wait_Process (Pid, Success); -- If a "dead" jobs is returned success is forced to False if Pid = OS_Lib.Invalid_Pid then Success := False; end if; Running.Get (Job, Pid); -- Note that if there is not such element it could be because the -- build master has been killed before the end of the compilation. -- In this case an EC message is received by the slave and the -- Job_Set is clear. See Main_Loop in gprslave's body. if Job /= No_Job then -- Now get the corresponding build master Builder := Builders.Get (Job.Build_Sock); if Is_Active_Build_Master (Builder) then Builders.Lock (Builder); begin Display (Builder, "job " & Image (Job.Id) & " terminated", Is_Debug => True); declare DS : Character renames Directory_Separator; Dep_Dir : constant String := To_String (Job.Dep_Dir); Dep_File : constant String := To_String (Job.Dep_File); Obj_File : constant String := To_String (Job.Obj_File); Out_File : constant String := To_String (Job.Output); S : Boolean; begin if Exists (Out_File) then Send_Output (Builder.D.Channel, Out_File); end if; OS_Lib.Delete_File (Out_File, S); if Success then -- No dependency or object files to send back if the -- compilation was not successful. declare R_Dir : constant String := Work_Directory (Builder) & (if Dep_Dir /= "" then DS & Dep_Dir else "") & DS; D_File : constant String := R_Dir & Dep_File; O_File : constant String := R_Dir & Obj_File; begin if Dep_File /= "" and then Exists (D_File) and then Kind (D_File) = Ordinary_File then Send_File (Builder.D.Channel, D_File, Rewrite => True); end if; if Obj_File /= "" then if Exists (O_File) then Send_File (Builder.D.Channel, O_File, Rewrite => False); end if; -- We also check for any artifacts based on the -- user's patterns if any. for Artifact of Expand_Artifacts (Root => R_Dir, Base_Name => Directories.Base_Name (Obj_File), Patterns => Builder.D.Included_Artifact_Patterns) loop Send_File (Builder.D.Channel, Artifact, Rewrite => False); end loop; end if; end; end if; end; Display (Builder, "compilation status " & Boolean'Image (Success), Is_Debug => True); if Success then Send_Ok (Builder.D.Channel, Job.Id); else Send_Ko (Builder.D.Channel, Job.Id); end if; Builders.Release (Builder); exception when E : others => -- An exception can be raised if the builder master has -- been terminated. In this case the communication won't -- succeed. -- Remove it from the list Close_Builder (Builder, Ack => False); Display (Builder, "cannot send response to build master " & Exception_Information (E), Force => True); end; else Display ("build master not found, cannot send response.", Is_Debug => True); end if; else -- This is not necessarily an error as we could get a Pid of a -- gprconfig run launched to generate a configuration file for a -- specific language. So we do not want to fail in this case. Display ("unknown job data for pid " & Integer'Image (Pid_To_Integer (Pid)), Is_Debug => True); end if; end loop; exception when E : others => Put_Line ("Unrecoverable error: Wait_Completion: " & Exception_Name (E)); Put_Line (Symbolic_Traceback (E)); OS_Exit (1); end Wait_Completion; --------------------- -- Wait_For_Master -- --------------------- procedure Wait_For_Master is use Stamps; procedure Sync_Gpr (Builder : in out Build_Master); -------------- -- Sync_Gpr -- -------------- procedure Sync_Gpr (Builder : in out Build_Master) is procedure Delete_Files (Except : Sync.Files.Set); -- Delete all files in the current working tree except those in -- Except set. procedure Display (Message : String); -- Display message callback WD : constant String := Work_Directory (Builder); ------------------ -- Delete_Files -- ------------------ procedure Delete_Files (Except : Sync.Files.Set) is procedure Process (Path : String); -- Search recursively the Path procedure Process (Path : String) is procedure Check (File : Directory_Entry_Type); -- Remove this file if not part of Except set ----------- -- Check -- ----------- procedure Check (File : Directory_Entry_Type) is S_Name : constant String := Simple_Name (File); Entry_Name : constant String := Path & Directory_Separator & S_Name; begin if Kind (File) = Directory then if S_Name not in "." | ".." and then not Is_Symbolic_Link (Entry_Name) then Process (Entry_Name); end if; else if not Except.Contains (Entry_Name) then Display (Builder, "delete excluded '" & Entry_Name & ''', Is_Debug => True); Delete_File (Entry_Name); end if; end if; end Check; begin Search (Directory => Path, Pattern => "*", Filter => (Special_File => False, others => True), Process => Check'Access); end Process; begin Process (WD); end Delete_Files; ------------- -- Display -- ------------- procedure Display (Message : String) is begin if Debug then Display (Message, Is_Debug => True); else Display (Builder, Message); end if; end Display; Total_File : Natural; Total_Transferred : Natural; In_Master : Sync.Files.Set; Result : constant Protocol.Command_Kind := Sync.Receive_Files (Builder.D.Channel, WD, Total_File, Total_Transferred, In_Master, Debug, Display'Access); begin if Result = ES then -- Delete all files not part of the list sent by the master. -- This is needed to remove files in previous build removed -- since then on the master. Again we need to do that as we -- can't let around unnedded specs or bodies. Delete_Files (Except => In_Master); elsif Result in EC | SI then -- Cannot communicate with build master anymore, we then -- receive an end-of-compilation. Exit now. Note that we do -- not need to remove the builder from the list as it is not -- yet registered. Close_Builder (Builder, Ack => Result = EC); end if; Display (Builder, "Files total:" & Natural'Image (Total_File)); Display (Builder, " transferred :" & Natural'Image (Total_Transferred)); exception when E : others => Close_Builder (Builder, Ack => False); Display (Builder, "Lost connection with " & Image (Address)); Display (Builder, Exception_Information (E), Is_Debug => True); end Sync_Gpr; Builder : Build_Master; Clock_Status : Boolean; Socket : Socket_Type; begin -- Wait for a connection Wait_Incoming_Master : loop begin Accept_Socket (Server, Socket, Address); exit Wait_Incoming_Master; exception when E : Socket_Error => if Resolve_Exception (E) /= Interrupted_System_Call then raise; end if; end; end loop Wait_Incoming_Master; Builder.D.Channel := Create (Socket); -- Then initialize the new builder Id Builders.Initialize (Builder); Display (Builder, "Connecting with " & Image (Address)); -- Initial handshake declare Master_Timestamp : Time_Stamp_Type; Version : Unbounded_String; Hash : Unbounded_String; Patterns : Unbounded_String; Is_Ping : Boolean; begin Get_Context (Builder.D.Channel, Builder.D.Target, Builder.D.Project_Name, Builder.D.Build_Env, Builder.Sync, Master_Timestamp, Version, Hash, Patterns, Is_Ping); -- Set included artifact patterns Display (Builder, "artifact patterns: " & To_String (Patterns), Is_Debug => True); String_Split.Create (Builder.D.Included_Artifact_Patterns, To_String (Patterns), Separators => ";"); if Is_Ping then Send_Ping_Response (Builder.D.Channel, GPR.Version.Gpr_Version_String, UTC_Time, Gprslave.Hash.all); Close_Builder (Builder, Ack => False); Display (Builder, "Ping response to " & Image (Address)); return; end if; Clock_Status := Check_Diff (Master_Timestamp, UTC_Time); if To_String (Version) /= GPR.Version.Gpr_Version_String (False) then Display (Builder, "Reject non compatible build for " & To_String (Builder.D.Project_Name)); Display (Builder, "builder version " & To_String (Version), Is_Debug => True); Display (Builder, "slave version " & GPR.Version.Gpr_Version_String (False), Is_Debug => True); Send_Ko (Builder.D.Channel); return; end if; if Builders.Working_Dir_Exists (Work_Directory (Builder)) then Display (Builder, "Cannot use the same build environment for " & To_String (Builder.D.Project_Name)); Send_Ko (Builder.D.Channel, "build environment " & To_String (Builder.D.Build_Env) & " already in use"); return; end if; -- If a hash has been specified, it must match the one from the -- master. if Gprslave.Hash /= null and then Gprslave.Hash.all /= To_String (Hash) then Display (Builder, "hash does not match " & To_String (Builder.D.Project_Name)); Send_Ko (Builder.D.Channel, "hash does not match, slave is " & Gprslave.Hash.all); return; end if; exception when E : others => -- Do not try to go further, just close the socket Close_Builder (Builder, Ack => False); Display (Builder, Exception_Information (E)); return; end; Display (Builder, "Handling project : " & To_String (Builder.D.Project_Name)); Display (Builder, "Compiling for : " & To_String (Builder.D.Target)); if Builder.Sync then Display (Builder, "Synchronization from master enabled"); else Display (Builder, "Synchronization from master disabled"); end if; -- Create slave environment if needed if not Exists (Work_Directory (Builder)) then begin Create_Path (Work_Directory (Builder)); exception when others => Send_Ko (Builder.D.Channel, "fail to create build environment directory: " & Work_Directory (Builder)); Close_Builder (Builder, Ack => False); Display (Builder, "failed to create build environment directory: " & Work_Directory (Builder), Force => True); return; end; Display (Builder, "create build environment directory: " & Work_Directory (Builder), Is_Debug => True); end if; -- Configure slave, note that this does not need to be into the critical -- section has the builder is not yet known in the system. At this point -- no compilation can be received for this slave anyway. Set_Rewrite_WD (Builder.D.Channel, Path => Work_Directory (Builder)); -- For Ada compilers, rewrite the root directory if Compiler_Path = null then Display (Builder, "compiler path is null.", Is_Debug => True); else declare C_Path : constant String := Containing_Directory (Containing_Directory (Compiler_Path.all)); begin Display (Builder, "compiler path is : " & C_Path, Is_Debug => True); Set_Rewrite_CD (Builder.D.Channel, Path => C_Path); end; end if; -- It is safe to write to this builder outside of a lock here as this -- builder is not yet registered into the slave. begin Send_Slave_Config (Builder.D.Channel, Max_Processes, Compose (Root_Directory.all, To_String (Builder.D.Build_Env)), Clock_Status); exception when others => -- build master has aborted, do not try to go further, -- just close the socket. Close_Builder (Builder, Ack => False); end; -- If we are using the Gpr synchronisation, it is time to do it here. -- Note that we want to avoid the rewriting rules below that are -- requiring some CPU cycles not needed at this stage. if Sock (Builder) /= No_Socket then if Builder.Sync then Sync_Gpr (Builder); end if; -- Register the new builder Builders.Insert (Builder); end if; exception when E : others => Display (Builder, "Unrecoverable error: Wait_For_Master.", Force => True); Display (Builder, Symbolic_Traceback (E), Force => True); OS_Exit (1); end Wait_For_Master; -------------------- -- Work_Directory -- -------------------- function Work_Directory (Builder : Build_Master) return String is begin return Compose (Compose (Root_Directory.all, To_String (Builder.D.Build_Env)), To_String (Builder.D.Project_Name)); end Work_Directory; begin Parse_Command_Line; -- Initialize the project support Snames.Initialize; Parse_Knowledge_Base (Base, Default_Knowledge_Base_Directory); Activate_Symbolic_Traceback; -- Always create the lib/object directories on the slave, this is needed -- when parsing a projet file to retrieve a specific driver. Opt.Create_Dirs := Create_All_Dirs; -- Setup the response handlers if Max_Responses < 1 then Max_Responses := 1; elsif Max_Responses > Max_Processes then Max_Responses := Max_Processes; end if; Response_Handlers := new Response_Handler_Set (1 .. Max_Responses); -- Wait for a gprbuild connection on any addresses Address.Addr := Any_Inet_Addr; Address.Port := Port_Type (Port); Create_Socket (Server); Set_Socket_Option (Server, Socket_Level, (Reuse_Address, True)); Bind_Socket (Server, Address); if Port = 0 then Address := Get_Socket_Name (Server); end if; Put_Line ("GPRSLAVE " & Version.Gpr_Version_String & " on " & Host_Name & ":" & Image (Long_Integer (Address.Port))); Put_Line (" max processes :" & Integer'Image (Max_Processes)); Put_Line (" max responses :" & Integer'Image (Max_Responses)); -- Initialize the host key used to create unique pid Slave_Id := Get_Slave_Id; Display ("slave id " & Image (Slave_Id), Is_Debug => True); Listen_Socket (Server); Main_Loop : loop Wait_For_Master; end loop Main_Loop; exception when E : others => Display ("Unrecoverable error: GprSlave.", Force => True); Display (Symbolic_Traceback (E), Force => True); OS_Exit (1); end Gprslave; gprbuild-25.0.0/src/gprslave.ads000066400000000000000000000025241470075373400165260ustar00rootroot00000000000000------------------------------------------------------------------------------ -- -- -- GPR TECHNOLOGY -- -- -- -- Copyright (C) 2012-2023, AdaCore -- -- -- -- This is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. This software is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- -- TABILITY 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 GNAT; see file COPYING. If not, -- -- see . -- -- -- ------------------------------------------------------------------------------ procedure Gprslave;