pax_global_header00006660000000000000000000000064146437433430014525gustar00rootroot0000000000000052 comment=10ea9f5da1d2ef066b1413e6049acbbc2ad94616 gnatcoll-bindings-25.0.0/000077500000000000000000000000001464374334300152075ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/.gitattributes000066400000000000000000000015561464374334300201110ustar00rootroot00000000000000testsuite/*/*/* no-precommit-check testsuite/*/*/*/* no-precommit-check testsuite/*/*/*/*/* no-precommit-check python3/tests/*/*/* no-precommit-check python3/tests/*/* no-precommit-check python3/tests/* no-precommit-check # Third-party package src/getRSS.c no-precommit-check src/sqlite/amalgamation/* no-precommit-check src/dborm.py no-precommit-check src/xref.generated/* no-precommit-check distrib/gnatcoll/runtime.py no-precommit-check # ??? Workaround bug in style checker, which complains that # Finalization_Size is an unrecognized attribute src/gnatcoll-storage_pools-headers.adb no-precommit-check gnatcoll-bindings-25.0.0/.gitignore000066400000000000000000000004221464374334300171750ustar00rootroot00000000000000makefile.setup gnat/ docs/_build *.cgpr b__* *.bexch *.a *.d gnatinspect.* obj/ lib/ install/ *.stdout *.stderr *.ali *.gli *.exe *.gcda *.gcno *.gcov *.bexch *.o *.deps *.pyc setup.json /gnat_src */docs/_build examples/library/obj out /testsuite/prod /testsuite/gcov gnatcoll-bindings-25.0.0/.gitlab-ci.yml000066400000000000000000000026061464374334300176470ustar00rootroot00000000000000workflow: rules: - if: $CI_PIPELINE_SOURCE == "merge_request_event" when: always - if: $CI_PIPELINE_SOURCE == "schedule" when: always - if: $CI_PIPELINE_SOURCE == "web" when: always - when: never stages: - build default: before_script: | echo "before script executing..." ####################### ## colored execution ## ####################### exec() { # dark green + $ + command line + grey echo -e "\e[0;32m\$ $@\e[0;37m" $@ # save the result res=$? # back to normal output echo -e -n "\e[0m" # make sure we translate the exit code return $res } # Enable generic CI for building with Anod cmd="generic_anod_ci" # generic anod ci requires --continuous-builder-mode when not run in a # MR context if [[ $CI_PIPELINE_SOURCE != "merge_request_event" ]]; then cmd="$cmd --continuous-builder-mode" fi exec eval $cmd echo "sourcing the generic CI environment" . /tmp/ci_env.sh exec anod vcs --list ######## # JOBS # ######## build_and_test: services: - image:e3 - cpu:2 stage: build interruptible: true parallel: matrix: - PYTHON: ["3.9", "3.10", "3.11", "3.12"] script: - anod test --latest gnatcoll-bindings -Qpython=$PYTHON - testsuite_reports artifacts: reports: junit: xunit-*.xml gnatcoll-bindings-25.0.0/.gitreview000066400000000000000000000001521464374334300172130ustar00rootroot00000000000000[gerrit] host = git.adacore.com project = gnatcoll-bindings defaultbranch = master defaultremote = origin gnatcoll-bindings-25.0.0/COPYING.RUNTIME000066400000000000000000000064601464374334300173720ustar00rootroot00000000000000GCC 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. gnatcoll-bindings-25.0.0/COPYING3000066400000000000000000001045131464374334300163310ustar00rootroot00000000000000 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 . gnatcoll-bindings-25.0.0/README.md000066400000000000000000000041151464374334300164670ustar00rootroot00000000000000The GNAT Components Collection (GNATcoll) - Bindings ==================================================== This is the bindings module of the GNAT Components Collection. Please refer to individual components for more details. Dependencies ------------ This module depends on the following external components, that should be available on your system: - GPRbuild - gnatcoll-core - As well as relevant third-party libraries you need to build bindings for. Building -------- The components of GNATcoll Bindings are built using standalone GPR project files. To build each of them you can simply do: ```sh $ gprbuild -P /gnatcoll-.gpr ``` However, this method has several limitations: * it builds one version of the library (static, relocatable and static-pic) at a time * it might depend on the environment (`C_INCLUDE_PATH`, `LIBRARY_PATH`, ...) In order to simplify that process, each component contains a Python script called `setup.py`. Each script provides the following subcommands: `build`, `install`, `clean`, `uninstall`. On the first call to `build`, the user can setup some preferences. You can do `setup.py build --help` to get the list of available options for each module. After first call previous preferences will be reused unless you use the `--reconfigure` switch. Note that you can perform an out-of-source-tree build by just invoking `setup.py` from another directory. Installing ---------- In order to install a given component, either call `gprinstall` or use `setup.py` script: ```sh $ setup.py install --prefix=some_path ``` Note that if `--prefix` is not used, then projects will be installed into the location of the used compiler. Bindings -------- The following bindings are provided: - [gmp](gmp/README.md) - [iconv](iconv/README.md) - lzma - [omp](omp/README.md) - [python](python/README.md) - [python3](python3/README.md) - [readline](readline/README.md) - [syslog](syslog/README.md) Bug reports ----------- Please send questions and bug reports to report@adacore.com following the same procedures used to submit reports with the GNAT toolset itself. gnatcoll-bindings-25.0.0/cpp/000077500000000000000000000000001464374334300157715ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/cpp/cpp_string_support.cpp000066400000000000000000000331701464374334300224450ustar00rootroot00000000000000/**************************************************************************** * G N A T C O L L * * * * Copyright (C) 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 * * . * * * ****************************************************************************/ /* Provide helper functions to implement in GNATCOLL.CPP.Strings a wrapper of the C++ ISO/IEC 14882:1998(E) string class. */ #include using namespace std; struct CPP_String { string *str; }; extern "C" void gnatcoll_cpp_append_string (CPP_String* s, const CPP_String* text) { (s->str) -> append(*(text->str)); } extern "C" void gnatcoll_cpp_append_substring (CPP_String* s, const CPP_String* text, size_t subpos, size_t sublen) { (s->str) -> append(*(text->str), subpos, sublen); } extern "C" void gnatcoll_cpp_append_text (CPP_String* s, const char* text) { (s->str) -> append(text); } extern "C" void gnatcoll_cpp_append_buffer (CPP_String* s, const char* text, size_t n) { (s->str) -> append(text, n); } extern "C" void gnatcoll_cpp_append_fill (CPP_String* s, size_t n, char c) { (s->str) -> append(n, c); } extern "C" void gnatcoll_cpp_assign_string (CPP_String* s, const CPP_String* text) { *(s->str) = *(text->str); } extern "C" void gnatcoll_cpp_assign_text (CPP_String* s, const char* text) { *(s->str) = text; } extern "C" void gnatcoll_cpp_assign_char (CPP_String* s, const char c) { *(s->str) = c; } extern "C" size_t gnatcoll_cpp_capacity (CPP_String* s) { return (s->str) -> capacity(); } extern "C" char gnatcoll_cpp_char_at (CPP_String* s, size_t pos) { return ((s->str) -> at(pos)); } extern "C" int gnatcoll_cpp_compare (CPP_String* left, CPP_String* right) { return (left->str) -> compare(*(right->str)); } extern "C" int gnatcoll_cpp_compare_with_substring (CPP_String* left, size_t pos, size_t len, CPP_String *right) { return (left->str) -> compare(pos, len, *(right->str)); } extern "C" int gnatcoll_cpp_compare_substrings (CPP_String* left, size_t pos, size_t len, CPP_String* right, size_t subpos, size_t sublen) { return (left->str) -> compare(pos, len, *(right->str), subpos, sublen); } extern "C" int gnatcoll_cpp_compare_with_text (CPP_String* left, const char* right) { return (left->str) -> compare(right); } extern "C" int gnatcoll_cpp_compare_substring_with_text (CPP_String* left, size_t pos, size_t len, const char* right) { return (left->str) -> compare(pos, len, right); } extern "C" int gnatcoll_cpp_compare_substring_with_buffer (CPP_String* left, size_t pos, size_t len, const char* right, size_t n) { return (left->str) -> compare(pos, len, right, n); } extern "C" void gnatcoll_cpp_clear (CPP_String* s) { (s->str) -> clear(); } extern "C" void gnatcoll_cpp_copy (CPP_String* s, char* to_str, size_t len, size_t pos, size_t* num_bytes) { *num_bytes = (s->str) -> copy(to_str, len, pos); } extern "C" const char* gnatcoll_cpp_c_str (CPP_String* s) { return (s->str) -> c_str(); } extern "C" const char* gnatcoll_cpp_data (CPP_String* s) { return (s->str) -> data(); } extern "C" void gnatcoll_cpp_destroy (CPP_String* s) { free (s->str); } extern "C" bool gnatcoll_cpp_empty (CPP_String* s) { return (s->str) -> empty(); } extern "C" void gnatcoll_cpp_erase_sequence (CPP_String* s, size_t pos, size_t len) { (s->str) -> erase(pos, len); } extern "C" size_t gnatcoll_cpp_find_first_not_of_string (CPP_String* s, const CPP_String* text, size_t pos) { return (s->str) -> find_first_not_of(*(text->str), pos); } extern "C" size_t gnatcoll_cpp_find_first_not_of_text (CPP_String* s, const char* text, size_t pos) { return (s->str) -> find_first_not_of(text, pos); } extern "C" size_t gnatcoll_cpp_find_first_not_of_buffer (CPP_String* s, const char* text, size_t pos, size_t n) { return (s->str) -> find_first_not_of(text, pos, n); } extern "C" size_t gnatcoll_cpp_find_first_not_of_char (CPP_String* s, char c, size_t pos) { return (s->str) -> find_first_not_of(c, pos); } extern "C" size_t gnatcoll_cpp_find_first_of_string (CPP_String* s, const CPP_String* text, size_t pos) { return (s->str) -> find_first_of(*(text->str), pos); } extern "C" size_t gnatcoll_cpp_find_first_of_text (CPP_String* s, const char* text, size_t pos) { return (s->str) -> find_first_of(text, pos); } extern "C" size_t gnatcoll_cpp_find_first_of_buffer (CPP_String* s, const char* text, size_t pos, size_t n) { return (s->str) -> find_first_of(text, pos, n); } extern "C" size_t gnatcoll_cpp_find_first_of_char (CPP_String* s, char c, size_t pos) { return (s->str) -> find_first_of(c, pos); } extern "C" size_t gnatcoll_cpp_find_last_not_of_string (CPP_String* s, const CPP_String* text, size_t pos) { return (s->str) -> find_last_not_of(*(text->str), pos); } extern "C" size_t gnatcoll_cpp_find_last_not_of_text (CPP_String* s, const char* text, size_t pos) { return (s->str) -> find_last_not_of(text, pos); } extern "C" size_t gnatcoll_cpp_find_last_not_of_buffer (CPP_String* s, const char* text, size_t pos, size_t n) { return (s->str) -> find_last_not_of(text, pos, n); } extern "C" size_t gnatcoll_cpp_find_last_not_of_char (CPP_String* s, char c, size_t pos) { return (s->str) -> find_last_not_of(c, pos); } extern "C" size_t gnatcoll_cpp_find_last_of_string (CPP_String* s, const CPP_String* text, size_t pos) { return (s->str) -> find_last_of(*(text->str), pos); } extern "C" size_t gnatcoll_cpp_find_last_of_text (CPP_String* s, const char* text, size_t pos) { return (s->str) -> find_last_of(text, pos); } extern "C" size_t gnatcoll_cpp_find_last_of_buffer (CPP_String* s, const char* text, size_t pos, size_t n) { return (s->str) -> find_last_of(text, pos, n); } extern "C" size_t gnatcoll_cpp_find_last_of_char (CPP_String* s, char c, size_t pos) { return (s->str) -> find_last_of(c, pos); } extern "C" size_t gnatcoll_cpp_find_string (CPP_String* s, const CPP_String* text, size_t pos) { return (s->str) -> find(*(text->str), pos); } extern "C" size_t gnatcoll_cpp_find_text (CPP_String* s, const char* text, size_t pos) { return (s->str) -> find(text, pos); } extern "C" size_t gnatcoll_cpp_find_buffer (CPP_String* s, const char* text, size_t pos, size_t n) { return (s->str) -> find(text, pos, n); } extern "C" size_t gnatcoll_cpp_find_char (CPP_String* s, char c, size_t pos) { return (s->str) -> find(c, pos); } extern "C" void gnatcoll_cpp_init (CPP_String* s) { s->str = new std::string(); } extern "C" void gnatcoll_cpp_init_with_fill (CPP_String* s, size_t n, char c) { s->str = new std::string(n,c); } extern "C" void gnatcoll_cpp_init_with_text (CPP_String* s, const char* text) { s->str = new std::string(text); } extern "C" void gnatcoll_cpp_insert_string (CPP_String* s, size_t pos, const CPP_String* text) { (s->str) -> insert(pos, *(text->str)); } extern "C" void gnatcoll_cpp_insert_substring (CPP_String* s, size_t pos, const CPP_String* text, size_t subpos, size_t sublen) { (s->str) -> insert(pos, *(text->str), subpos, sublen); } extern "C" void gnatcoll_cpp_insert_text (CPP_String* s, size_t pos, const char *text) { (s->str) -> insert(pos, text); } extern "C" void gnatcoll_cpp_insert_buffer (CPP_String* s, size_t pos, const char *text, size_t n) { (s->str) -> insert(pos, text, n); } extern "C" void gnatcoll_cpp_insert_fill (CPP_String* s, size_t pos, size_t n, char c) { (s->str) -> insert(pos, n, c); } extern "C" size_t gnatcoll_cpp_length (CPP_String* s) { return (s->str) -> length(); } extern "C" size_t gnatcoll_cpp_max_size (CPP_String* s) { return (s->str) -> max_size(); } extern "C" size_t gnatcoll_cpp_npos() { return string::npos; } extern "C" void gnatcoll_cpp_pop_back (CPP_String* s) { (s->str) -> pop_back(); } extern "C" void gnatcoll_cpp_push_back (CPP_String* s, char c) { (s->str) -> push_back(c); } extern "C" void gnatcoll_cpp_replace_string (CPP_String* s, size_t pos, size_t len, const CPP_String* text) { (s->str) -> replace(pos, len, *(text->str)); } extern "C" void gnatcoll_cpp_replace_substring (CPP_String* s, size_t pos, size_t len, const CPP_String* text, size_t subpos, size_t sublen) { (s->str) -> replace(pos, len, *(text->str), subpos, sublen); } extern "C" void gnatcoll_cpp_replace_text (CPP_String* s, size_t pos, size_t len, const char *text) { (s->str) -> replace(pos, len, text); } extern "C" void gnatcoll_cpp_replace_buffer (CPP_String* s, size_t pos, size_t len, const char *text, size_t n) { (s->str) -> replace(pos, len, text, n); } extern "C" void gnatcoll_cpp_replace_fill (CPP_String* s, size_t pos, size_t len, size_t n, char c) { (s->str) -> replace(pos, len, n, c); } extern "C" void gnatcoll_cpp_reserve (CPP_String* s, size_t n) { (s->str) -> reserve(n); } extern "C" void gnatcoll_cpp_resize (CPP_String* s, size_t n) { (s->str) -> resize(n); } extern "C" void gnatcoll_cpp_resize_with_fill (CPP_String* s, size_t n, char c) { (s->str) -> resize(n,c); } extern "C" size_t gnatcoll_cpp_reverse_find_string (CPP_String* s, const CPP_String* text, size_t pos) { return (s->str) -> rfind(*(text->str), pos); } extern "C" size_t gnatcoll_cpp_reverse_find_text (CPP_String* s, const char* text, size_t pos) { return (s->str) -> rfind(text, pos); } extern "C" size_t gnatcoll_cpp_reverse_find_buffer (CPP_String* s, const char* text, size_t pos, size_t n) { return (s->str) -> rfind(text, pos, n); } extern "C" size_t gnatcoll_cpp_reverse_find_char (CPP_String* s, char c, size_t pos) { return (s->str) -> rfind(c, pos); } extern "C" size_t gnatcoll_cpp_size (CPP_String* s) { return (s->str) -> size(); } extern "C" void gnatcoll_cpp_substr (CPP_String* result, CPP_String* s, size_t pos, size_t len) { std::string aux = (s->str) -> substr(pos, len); const char* text = aux.c_str(); gnatcoll_cpp_init_with_text(result, text); } extern "C" void gnatcoll_cpp_swap_strings (CPP_String* s1, CPP_String* s2) { (s1->str) -> swap (*(s2->str)); } // Relational Operators // ******************** extern "C" bool gnatcoll_cpp_eq_strings (CPP_String* left, CPP_String* right) { return *(left->str) == *(right->str); } extern "C" bool gnatcoll_cpp_eq_text_string (const char* left, CPP_String* right) { return left == *(right->str); } extern "C" bool gnatcoll_cpp_eq_string_text (CPP_String* left, const char* right) { return *(left->str) == right; } extern "C" bool gnatcoll_cpp_lt_strings (CPP_String* left, CPP_String* right) { return *(left->str) < *(right->str); } extern "C" bool gnatcoll_cpp_lt_text_string (const char* left, CPP_String* right) { return left < *(right->str); } extern "C" bool gnatcoll_cpp_lt_string_text (CPP_String* left, const char* right) { return *(left->str) < right; } extern "C" bool gnatcoll_cpp_le_strings (CPP_String* left, CPP_String* right) { return *(left->str) <= *(right->str); } extern "C" bool gnatcoll_cpp_le_text_string (const char* left, CPP_String* right) { return left <= *(right->str); } extern "C" bool gnatcoll_cpp_le_string_text (CPP_String* left, const char* right) { return *(left->str) <= right; } extern "C" bool gnatcoll_cpp_gt_strings (CPP_String* left, CPP_String* right) { return *(left->str) > *(right->str); } extern "C" bool gnatcoll_cpp_gt_text_string (const char* left, CPP_String* right) { return left > *(right->str); } extern "C" bool gnatcoll_cpp_gt_string_text (CPP_String* left, const char* right) { return *(left->str) > right; } extern "C" bool gnatcoll_cpp_ge_strings (CPP_String* left, CPP_String* right) { return *(left->str) >= *(right->str); } extern "C" bool gnatcoll_cpp_ge_text_string (const char* left, CPP_String* right) { return left >= *(right->str); } extern "C" bool gnatcoll_cpp_ge_string_text (CPP_String* left, const char* right) { return *(left->str) >= right; } gnatcoll-bindings-25.0.0/cpp/gnatcoll-cpp-strings.adb000066400000000000000000001201631464374334300225160ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with Interfaces.C.Extensions; package body GNATCOLL.CPP.Strings is use Interfaces.C; use Interfaces.C.Extensions; use Interfaces.C.Strings; use System; package External is procedure Append_String (Str : in out CPP_String; Text : CPP_String); pragma Import (C, Append_String, "gnatcoll_cpp_append_string"); procedure Append_Substring (Str : in out CPP_String; Text : CPP_String; Subpos : size_t; Sublen : size_t); pragma Import (C, Append_Substring, "gnatcoll_cpp_append_substring"); procedure Append_Text (Str : in out CPP_String; Text : chars_ptr); pragma Import (C, Append_Text, "gnatcoll_cpp_append_text"); procedure Append_Buffer (Str : in out CPP_String; Text : chars_ptr; N : size_t); pragma Import (C, Append_Buffer, "gnatcoll_cpp_append_buffer"); procedure Append_Fill (Str : in out CPP_String; N : size_t; C : Character); pragma Import (C, Append_Fill, "gnatcoll_cpp_append_fill"); procedure Assign_String (Str : in out CPP_String; Text : CPP_String); pragma Import (C, Assign_String, "gnatcoll_cpp_assign_string"); procedure Assign_Text (Str : in out CPP_String; Text : chars_ptr); pragma Import (C, Assign_Text, "gnatcoll_cpp_assign_text"); procedure Assign_Char (Str : in out CPP_String; C : Character); pragma Import (C, Assign_Char, "gnatcoll_cpp_assign_char"); function Capacity (Str : CPP_String) return size_t; pragma Import (C, Capacity, "gnatcoll_cpp_capacity"); function Char_At (Str : CPP_String; Pos : size_t) return Character; pragma Import (C, Char_At, "gnatcoll_cpp_char_at"); procedure Clear (Str : in out CPP_String); pragma Import (C, Clear, "gnatcoll_cpp_clear"); function Compare (Left : CPP_String; Right : CPP_String) return Integer; pragma Import (C, Compare, "gnatcoll_cpp_compare"); function Compare_With_Substring (Left : CPP_String; Pos : size_t; Len : size_t; Right : CPP_String) return Integer; pragma Import (C, Compare_With_Substring, "gnatcoll_cpp_compare_with_substring"); function Compare_Substrings (Left : CPP_String; Pos : size_t; Len : size_t; Right : CPP_String; Subpos : size_t; Sublen : size_t) return Integer; pragma Import (C, Compare_Substrings, "gnatcoll_cpp_compare_substrings"); function Compare_With_Text (Left : CPP_String; Right : chars_ptr) return Integer; pragma Import (C, Compare_With_Text, "gnatcoll_cpp_compare_with_text"); function Compare_Substring_With_Text (Left : CPP_String; Pos : size_t; Len : size_t; Right : chars_ptr) return Integer; pragma Import (C, Compare_Substring_With_Text, "gnatcoll_cpp_compare_substring_with_text"); function Compare_Substring_With_Buffer (Left : CPP_String; Pos : size_t; Len : size_t; Right : chars_ptr; N : size_t) return Integer; pragma Import (C, Compare_Substring_With_Buffer, "gnatcoll_cpp_compare_substring_with_buffer"); procedure Copy (From_Str : CPP_String; To_Str : chars_ptr; Len : size_t; Pos : size_t; Num_Chars : access size_t); pragma Import (C, Copy, "gnatcoll_cpp_copy"); function C_Str (Str : CPP_String) return chars_ptr; pragma Import (C, C_Str, "gnatcoll_cpp_c_str"); function Data (Str : CPP_String) return chars_ptr; pragma Import (C, Data, "gnatcoll_cpp_data"); procedure Destroy (Str : in out CPP_String); pragma Import (C, Destroy, "gnatcoll_cpp_destroy"); function Empty (Str : CPP_String) return bool; pragma Import (C, Empty, "gnatcoll_cpp_empty"); procedure Erase_Sequence (Str : in out CPP_String; Pos : size_t; Len : size_t); pragma Import (C, Erase_Sequence, "gnatcoll_cpp_erase_sequence"); function Find_String (Str : CPP_String; Text : CPP_String; Pos : size_t) return size_t; pragma Import (C, Find_String, "gnatcoll_cpp_find_string"); function Find_Text (Str : CPP_String; Text : chars_ptr; Pos : size_t) return size_t; pragma Import (C, Find_Text, "gnatcoll_cpp_find_text"); function Find_Buffer (Str : CPP_String; Text : chars_ptr; Pos : size_t; N : size_t) return size_t; pragma Import (C, Find_Buffer, "gnatcoll_cpp_find_buffer"); function Find_Char (Str : CPP_String; C : Character; Pos : size_t) return size_t; pragma Import (C, Find_Char, "gnatcoll_cpp_find_char"); function Find_First_Not_Of_String (Str : CPP_String; Text : CPP_String; Pos : size_t) return size_t; pragma Import (C, Find_First_Not_Of_String, "gnatcoll_cpp_find_first_not_of_string"); function Find_First_Not_Of_Text (Str : CPP_String; Text : chars_ptr; Pos : size_t) return size_t; pragma Import (C, Find_First_Not_Of_Text, "gnatcoll_cpp_find_first_not_of_text"); function Find_First_Not_Of_Buffer (Str : CPP_String; Text : chars_ptr; Pos : size_t; N : size_t) return size_t; pragma Import (C, Find_First_Not_Of_Buffer, "gnatcoll_cpp_find_first_not_of_buffer"); function Find_First_Not_Of_Char (Str : CPP_String; C : Character; Pos : size_t) return size_t; pragma Import (C, Find_First_Not_Of_Char, "gnatcoll_cpp_find_first_not_of_char"); function Find_First_Of_String (Str : CPP_String; Text : CPP_String; Pos : size_t) return size_t; pragma Import (C, Find_First_Of_String, "gnatcoll_cpp_find_first_of_string"); function Find_First_Of_Text (Str : CPP_String; Text : chars_ptr; Pos : size_t) return size_t; pragma Import (C, Find_First_Of_Text, "gnatcoll_cpp_find_first_of_text"); function Find_First_Of_Buffer (Str : CPP_String; Text : chars_ptr; Pos : size_t; N : size_t) return size_t; pragma Import (C, Find_First_Of_Buffer, "gnatcoll_cpp_find_first_of_buffer"); function Find_First_Of_Char (Str : CPP_String; C : Character; Pos : size_t) return size_t; pragma Import (C, Find_First_Of_Char, "gnatcoll_cpp_find_first_of_char"); function Find_Last_Not_Of_String (Str : CPP_String; Text : CPP_String; Pos : size_t) return size_t; pragma Import (C, Find_Last_Not_Of_String, "gnatcoll_cpp_find_last_not_of_string"); function Find_Last_Not_Of_Text (Str : CPP_String; Text : chars_ptr; Pos : size_t) return size_t; pragma Import (C, Find_Last_Not_Of_Text, "gnatcoll_cpp_find_last_not_of_text"); function Find_Last_Not_Of_Buffer (Str : CPP_String; Text : chars_ptr; Pos : size_t; N : size_t) return size_t; pragma Import (C, Find_Last_Not_Of_Buffer, "gnatcoll_cpp_find_last_not_of_buffer"); function Find_Last_Not_Of_Char (Str : CPP_String; C : Character; Pos : size_t) return size_t; pragma Import (C, Find_Last_Not_Of_Char, "gnatcoll_cpp_find_last_not_of_char"); function Find_Last_Of_String (Str : CPP_String; Text : CPP_String; Pos : size_t) return size_t; pragma Import (C, Find_Last_Of_String, "gnatcoll_cpp_find_last_of_string"); function Find_Last_Of_Text (Str : CPP_String; Text : chars_ptr; Pos : size_t) return size_t; pragma Import (C, Find_Last_Of_Text, "gnatcoll_cpp_find_last_of_text"); function Find_Last_Of_Buffer (Str : CPP_String; Text : chars_ptr; Pos : size_t; N : size_t) return size_t; pragma Import (C, Find_Last_Of_Buffer, "gnatcoll_cpp_find_last_of_buffer"); function Find_Last_Of_Char (Str : CPP_String; C : Character; Pos : size_t) return size_t; pragma Import (C, Find_Last_Of_Char, "gnatcoll_cpp_find_last_of_char"); procedure Init (Str : in out CPP_String); pragma Import (C, Init, "gnatcoll_cpp_init"); procedure Init_With_Text (Str : in out CPP_String; Text : chars_ptr); pragma Import (C, Init_With_Text, "gnatcoll_cpp_init_with_text"); procedure Init_With_Fill (Str : in out CPP_String; N : size_t; C : Character); pragma Import (C, Init_With_Fill, "gnatcoll_cpp_init_with_fill"); procedure Insert_String (Str : in out CPP_String; Pos : size_t; Text : CPP_String); pragma Import (C, Insert_String, "gnatcoll_cpp_insert_string"); procedure Insert_Substring (Str : in out CPP_String; Pos : size_t; Text : CPP_String; Subpos : size_t; Sublen : size_t); pragma Import (C, Insert_Substring, "gnatcoll_cpp_insert_substring"); procedure Insert_Text (Str : in out CPP_String; Pos : size_t; Text : chars_ptr); pragma Import (C, Insert_Text, "gnatcoll_cpp_insert_text"); procedure Insert_Buffer (Str : in out CPP_String; Pos : size_t; Text : chars_ptr; N : size_t); pragma Import (C, Insert_Buffer, "gnatcoll_cpp_insert_buffer"); procedure Insert_Fill (Str : in out CPP_String; Pos : size_t; N : size_t; C : Character); pragma Import (C, Insert_Fill, "gnatcoll_cpp_insert_fill"); function Length (Str : CPP_String) return size_t; pragma Import (C, Length, "gnatcoll_cpp_length"); function Max_Size (Str : CPP_String) return size_t; pragma Import (C, Max_Size, "gnatcoll_cpp_max_size"); function Npos return size_t; pragma Import (C, Npos, "gnatcoll_cpp_npos"); procedure Pop_Back (Str : in out CPP_String); pragma Import (C, Pop_Back, "gnatcoll_cpp_pop_back"); procedure Push_Back (Str : in out CPP_String; C : Character); pragma Import (C, Push_Back, "gnatcoll_cpp_push_back"); procedure Replace_String (Str : in out CPP_String; Pos : size_t; Len : size_t; Text : CPP_String); pragma Import (C, Replace_String, "gnatcoll_cpp_replace_string"); procedure Replace_Substring (Str : in out CPP_String; Pos : size_t; Len : size_t; Text : CPP_String; Subpos : size_t; Sublen : size_t); pragma Import (C, Replace_Substring, "gnatcoll_cpp_replace_substring"); procedure Replace_Text (Str : in out CPP_String; Pos : size_t; Len : size_t; Text : chars_ptr); pragma Import (C, Replace_Text, "gnatcoll_cpp_replace_text"); procedure Replace_Buffer (Str : in out CPP_String; Pos : size_t; Len : size_t; Text : chars_ptr; N : size_t); pragma Import (C, Replace_Buffer, "gnatcoll_cpp_replace_buffer"); procedure Replace_Fill (Str : in out CPP_String; Pos : size_t; Len : size_t; N : size_t; C : Character); pragma Import (C, Replace_Fill, "gnatcoll_cpp_replace_fill"); procedure Reserve (Str : in out CPP_String; N : size_t := 0); pragma Import (C, Reserve, "gnatcoll_cpp_reserve"); procedure Resize (Str : in out CPP_String; N : size_t); pragma Import (C, Resize, "gnatcoll_cpp_resize"); procedure Resize_And_Fill (Str : in out CPP_String; N : size_t; C : Character); pragma Import (C, Resize_And_Fill, "gnatcoll_cpp_resize_with_fill"); function Reverse_Find_String (Str : CPP_String; Text : CPP_String; Pos : size_t) return size_t; pragma Import (C, Reverse_Find_String, "gnatcoll_cpp_reverse_find_string"); function Reverse_Find_Text (Str : CPP_String; Text : chars_ptr; Pos : size_t) return size_t; pragma Import (C, Reverse_Find_Text, "gnatcoll_cpp_reverse_find_text"); function Reverse_Find_Buffer (Str : CPP_String; Text : chars_ptr; Pos : size_t; N : size_t) return size_t; pragma Import (C, Reverse_Find_Buffer, "gnatcoll_cpp_reverse_find_buffer"); function Reverse_Find_Char (Str : CPP_String; C : Character; Pos : size_t) return size_t; pragma Import (C, Reverse_Find_Char, "gnatcoll_cpp_reverse_find_char"); function Size (Str : CPP_String) return size_t; pragma Import (C, Size, "gnatcoll_cpp_size"); procedure Substr (Result : in out CPP_String; Str : CPP_String; Pos : size_t := 0; Len : size_t := Npos); pragma Import (C, Substr, "gnatcoll_cpp_substr"); procedure Swap (Str : in out CPP_String; Text : in out CPP_String); pragma Import (C, Swap, "gnatcoll_cpp_swap_strings"); -------------------------- -- Relational_Operators -- -------------------------- function Eq_String (Left : CPP_String; Right : CPP_String) return bool; pragma Import (C, Eq_String, "gnatcoll_cpp_eq_strings"); function Eq_Text_String (Left : chars_ptr; Right : CPP_String) return bool; pragma Import (C, Eq_Text_String, "gnatcoll_cpp_eq_text_string"); function Eq_String_Text (Left : CPP_String; Right : chars_ptr) return bool; pragma Import (C, Eq_String_Text, "gnatcoll_cpp_eq_string_text"); function Lt_String (Left : CPP_String; Right : CPP_String) return bool; pragma Import (C, Lt_String, "gnatcoll_cpp_lt_strings"); function Lt_Text_String (Left : chars_ptr; Right : CPP_String) return bool; pragma Import (C, Lt_Text_String, "gnatcoll_cpp_lt_text_string"); function Lt_String_Text (Left : CPP_String; Right : chars_ptr) return bool; pragma Import (C, Lt_String_Text, "gnatcoll_cpp_lt_string_text"); function Le_String (Left : CPP_String; Right : CPP_String) return bool; pragma Import (C, Le_String, "gnatcoll_cpp_le_strings"); function Le_Text_String (Left : chars_ptr; Right : CPP_String) return bool; pragma Import (C, Le_Text_String, "gnatcoll_cpp_le_text_string"); function Le_String_Text (Left : CPP_String; Right : chars_ptr) return bool; pragma Import (C, Le_String_Text, "gnatcoll_cpp_le_string_text"); function Gt_String (Left : CPP_String; Right : CPP_String) return bool; pragma Import (C, Gt_String, "gnatcoll_cpp_gt_strings"); function Gt_Text_String (Left : chars_ptr; Right : CPP_String) return bool; pragma Import (C, Gt_Text_String, "gnatcoll_cpp_gt_text_string"); function Gt_String_Text (Left : CPP_String; Right : chars_ptr) return bool; pragma Import (C, Gt_String_Text, "gnatcoll_cpp_gt_string_text"); function Ge_String (Left : CPP_String; Right : CPP_String) return bool; pragma Import (C, Ge_String, "gnatcoll_cpp_ge_strings"); function Ge_Text_String (Left : chars_ptr; Right : CPP_String) return bool; pragma Import (C, Ge_Text_String, "gnatcoll_cpp_ge_text_string"); function Ge_String_Text (Left : CPP_String; Right : chars_ptr) return bool; pragma Import (C, Ge_String_Text, "gnatcoll_cpp_ge_string_text"); end External; procedure Check_Non_Null (Str : CPP_String); -- Raise Constraint_Error if Str is not initialized. ------------ -- Append -- ------------ procedure Append (Str : in out CPP_String; Text : String) is C_Text : chars_ptr := New_String (Text); begin Check_Non_Null (Str); External.Append_Text (Str, C_Text); Free (C_Text); end Append; procedure Append (Str : in out CPP_String; Text : CPP_String) is begin Check_Non_Null (Str); Check_Non_Null (Text); External.Append_String (Str, Text); end Append; procedure Append (Str : in out CPP_String; Text : CPP_String; Subpos : size_t; Sublen : size_t) is begin Check_Non_Null (Str); Check_Non_Null (Text); External.Append_Substring (Str, Text, Subpos, Sublen); end Append; procedure Append (Str : in out CPP_String; Text : chars_ptr) is begin Check_Non_Null (Str); External.Append_Text (Str, Text); end Append; procedure Append (Str : in out CPP_String; Text : chars_ptr; N : size_t) is begin Check_Non_Null (Str); External.Append_Buffer (Str, Text, N); end Append; procedure Append (Str : in out CPP_String; N : size_t; C : Character) is begin Check_Non_Null (Str); External.Append_Fill (Str, N, C); end Append; ------------ -- Assign -- ------------ procedure Assign (Str : in out CPP_String; Text : CPP_String) is begin Check_Non_Null (Str); Check_Non_Null (Text); External.Assign_String (Str, Text); end Assign; procedure Assign (Str : in out CPP_String; Text : String) is C_Text : chars_ptr := New_String (Text); begin Check_Non_Null (Str); Assign (Str, C_Text); Free (C_Text); end Assign; procedure Assign (Str : in out CPP_String; Text : chars_ptr) is begin Check_Non_Null (Str); External.Assign_Text (Str, Text); end Assign; procedure Assign (Str : in out CPP_String; C : Character) is begin Check_Non_Null (Str); External.Assign_Char (Str, C); end Assign; -------------- -- Capacity -- -------------- function Capacity (Str : CPP_String) return size_t is begin Check_Non_Null (Str); return External.Capacity (Str); end Capacity; ------------- -- Char_At -- ------------- function Char_At (Str : CPP_String; Pos : size_t) return Character is begin Check_Non_Null (Str); return External.Char_At (Str, Pos); end Char_At; -------------------- -- Check_Non_Null -- -------------------- procedure Check_Non_Null (Str : CPP_String) is begin if Str.Wrapped_String_Address = Null_Address then raise Constraint_Error; end if; end Check_Non_Null; ----------- -- Clear -- ----------- procedure Clear (Str : in out CPP_String) is begin Check_Non_Null (Str); External.Clear (Str); end Clear; ------------- -- Compare -- ------------- function Compare (Left : CPP_String; Right : CPP_String) return Integer is begin Check_Non_Null (Left); Check_Non_Null (Right); return External.Compare (Left, Right); end Compare; function Compare (Left : CPP_String; Pos : size_t; Len : size_t; Right : CPP_String) return Integer is begin Check_Non_Null (Left); Check_Non_Null (Right); return External.Compare_With_Substring (Left, Pos, Len, Right); end Compare; function Compare (Left : CPP_String; Pos : size_t; Len : size_t; Right : CPP_String; Subpos : size_t; Sublen : size_t) return Integer is begin Check_Non_Null (Left); Check_Non_Null (Right); return External.Compare_Substrings (Left, Pos, Len, Right, Subpos, Sublen); end Compare; function Compare (Left : CPP_String; Right : chars_ptr) return Integer is begin Check_Non_Null (Left); return External.Compare_With_Text (Left, Right); end Compare; function Compare (Left : CPP_String; Pos : size_t; Len : size_t; Right : chars_ptr) return Integer is begin Check_Non_Null (Left); return External.Compare_Substring_With_Text (Left, Pos, Len, Right); end Compare; function Compare (Left : CPP_String; Pos : size_t; Len : size_t; Right : chars_ptr; N : size_t) return Integer is begin Check_Non_Null (Left); return External.Compare_Substring_With_Buffer (Left, Pos, Len, Right, N); end Compare; ---------- -- Copy -- ---------- procedure Copy (From_Str : CPP_String; To_Str : chars_ptr; Len : size_t; Pos : size_t; Num_Chars : out size_t) is Result : aliased size_t; begin Check_Non_Null (From_Str); External.Copy (From_Str, To_Str, Len, Pos, Result'Access); Num_Chars := Result; end Copy; ----------- -- C_Str -- ----------- function C_Str (Str : CPP_String) return chars_ptr is begin Check_Non_Null (Str); return External.C_Str (Str); end C_Str; ---------- -- Data -- ---------- function Data (Str : CPP_String) return chars_ptr is begin Check_Non_Null (Str); return External.Data (Str); end Data; function Data (Str : CPP_String) return String is begin return Value (Data (Str)); end Data; ----------- -- Empty -- ----------- function Empty (Str : CPP_String) return Boolean is begin Check_Non_Null (Str); return External.Empty (Str) /= False; end Empty; ----------- -- Erase -- ----------- procedure Erase (Str : in out CPP_String; Pos : size_t := 0; Len : size_t := Npos) is begin Check_Non_Null (Str); External.Erase_Sequence (Str, Pos, Len); end Erase; ---------- -- Find -- ---------- function Find (Str : CPP_String; Text : CPP_String; Pos : size_t := 0) return size_t is begin Check_Non_Null (Str); Check_Non_Null (Text); return External.Find_String (Str, Text, Pos); end Find; function Find (Str : CPP_String; Text : chars_ptr; Pos : size_t := 0) return size_t is begin Check_Non_Null (Str); return External.Find_Text (Str, Text, Pos); end Find; function Find (Str : CPP_String; Text : chars_ptr; Pos : size_t; N : size_t) return size_t is begin Check_Non_Null (Str); return External.Find_Buffer (Str, Text, Pos, N); end Find; function Find (Str : CPP_String; C : Character; Pos : size_t := 0) return size_t is begin Check_Non_Null (Str); return External.Find_Char (Str, C, Pos); end Find; ----------------------- -- Find_First_Not_Of -- ----------------------- function Find_First_Not_Of (Str : CPP_String; Text : CPP_String; Pos : size_t := 0) return size_t is begin Check_Non_Null (Str); Check_Non_Null (Text); return External.Find_First_Not_Of_String (Str, Text, Pos); end Find_First_Not_Of; function Find_First_Not_Of (Str : CPP_String; Text : chars_ptr; Pos : size_t := 0) return size_t is begin Check_Non_Null (Str); return External.Find_First_Not_Of_Text (Str, Text, Pos); end Find_First_Not_Of; function Find_First_Not_Of (Str : CPP_String; Text : chars_ptr; Pos : size_t; N : size_t) return size_t is begin Check_Non_Null (Str); return External.Find_First_Not_Of_Buffer (Str, Text, Pos, N); end Find_First_Not_Of; function Find_First_Not_Of (Str : CPP_String; C : Character; Pos : size_t := 0) return size_t is begin Check_Non_Null (Str); return External.Find_First_Not_Of_Char (Str, C, Pos); end Find_First_Not_Of; ------------------- -- Find_First_Of -- ------------------- function Find_First_Of (Str : CPP_String; Text : CPP_String; Pos : size_t := 0) return size_t is begin Check_Non_Null (Str); Check_Non_Null (Text); return External.Find_First_Of_String (Str, Text, Pos); end Find_First_Of; function Find_First_Of (Str : CPP_String; Text : chars_ptr; Pos : size_t := 0) return size_t is begin Check_Non_Null (Str); return External.Find_First_Of_Text (Str, Text, Pos); end Find_First_Of; function Find_First_Of (Str : CPP_String; Text : chars_ptr; Pos : size_t; N : size_t) return size_t is begin Check_Non_Null (Str); return External.Find_First_Of_Buffer (Str, Text, Pos, N); end Find_First_Of; function Find_First_Of (Str : CPP_String; C : Character; Pos : size_t := 0) return size_t is begin Check_Non_Null (Str); return External.Find_First_Of_Char (Str, C, Pos); end Find_First_Of; ---------------------- -- Find_Last_Not_Of -- ---------------------- function Find_Last_Not_Of (Str : CPP_String; Text : CPP_String; Pos : size_t := Npos) return size_t is begin Check_Non_Null (Str); Check_Non_Null (Text); return External.Find_Last_Not_Of_String (Str, Text, Pos); end Find_Last_Not_Of; function Find_Last_Not_Of (Str : CPP_String; Text : chars_ptr; Pos : size_t := Npos) return size_t is begin Check_Non_Null (Str); return External.Find_Last_Not_Of_Text (Str, Text, Pos); end Find_Last_Not_Of; function Find_Last_Not_Of (Str : CPP_String; Text : chars_ptr; Pos : size_t; N : size_t) return size_t is begin Check_Non_Null (Str); return External.Find_Last_Not_Of_Buffer (Str, Text, Pos, N); end Find_Last_Not_Of; function Find_Last_Not_Of (Str : CPP_String; C : Character; Pos : size_t := Npos) return size_t is begin Check_Non_Null (Str); return External.Find_Last_Not_Of_Char (Str, C, Pos); end Find_Last_Not_Of; ------------------ -- Find_Last_Of -- ------------------ function Find_Last_Of (Str : CPP_String; Text : CPP_String; Pos : size_t := Npos) return size_t is begin Check_Non_Null (Str); Check_Non_Null (Text); return External.Find_Last_Of_String (Str, Text, Pos); end Find_Last_Of; function Find_Last_Of (Str : CPP_String; Text : chars_ptr; Pos : size_t := Npos) return size_t is begin Check_Non_Null (Str); return External.Find_Last_Of_Text (Str, Text, Pos); end Find_Last_Of; function Find_Last_Of (Str : CPP_String; Text : chars_ptr; Pos : size_t; N : size_t) return size_t is begin Check_Non_Null (Str); return External.Find_Last_Of_Buffer (Str, Text, Pos, N); end Find_Last_Of; function Find_Last_Of (Str : CPP_String; C : Character; Pos : size_t := Npos) return size_t is begin Check_Non_Null (Str); return External.Find_Last_Of_Char (Str, C, Pos); end Find_Last_Of; ---------- -- Free -- ---------- procedure Free (Str : in out CPP_String) is begin Check_Non_Null (Str); External.Destroy (Str); Str.Wrapped_String_Address := Null_Address; end Free; ------------ -- Insert -- ------------ procedure Insert (Str : in out CPP_String; Pos : size_t; Text : String) is C_Text : chars_ptr := New_String (Text); begin Check_Non_Null (Str); External.Insert_Text (Str, Pos, C_Text); Free (C_Text); end Insert; procedure Insert (Str : in out CPP_String; Pos : size_t; Text : CPP_String) is begin Check_Non_Null (Str); Check_Non_Null (Text); External.Insert_String (Str, Pos, Text); end Insert; procedure Insert (Str : in out CPP_String; Pos : size_t; Text : CPP_String; Subpos : size_t; Sublen : size_t) is begin Check_Non_Null (Str); Check_Non_Null (Text); External.Insert_Substring (Str, Pos, Text, Subpos, Sublen); end Insert; procedure Insert (Str : in out CPP_String; Pos : size_t; Text : chars_ptr) is begin Check_Non_Null (Str); External.Insert_Text (Str, Pos, Text); end Insert; procedure Insert (Str : in out CPP_String; Pos : size_t; Text : chars_ptr; N : size_t) is begin Check_Non_Null (Str); External.Insert_Buffer (Str, Pos, Text, N); end Insert; procedure Insert (Str : in out CPP_String; Pos : size_t; N : size_t; C : Character) is begin Check_Non_Null (Str); External.Insert_Fill (Str, Pos, N, C); end Insert; ------------ -- Length -- ------------ function Length (Str : CPP_String) return size_t is begin Check_Non_Null (Str); return External.Length (Str); end Length; -------------- -- Max_Size -- -------------- function Max_Size (Str : CPP_String) return size_t is begin Check_Non_Null (Str); return External.Max_Size (Str); end Max_Size; -------------------- -- New_CPP_String -- -------------------- function New_CPP_String return CPP_String is Result : CPP_String; begin External.Init (Result); return Result; end New_CPP_String; function New_CPP_String (Text : chars_ptr) return CPP_String is Result : CPP_String; begin External.Init_With_Text (Result, Text); return Result; end New_CPP_String; function New_CPP_String (Text : String) return CPP_String is C_Text : chars_ptr := New_String (Text); Result : CPP_String; begin Result := New_CPP_String (C_Text); Free (C_Text); return Result; end New_CPP_String; function New_CPP_String (Text : CPP_String) return CPP_String is Contents : constant String := Data (Text); begin return New_CPP_String (Contents); end New_CPP_String; function New_CPP_String (N : size_t; C : Character) return CPP_String is Result : CPP_String; begin External.Init_With_Fill (Result, N, C); return Result; end New_CPP_String; ---------- -- Npos -- ---------- function Npos return size_t is begin return External.Npos; end Npos; -------------- -- Pop_Back -- -------------- procedure Pop_Back (Str : in out CPP_String) is begin Check_Non_Null (Str); External.Pop_Back (Str); end Pop_Back; --------------- -- Push_Back -- --------------- procedure Push_Back (Str : in out CPP_String; C : Character) is begin Check_Non_Null (Str); External.Push_Back (Str, C); end Push_Back; ------------- -- Replace -- ------------- procedure Replace (Str : in out CPP_String; Pos : size_t; Len : size_t; Text : String) is C_Text : chars_ptr := New_String (Text); begin Check_Non_Null (Str); External.Replace_Text (Str, Pos, Len, C_Text); Free (C_Text); end Replace; procedure Replace (Str : in out CPP_String; Pos : size_t; Len : size_t; Text : CPP_String) is begin Check_Non_Null (Str); Check_Non_Null (Text); External.Replace_String (Str, Pos, Len, Text); end Replace; procedure Replace (Str : in out CPP_String; Pos : size_t; Len : size_t; Text : CPP_String; Subpos : size_t; Sublen : size_t) is begin Check_Non_Null (Str); Check_Non_Null (Text); External.Replace_Substring (Str, Pos, Len, Text, Subpos, Sublen); end Replace; procedure Replace (Str : in out CPP_String; Pos : size_t; Len : size_t; Text : chars_ptr) is begin Check_Non_Null (Str); External.Replace_Text (Str, Pos, Len, Text); end Replace; procedure Replace (Str : in out CPP_String; Pos : size_t; Len : size_t; Text : chars_ptr; N : size_t) is begin Check_Non_Null (Str); External.Replace_Buffer (Str, Pos, Len, Text, N); end Replace; procedure Replace (Str : in out CPP_String; Pos : size_t; Len : size_t; N : size_t; C : Character) is begin Check_Non_Null (Str); External.Replace_Fill (Str, Pos, Len, N, C); end Replace; ------------- -- Reserve -- ------------- procedure Reserve (Str : in out CPP_String; N : size_t := 0) is begin Check_Non_Null (Str); External.Reserve (Str, N); end Reserve; ------------ -- Resize -- ------------ procedure Resize (Str : in out CPP_String; N : size_t) is begin Check_Non_Null (Str); External.Resize (Str, N); end Resize; ------------ -- Resize -- ------------ procedure Resize (Str : in out CPP_String; N : size_t; C : Character) is begin Check_Non_Null (Str); External.Resize_And_Fill (Str, N, C); end Resize; ------------------ -- Reverse_Find -- ------------------ function Reverse_Find (Str : CPP_String; Text : CPP_String; Pos : size_t := Npos) return size_t is begin Check_Non_Null (Str); Check_Non_Null (Text); return External.Reverse_Find_String (Str, Text, Pos); end Reverse_Find; function Reverse_Find (Str : CPP_String; Text : chars_ptr; Pos : size_t := Npos) return size_t is begin Check_Non_Null (Str); return External.Reverse_Find_Text (Str, Text, Pos); end Reverse_Find; function Reverse_Find (Str : CPP_String; Text : chars_ptr; Pos : size_t; N : size_t) return size_t is begin Check_Non_Null (Str); return External.Reverse_Find_Buffer (Str, Text, Pos, N); end Reverse_Find; function Reverse_Find (Str : CPP_String; C : Character; Pos : size_t := Npos) return size_t is begin Check_Non_Null (Str); return External.Reverse_Find_Char (Str, C, Pos); end Reverse_Find; ---------- -- Size -- ---------- function Size (Str : CPP_String) return size_t is begin Check_Non_Null (Str); return External.Size (Str); end Size; ------------ -- Substr -- ------------ function Substr (Str : CPP_String; Pos : size_t := 0; Len : size_t := Npos) return CPP_String is begin Check_Non_Null (Str); return Result : CPP_String do External.Substr (Result, Str, Pos, Len); end return; end Substr; ---------- -- Swap -- ---------- procedure Swap (Str : in out CPP_String; Text : in out CPP_String) is begin Check_Non_Null (Str); Check_Non_Null (Text); External.Swap (Str, Text); end Swap; -------------------------- -- Relational_Operators -- -------------------------- function "=" (Left : CPP_String; Right : CPP_String) return Boolean is begin Check_Non_Null (Left); Check_Non_Null (Right); return External.Eq_String (Left, Right) /= False; end "="; function "=" (Left : chars_ptr; Right : CPP_String) return Boolean is begin Check_Non_Null (Right); return External.Eq_Text_String (Left, Right) /= False; end "="; function "=" (Left : CPP_String; Right : chars_ptr) return Boolean is begin Check_Non_Null (Left); return External.Eq_String_Text (Left, Right) /= False; end "="; function "<" (Left : CPP_String; Right : CPP_String) return Boolean is begin Check_Non_Null (Left); Check_Non_Null (Right); return External.Lt_String (Left, Right) /= False; end "<"; function "<" (Left : chars_ptr; Right : CPP_String) return Boolean is begin Check_Non_Null (Right); return External.Lt_Text_String (Left, Right) /= False; end "<"; function "<" (Left : CPP_String; Right : chars_ptr) return Boolean is begin Check_Non_Null (Left); return External.Lt_String_Text (Left, Right) /= False; end "<"; function "<=" (Left : CPP_String; Right : CPP_String) return Boolean is begin Check_Non_Null (Left); Check_Non_Null (Right); return External.Le_String (Left, Right) /= False; end "<="; function "<=" (Left : chars_ptr; Right : CPP_String) return Boolean is begin Check_Non_Null (Right); return External.Le_Text_String (Left, Right) /= False; end "<="; function "<=" (Left : CPP_String; Right : chars_ptr) return Boolean is begin Check_Non_Null (Left); return External.Le_String_Text (Left, Right) /= False; end "<="; function ">" (Left : CPP_String; Right : CPP_String) return Boolean is begin Check_Non_Null (Left); Check_Non_Null (Right); return External.Gt_String (Left, Right) /= False; end ">"; function ">" (Left : chars_ptr; Right : CPP_String) return Boolean is begin Check_Non_Null (Right); return External.Gt_Text_String (Left, Right) /= False; end ">"; function ">" (Left : CPP_String; Right : chars_ptr) return Boolean is begin Check_Non_Null (Left); return External.Gt_String_Text (Left, Right) /= False; end ">"; function ">=" (Left : CPP_String; Right : CPP_String) return Boolean is begin Check_Non_Null (Left); Check_Non_Null (Right); return External.Ge_String (Left, Right) /= False; end ">="; function ">=" (Left : chars_ptr; Right : CPP_String) return Boolean is begin Check_Non_Null (Right); return External.Ge_Text_String (Left, Right) /= False; end ">="; function ">=" (Left : CPP_String; Right : chars_ptr) return Boolean is begin Check_Non_Null (Left); return External.Ge_String_Text (Left, Right) /= False; end ">="; end GNATCOLL.CPP.Strings; gnatcoll-bindings-25.0.0/cpp/gnatcoll-cpp-strings.ads000066400000000000000000000657751464374334300225600ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 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 -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package provides a wrapper of the C++ ISO/IEC 14882:1998(E) string -- class. with Interfaces.C; with Interfaces.C.Strings; with System; package GNATCOLL.CPP.Strings is type CPP_String is limited private; -- Defined limited because it has a pointer to the C++ string (to -- forbid copying variables that reference the same string). function Npos return Interfaces.C.size_t; -- Greatest possible value for string indexes. procedure Append (Str : in out CPP_String; Text : String); -- Append Ada-string: Append to Str the conversion of Text into a null- -- terminated character sequence. procedure Append (Str : in out CPP_String; Text : CPP_String); -- Append string: Append to Str the contents of Text. procedure Append (Str : in out CPP_String; Text : CPP_String; Subpos : Interfaces.C.size_t; Sublen : Interfaces.C.size_t); -- Append substring: Append to Str a copy of a substring of Text. The -- substring is the portion of Text that begins at the character position -- subpos and spans sublen characters (or until the end of Text, if either -- Text is too short or if sublen is Npos). procedure Append (Str : in out CPP_String; Text : Interfaces.C.Strings.chars_ptr); -- Append C-string: Append to Str the null-terminated character sequence -- pointed by Text. procedure Append (Str : in out CPP_String; Text : Interfaces.C.Strings.chars_ptr; N : Interfaces.C.size_t); -- Append buffer: Append to Str a copy of the first n characters of the -- array of characters pointed by Text. procedure Append (Str : in out CPP_String; N : Interfaces.C.size_t; C : Character); -- Append with fill: Append N consecutive copies of character c. procedure Assign (Str : in out CPP_String; Text : String); -- Ada String: Assign to Str the conversion of Text into a null terminated -- character sequence. procedure Assign (Str : in out CPP_String; Text : CPP_String); -- C++ String: Assign to Str a copy of the C++ string Text. procedure Assign (Str : in out CPP_String; Text : Interfaces.C.Strings.chars_ptr); -- Assign to Str a copy of the null-terminated character sequence pointed -- by Text. procedure Assign (Str : in out CPP_String; C : Character); -- Assign to Str a copy of the character C, replacing its current contents. function Capacity (Str : CPP_String) return Interfaces.C.size_t; -- Returns the size of the storage space currently allocated for the string -- expressed in terms of bytes. procedure Clear (Str : in out CPP_String); -- Erases the contents of the string, which becomes an empty string. function Char_At (Str : CPP_String; Pos : Interfaces.C.size_t) return Character; -- Return the character located at the given Position. function Empty (Str : CPP_String) return Boolean; -- Returns whether the string is empty (i.e. whether its length is 0). procedure Erase (Str : in out CPP_String; Pos : Interfaces.C.size_t := 0; Len : Interfaces.C.size_t := Npos); -- Erases the portion of the string value that begins at the character -- position pos and spans len characters (or until the end of the string, -- if either the content is too short or if len is Npos). Default values -- erase all characters in the string (like function Clear). procedure Free (Str : in out CPP_String); -- Destroys the C++ string object. procedure Insert (Str : in out CPP_String; Pos : Interfaces.C.size_t; Text : String); -- Insert Ada-string: Inserts at the given position the conversion of Text -- into a null-terminated character sequence. procedure Insert (Str : in out CPP_String; Pos : Interfaces.C.size_t; Text : CPP_String); -- Insert string: Inserts into Str a copy of Text at the given position. procedure Insert (Str : in out CPP_String; Pos : Interfaces.C.size_t; Text : CPP_String; Subpos : Interfaces.C.size_t; Sublen : Interfaces.C.size_t); -- Insert substring: Inserts into Str a copy of a substring of Text. The -- substring is the portion of Text that begins at the character position -- subpos and spans sublen characters (or until the end of Text, if either -- Text is too short or if sublen is Npos). procedure Insert (Str : in out CPP_String; Pos : Interfaces.C.size_t; Text : Interfaces.C.Strings.chars_ptr); -- Insert C-string: Inserts a copy of the null-terminated character -- sequence pointed by Text. procedure Insert (Str : in out CPP_String; Pos : Interfaces.C.size_t; Text : Interfaces.C.Strings.chars_ptr; N : Interfaces.C.size_t); -- Insert buffer: Insert into Str a copy of the first N characters of the -- array of characters pointed by Text. procedure Insert (Str : in out CPP_String; Pos : Interfaces.C.size_t; N : Interfaces.C.size_t; C : Character); -- Insert with character fill: Insert N consecutive copies of character C. function Length (Str : CPP_String) return Interfaces.C.size_t; -- Return the number of actual bytes that conform the contents of the -- string, which is not necessarily equal to its storage capacity. function Max_Size (Str : CPP_String) return Interfaces.C.size_t; -- Return the maximum length the string can reach. function New_CPP_String return CPP_String; -- Empty string constructor: allocates and initializes an empty string, -- with a length of zero characters. function New_CPP_String (Text : String) return CPP_String; -- Ada string copy constructor: allocates a new string and initializes -- it copying the conversion of Text into a C null-terminated character -- sequence. function New_CPP_String (Text : CPP_String) return CPP_String; -- C++ string copy constructor: allocates a new string and initializes -- it copying the contents of Text. function New_CPP_String (Text : Interfaces.C.Strings.chars_ptr) return CPP_String; -- C-String constructor: allocates a new string and initializes it copying -- the contents of the null-terminated character sequence pointed by Text. function New_CPP_String (N : Interfaces.C.size_t; C : Character) return CPP_String; -- Fill constructor: allocates a new string and initializes it filling the -- string with N consecutive copies of character C. procedure Pop_Back (Str : in out CPP_String); -- Remove last character of Str. procedure Push_Back (Str : in out CPP_String; C : Character); -- Append character C to the end of Str. procedure Replace (Str : in out CPP_String; Pos : Interfaces.C.size_t; Len : Interfaces.C.size_t; Text : String); -- Replace string: Replaces the portion of the string that begins at -- character Pos and spans Len characters by the contents of Text. procedure Replace (Str : in out CPP_String; Pos : Interfaces.C.size_t; Len : Interfaces.C.size_t; Text : CPP_String); -- Replace string (1): Replaces the portion of the string that begins at -- character pos and spans len characters by the contents of Text. procedure Replace (Str : in out CPP_String; Pos : Interfaces.C.size_t; Len : Interfaces.C.size_t; Text : CPP_String; Subpos : Interfaces.C.size_t; Sublen : Interfaces.C.size_t); -- Replace substring: Replaces the portion of the string that begins at -- character Pos and spans Len characters by the contents of Text that -- begins at character Subpos and spans Sublen characters. procedure Replace (Str : in out CPP_String; Pos : Interfaces.C.size_t; Len : Interfaces.C.size_t; Text : Interfaces.C.Strings.chars_ptr); -- Replace c-string: Replaces the portion of the string that begins at -- character Pos and spans Len characters by the contents of Text. procedure Replace (Str : in out CPP_String; Pos : Interfaces.C.size_t; Len : Interfaces.C.size_t; Text : Interfaces.C.Strings.chars_ptr; N : Interfaces.C.size_t); -- Replace buffer: Replaces the portion of the string that begins at -- character Pos and spans Len characters by the contents of the first -- N characters of the array of characters pointed by Text. procedure Replace (Str : in out CPP_String; Pos : Interfaces.C.size_t; Len : Interfaces.C.size_t; N : Interfaces.C.size_t; C : Character); -- Replace with character fill: Replaces the portion of the string that -- begins at character Pos by N consecutive copies of character C. procedure Reserve (Str : in out CPP_String; N : Interfaces.C.size_t := 0); -- Requests that the string capacity be adapted to a planned change in size -- to a length of up to N characters. If N is greater than the current -- string capacity, the function causes the container to increase its -- capacity to N characters (or greater); In all other cases, it is taken -- as a non-binding request to shrink the string capacity: the container -- implementation is free to optimize otherwise and leave the string with -- a capacity greater than n. procedure Resize (Str : in out CPP_String; N : Interfaces.C.size_t); -- Resize the string to a length of N characters. If N is smaller than the -- current string length, the current value is shortened to its first N -- character, removing the characters beyond the Nth. If N is greater than -- the current string length, the current content is extended by inserting -- at the end as many null characters as needed to reach a size of N. procedure Resize (Str : in out CPP_String; N : Interfaces.C.size_t; C : Character); -- Resize the string to a length of N characters. If N is smaller than the -- current string length, the current value is shortened to its first N -- character, removing the characters beyond the Nth. If N is greater than -- the current string length, the current content is extended by inserting -- at the end as many characters C as needed to reach a size of N. function Size (Str : CPP_String) return Interfaces.C.size_t; -- Return the number of actual bytes that conform the contents of the -- string, which is not necessarily equal to its storage capacity. procedure Swap (Str : in out CPP_String; Text : in out CPP_String); -- Exchange the content of the container Str by the content of Text. ----------------------- -- String operations -- ----------------------- function C_Str (Str : CPP_String) return Interfaces.C.Strings.chars_ptr; -- Return a pointer to an array that contains a null-terminated sequence -- of characters (i.e., a C-string) representing the current value of the -- string object. function Compare (Left : CPP_String; Right : CPP_String) return Integer; -- Compare the value of the string objects. Returns a signed integral -- indicating the relation between the strings: -- 0: They compare equal -- <0: Either the value of the first character that does not match is -- lower in the compared string, or all compared characters match -- but the compared string is shorter. -- >0: Either the value of the first character that does not match is -- greater in the compared string, or all compared characters match -- but the compared string is longer. function Compare (Left : CPP_String; Pos : Interfaces.C.size_t; Len : Interfaces.C.size_t; Right : CPP_String) return Integer; -- Compare the substring that begins at its character in position Pos and -- spans Len characters with the value of string Right. function Compare (Left : CPP_String; Pos : Interfaces.C.size_t; Len : Interfaces.C.size_t; Right : CPP_String; Subpos : Interfaces.C.size_t; Sublen : Interfaces.C.size_t) return Integer; -- Compare the substring that begins at its character in position Pos and -- spans Len characters with the value of string Right from position Subpos -- spanning Sublen chars. function Compare (Left : CPP_String; Right : Interfaces.C.Strings.chars_ptr) return Integer; -- Compare string with null-terminated C string. function Compare (Left : CPP_String; Pos : Interfaces.C.size_t; Len : Interfaces.C.size_t; Right : Interfaces.C.Strings.chars_ptr) return Integer; -- Compare substring with null-terminated C string. function Compare (Left : CPP_String; Pos : Interfaces.C.size_t; Len : Interfaces.C.size_t; Right : Interfaces.C.Strings.chars_ptr; N : Interfaces.C.size_t) return Integer; -- Compare the substring that begins at its character in position Pos and -- spans Len characters with the value of string Right. N is the number of -- characters to compare. procedure Copy (From_Str : CPP_String; To_Str : Interfaces.C.Strings.chars_ptr; Len : Interfaces.C.size_t; Pos : Interfaces.C.size_t; Num_Chars : out Interfaces.C.size_t); -- Copies a substring of the current value of the string object From_Str -- into the C array pointed by To_Str. This substring contains the Len -- characters that start at position Pos. The function does not append -- a null character at the end of the copied content. function Data (Str : CPP_String) return String; -- Return the string data. function Data (Str : CPP_String) return Interfaces.C.Strings.chars_ptr; -- Return the null-terminated character sequence contained in Str. function Find (Str : CPP_String; Text : CPP_String; Pos : Interfaces.C.size_t := 0) return Interfaces.C.size_t; -- Searches in Str for the first occurrence of the sequence Text. Pos is -- the position of the first character in Str to be considered in the -- search. function Find (Str : CPP_String; Text : Interfaces.C.Strings.chars_ptr; Pos : Interfaces.C.size_t := 0) return Interfaces.C.size_t; -- Searches in Str for the first occurrence of the sequence Text. Pos is -- the position of the first character in Str to be considered in the -- search. function Find (Str : CPP_String; Text : Interfaces.C.Strings.chars_ptr; Pos : Interfaces.C.size_t; N : Interfaces.C.size_t) return Interfaces.C.size_t; -- Searches in Str for the first occurrence of the sequence Text. Pos is -- the position of the first character in Str to be considered in the -- search; N is the length of the sequence of characters to match. function Find (Str : CPP_String; C : Character; Pos : Interfaces.C.size_t := 0) return Interfaces.C.size_t; -- Searches in Str for the first occurrence of character C. Pos is the -- position of the first character in Str to be considered in the search. function Find_First_Not_Of (Str : CPP_String; Text : CPP_String; Pos : Interfaces.C.size_t := 0) return Interfaces.C.size_t; -- Searches the string for the first character that does not match any of -- the characters specified in Text. When Pos is specified, the search only -- includes characters at or after position Pos, ignoring any possible -- occurrences before Pos. function Find_First_Not_Of (Str : CPP_String; Text : Interfaces.C.Strings.chars_ptr; Pos : Interfaces.C.size_t := 0) return Interfaces.C.size_t; -- Searches the string for the first character that does not match any of -- the characters specified in Text. When Pos is specified, the search only -- includes characters at or after position Pos, ignoring any possible -- occurrences before Pos. function Find_First_Not_Of (Str : CPP_String; Text : Interfaces.C.Strings.chars_ptr; Pos : Interfaces.C.size_t; N : Interfaces.C.size_t) return Interfaces.C.size_t; -- Searches the string for the first character that does not match any of -- the characters specified in Text. When Pos is specified, the search only -- includes characters at or after position Pos, ignoring any possible -- occurrences before Pos. N is the number of characters to search for. function Find_First_Not_Of (Str : CPP_String; C : Character; Pos : Interfaces.C.size_t := 0) return Interfaces.C.size_t; -- Searches the string for the first character that does not match C. -- When Pos is specified, the search only includes characters at or after -- position Pos, ignoring any possible occurrences before Pos. function Find_First_Of (Str : CPP_String; Text : CPP_String; Pos : Interfaces.C.size_t := 0) return Interfaces.C.size_t; -- Searches the string for the first character that matches any of the -- characters specified in Text. When Pos is specified, the search only -- includes characters at or after position Pos, ignoring any possible -- occurrences before Pos. function Find_First_Of (Str : CPP_String; Text : Interfaces.C.Strings.chars_ptr; Pos : Interfaces.C.size_t := 0) return Interfaces.C.size_t; -- Searches the string for the first character that matches any of the -- characters specified in Text. When Pos is specified, the search only -- includes characters at or after position Pos, ignoring any possible -- occurrences before Pos. function Find_First_Of (Str : CPP_String; Text : Interfaces.C.Strings.chars_ptr; Pos : Interfaces.C.size_t; N : Interfaces.C.size_t) return Interfaces.C.size_t; -- Searches the string for the first character that matches any of the -- characters specified in Text. When Pos is specified, the search only -- includes characters at or after position Pos, ignoring any possible -- occurrences before Pos. N is the number of characters to search for. function Find_First_Of (Str : CPP_String; C : Character; Pos : Interfaces.C.size_t := 0) return Interfaces.C.size_t; -- Searches the string for the first character that matches character C. -- When pos is specified, the search only includes characters at or after -- position pos, ignoring any possible occurrences before Pos. N is the -- number of characters to search for. function Find_Last_Not_Of (Str : CPP_String; Text : CPP_String; Pos : Interfaces.C.size_t := Npos) return Interfaces.C.size_t; -- Searches the string for the last character that does not match any of -- the characters specified in Text. When Pos is specified, the search only -- includes characters at or before position Pos, ignoring any possible -- occurrences after Pos. function Find_Last_Not_Of (Str : CPP_String; Text : Interfaces.C.Strings.chars_ptr; Pos : Interfaces.C.size_t := Npos) return Interfaces.C.size_t; -- Searches the string for the last character that does not match any of -- the characters specified in Text. When Pos is specified, the search only -- includes characters at or before position Pos, ignoring any possible -- occurrences after Pos. function Find_Last_Not_Of (Str : CPP_String; Text : Interfaces.C.Strings.chars_ptr; Pos : Interfaces.C.size_t; N : Interfaces.C.size_t) return Interfaces.C.size_t; -- Searches the string for the last character that does not match any of -- the characters specified in Text. When pos is specified, the search only -- includes characters at or before position Pos, ignoring any possible -- occurrences after Pos. N is the number of characters to search for. function Find_Last_Not_Of (Str : CPP_String; C : Character; Pos : Interfaces.C.size_t := Npos) return Interfaces.C.size_t; -- Searches the string for the last character that does not match C. -- When pos is specified, the search only includes characters at or before -- position pos, ignoring any possible occurrences after Pos. N is the -- number of characters to search for. function Find_Last_Of (Str : CPP_String; Text : CPP_String; Pos : Interfaces.C.size_t := Npos) return Interfaces.C.size_t; -- Searches the string for the last character that matches any of the -- characters specified in Text. When pos is specified, the search only -- includes characters at or before position pos, ignoring any possible -- occurrences after Pos. function Find_Last_Of (Str : CPP_String; Text : Interfaces.C.Strings.chars_ptr; Pos : Interfaces.C.size_t := Npos) return Interfaces.C.size_t; -- Searches the string for the last character that matches any of the -- characters specified in Text. When pos is specified, the search only -- includes characters at or before position pos, ignoring any possible -- occurrences after Pos. function Find_Last_Of (Str : CPP_String; Text : Interfaces.C.Strings.chars_ptr; Pos : Interfaces.C.size_t; N : Interfaces.C.size_t) return Interfaces.C.size_t; -- Searches the string for the last character that matches any of the -- characters specified in Text. When pos is specified, the search only -- includes characters at or before position pos, ignoring any possible -- occurrences after Pos. N is the number of characters to search for. function Find_Last_Of (Str : CPP_String; C : Character; Pos : Interfaces.C.size_t := Npos) return Interfaces.C.size_t; -- Searches the string for the last character that matches character C. -- When pos is specified, the search only includes characters at or before -- position pos, ignoring any possible occurrences after Pos. N is the -- number of characters to search for. function Reverse_Find (Str : CPP_String; Text : CPP_String; Pos : Interfaces.C.size_t := Npos) return Interfaces.C.size_t; -- Searches in Str for the last occurrence of the sequence Text. When Pos -- is specified, the search only includes sequences of characters that -- begin at or before position Pos, ignoring any possible match beginning -- after Pos. function Reverse_Find (Str : CPP_String; Text : Interfaces.C.Strings.chars_ptr; Pos : Interfaces.C.size_t := Npos) return Interfaces.C.size_t; -- Searches in Str for the last occurrence of the sequence Text. When Pos -- is specified, the search only includes sequences of characters that -- begin at or before position Pos, ignoring any possible match beginning -- after Pos. function Reverse_Find (Str : CPP_String; Text : Interfaces.C.Strings.chars_ptr; Pos : Interfaces.C.size_t; N : Interfaces.C.size_t) return Interfaces.C.size_t; -- Searches in Str for the last occurrence of the sequence Text. Pos is -- the position of the last character in Str to be considered in the -- search; N is the length of the sequence of characters to match. function Reverse_Find (Str : CPP_String; C : Character; Pos : Interfaces.C.size_t := Npos) return Interfaces.C.size_t; -- Searches in Str for the last occurrence of character C. Pos is the -- position of the last character in Str to be considered in the search. function Substr (Str : CPP_String; Pos : Interfaces.C.size_t := 0; Len : Interfaces.C.size_t := Npos) return CPP_String; -- Returns a newly constructed string object with its value initialized to -- a copy of a substring of this object. -------------------------- -- Relational Operators -- -------------------------- function "=" (Left : CPP_String; Right : CPP_String) return Boolean; function "=" (Left : Interfaces.C.Strings.chars_ptr; Right : CPP_String) return Boolean; function "=" (Left : CPP_String; Right : Interfaces.C.Strings.chars_ptr) return Boolean; function "<" (Left : CPP_String; Right : CPP_String) return Boolean; function "<" (Left : Interfaces.C.Strings.chars_ptr; Right : CPP_String) return Boolean; function "<" (Left : CPP_String; Right : Interfaces.C.Strings.chars_ptr) return Boolean; function "<=" (Left : CPP_String; Right : CPP_String) return Boolean; function "<=" (Left : Interfaces.C.Strings.chars_ptr; Right : CPP_String) return Boolean; function "<=" (Left : CPP_String; Right : Interfaces.C.Strings.chars_ptr) return Boolean; function ">" (Left : CPP_String; Right : CPP_String) return Boolean; function ">" (Left : Interfaces.C.Strings.chars_ptr; Right : CPP_String) return Boolean; function ">" (Left : CPP_String; Right : Interfaces.C.Strings.chars_ptr) return Boolean; function ">=" (Left : CPP_String; Right : CPP_String) return Boolean; function ">=" (Left : Interfaces.C.Strings.chars_ptr; Right : CPP_String) return Boolean; function ">=" (Left : CPP_String; Right : Interfaces.C.Strings.chars_ptr) return Boolean; private type CPP_String is record Wrapped_String_Address : System.Address := System.Null_Address; end record; end GNATCOLL.CPP.Strings; gnatcoll-bindings-25.0.0/cpp/gnatcoll-cpp.ads000066400000000000000000000035041464374334300210470ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 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 -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package hierarchy provides binding to C++ Standard library functions package GNATCOLL.CPP is end GNATCOLL.CPP; gnatcoll-bindings-25.0.0/cpp/gnatcoll_cpp.gpr000066400000000000000000000076021464374334300211550ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with "gnatcoll_core"; library project GnatColl_CPP is Version := External ("GNATCOLL_VERSION", "0.0"); Name := "gnatcoll_cpp"; type Build_Type is ("DEBUG", "PROD"); Build : Build_Type := External ("GNATCOLL_BUILD_MODE", External ("BUILD", "PROD")); type Library_Type_Type is ("relocatable", "static", "static-pic"); Library_Type : Library_Type_Type := External ("LIBRARY_TYPE", "static"); for Source_Dirs use ("."); for Library_Kind use Library_Type; for Object_Dir use "obj/" & Project'Library_Kind; for Library_Dir use "lib/" & Project'Library_Kind; for Library_Name use Name; case Library_Type is when "relocatable" => for Leading_Library_Options use External_As_List ("LDFLAGS", " "); for Library_Version use "lib" & Name & Gnatcoll_Core.So_Ext & "." & Version; when others => null; end case; for Languages use ("Ada", "C++"); package Compiler is case Build is when "DEBUG" => for Switches ("Ada") use ("-g", "-O0", "-gnata", "-gnatVa", "-gnatQ", "-gnaty", "-gnateE", "-gnatwaCJe", "-fstack-check"); when "PROD" => -- Do not use -gnatwe for production mode for Switches ("Ada") use ("-O2", "-gnatn", "-gnatwaCJ"); end case; for Switches ("Ada") use Compiler'Switches ("Ada") & External_As_List ("ADAFLAGS", " "); for Switches ("C++") use Compiler'Switches ("C++") & External_As_List ("CFLAGS", " ") & External_As_List ("CPPFLAGS", " "); end Compiler; package Naming is for Specification_Suffix ("C++") use ".h"; for Implementation_Suffix ("C++") use ".cpp"; end Naming; package Binder is case Build is when "DEBUG" => for Switches ("Ada") use ("-E"); when "PROD" => null; end case; end Binder; package Builder is case Build is when "DEBUG" => for Global_Configuration_Pragmas use "../gnat_debug.adc"; when "PROD" => null; end case; end Builder; package Ide is for VCS_Kind use "Git"; end Ide; end GnatColl_CPP; gnatcoll-bindings-25.0.0/cpp/setup.py000077500000000000000000000033611464374334300175110ustar00rootroot00000000000000#!/usr/bin/env python import logging import os import sys sys.path.append(os.path.dirname(os.path.dirname(os.path.abspath(__file__)))) from setup_support import SetupApp class GNATCollCPP(SetupApp): name = 'gnatcoll_cpp' project = 'gnatcoll_cpp.gpr' description = 'GNATColl CPP bindings' def create(self): super(GNATCollCPP, self).create() self.build_cmd.add_argument( '--debug', help='build project in debug mode', action="store_true", default=False) def update_config(self, config, args): logging.info('%-26s %s', 'Libraries kind', ", ".join(config.data['library_types'])) # Set library version with open(os.path.join(config.source_dir, '..', 'version_information'), 'r') as fd: version = fd.read().strip() config.set_data('GNATCOLL_VERSION', version, sub='gprbuild') # Set build mode config.set_data('BUILD', 'DEBUG' if args.debug else 'PROD', sub='gprbuild') logging.info('%-26s %s', 'Build mode', config.data['gprbuild']['BUILD']) def variants(self, config, cmd): result = [] for library_type in config.data['library_types']: gpr_vars = {'LIBRARY_TYPE': library_type, 'GPR_BUILD': library_type} if cmd == 'install': result.append((['--build-name=%s' % library_type, '--build-var=LIBRARY_TYPE'], gpr_vars)) else: result.append(([], gpr_vars)) return result if __name__ == '__main__': app = GNATCollCPP() sys.exit(app.run()) gnatcoll-bindings-25.0.0/docs-common/000077500000000000000000000000001464374334300174255ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/docs-common/Makefile000066400000000000000000000110351464374334300210650ustar00rootroot00000000000000# Makefile for Sphinx documentation # # You can set these variables from the command line. SPHINXOPTS = SPHINXBUILD = sphinx-build PAPER = BUILDDIR = _build # Internal variables. PAPEROPT_a4 = -D latex_paper_size=a4 PAPEROPT_letter = -D latex_paper_size=letter ALLSPHINXOPTS = -d $(BUILDDIR)/doctrees $(PAPEROPT_$(PAPER)) $(SPHINXOPTS) . .PHONY: help clean html dirhtml singlehtml pickle json htmlhelp qthelp devhelp epub latex latexpdf text man changes linkcheck doctest help: @echo "Please use \`make ' where is one of" @echo " html to make standalone HTML files" @echo " dirhtml to make HTML files named index.html in directories" @echo " singlehtml to make a single large HTML file" @echo " pickle to make pickle files" @echo " json to make JSON files" @echo " htmlhelp to make HTML files and a HTML help project" @echo " qthelp to make HTML files and a qthelp project" @echo " devhelp to make HTML files and a Devhelp project" @echo " epub to make an epub" @echo " latex to make LaTeX files, you can set PAPER=a4 or PAPER=letter" @echo " latexpdf to make LaTeX files and run them through pdflatex" @echo " text to make text files" @echo " man to make manual pages" @echo " changes to make an overview of all changed/added/deprecated items" @echo " linkcheck to check all external links for integrity" @echo " doctest to run all doctests embedded in the documentation (if enabled)" clean: -rm -rf $(BUILDDIR)/* html: $(SPHINXBUILD) -b html $(ALLSPHINXOPTS) $(BUILDDIR)/html @echo @echo "Build finished. The HTML pages are in $(BUILDDIR)/html." dirhtml: $(SPHINXBUILD) -b dirhtml $(ALLSPHINXOPTS) $(BUILDDIR)/dirhtml @echo @echo "Build finished. The HTML pages are in $(BUILDDIR)/dirhtml." singlehtml: $(SPHINXBUILD) -b singlehtml $(ALLSPHINXOPTS) $(BUILDDIR)/singlehtml @echo @echo "Build finished. The HTML page is in $(BUILDDIR)/singlehtml." pickle: $(SPHINXBUILD) -b pickle $(ALLSPHINXOPTS) $(BUILDDIR)/pickle @echo @echo "Build finished; now you can process the pickle files." json: $(SPHINXBUILD) -b json $(ALLSPHINXOPTS) $(BUILDDIR)/json @echo @echo "Build finished; now you can process the JSON files." htmlhelp: $(SPHINXBUILD) -b htmlhelp $(ALLSPHINXOPTS) $(BUILDDIR)/htmlhelp @echo @echo "Build finished; now you can run HTML Help Workshop with the" \ ".hhp project file in $(BUILDDIR)/htmlhelp." qthelp: $(SPHINXBUILD) -b qthelp $(ALLSPHINXOPTS) $(BUILDDIR)/qthelp @echo @echo "Build finished; now you can run "qcollectiongenerator" with the" \ ".qhcp project file in $(BUILDDIR)/qthelp, like this:" @echo "# qcollectiongenerator $(BUILDDIR)/qthelp/GNATColl.qhcp" @echo "To view the help file:" @echo "# assistant -collectionFile $(BUILDDIR)/qthelp/GNATColl.qhc" devhelp: $(SPHINXBUILD) -b devhelp $(ALLSPHINXOPTS) $(BUILDDIR)/devhelp @echo @echo "Build finished." @echo "To view the help file:" @echo "# mkdir -p $$HOME/.local/share/devhelp/GNATColl" @echo "# ln -s $(BUILDDIR)/devhelp $$HOME/.local/share/devhelp/GNATColl" @echo "# devhelp" epub: $(SPHINXBUILD) -b epub $(ALLSPHINXOPTS) $(BUILDDIR)/epub @echo @echo "Build finished. The epub file is in $(BUILDDIR)/epub." latex: $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex @echo @echo "Build finished; the LaTeX files are in $(BUILDDIR)/latex." @echo "Run \`make' in that directory to run these through (pdf)latex" \ "(use \`make latexpdf' here to do that automatically)." latexpdf: $(SPHINXBUILD) -b latex $(ALLSPHINXOPTS) $(BUILDDIR)/latex @echo "Running LaTeX files through pdflatex..." make -C $(BUILDDIR)/latex LATEXOPTS="-interaction=errorstopmode" all-pdf @echo "pdflatex finished; the PDF files are in $(BUILDDIR)/latex." text: $(SPHINXBUILD) -b text $(ALLSPHINXOPTS) $(BUILDDIR)/text @echo @echo "Build finished. The text files are in $(BUILDDIR)/text." man: $(SPHINXBUILD) -b man $(ALLSPHINXOPTS) $(BUILDDIR)/man @echo @echo "Build finished. The manual pages are in $(BUILDDIR)/man." changes: $(SPHINXBUILD) -b changes $(ALLSPHINXOPTS) $(BUILDDIR)/changes @echo @echo "The overview file is in $(BUILDDIR)/changes." linkcheck: $(SPHINXBUILD) -b linkcheck $(ALLSPHINXOPTS) $(BUILDDIR)/linkcheck @echo @echo "Link check complete; look for any errors in the above output " \ "or in $(BUILDDIR)/linkcheck/output.txt." doctest: $(SPHINXBUILD) -b doctest $(ALLSPHINXOPTS) $(BUILDDIR)/doctest @echo "Testing of doctests in the sources finished, look at the " \ "results in $(BUILDDIR)/doctest/output.txt." gnatcoll-bindings-25.0.0/docs-common/adacore-logo-white.png000066400000000000000000001146251464374334300236160ustar00rootroot00000000000000‰PNG  IHDRФi[¾” pHYs  šœÐiTXtXML:com.adobe.xmp nãoN’kIDATxìá€u?^Ÿ¹™H€:„. ¡÷"!¥†Q°€ —ßîêª+v]QA±¡BG"*ÄB¯Ò{—šJzæ]^–?Å$L&3wîó}>ç´uvvŠˆˆˆ#p“²Â81O ¡!"""""""""""""""4DDDDDDDDDDDDDDD„†ˆˆˆˆˆˆˆˆˆˆˆˆˆˆˆÐ"""""""""""""""BCDDDDDDDDDDDDDDDhˆˆˆˆˆˆˆˆˆˆˆˆˆˆˆ ¡!"""""""""""""""4DDDDDDDDDDDDDDD„†ˆˆˆˆˆˆˆˆˆˆˆˆˆˆˆÐÚEDDDDDDDD  ,‰¥±4X B,Åü«vÌö¯&¢Ó«æ`2¦c:&c&a¦a f‹ˆˆˆˆˆ(L»ˆˆˆˆˆˆˆˆh¦~X+`–ÇÊXËb,‹e°c°Ö30000ÏâŸxÏàILÑ¢ÚEDDDDDDDDOZñ&VÇÊX«bu¬ˆ6Õ7+` g:þ‰âi<ŠGð(Ãcx 3DDDDDD4Y»ˆˆˆˆˆˆˆˆXX«a=lˆu±†c8– ²8ÖÀìi<Œûq?îÇý¸‹ˆˆˆˆˆèí""""""""b^Ú°ÞŠM°6Äz(zÛ X[ùWÓqîƸwànÌÑMí""""""""b1¼›c3ŒÀFXR´¢Å±16Æ^5à¸7ã&<("""""¢ ÚEôŒ%±ŽxŽ˜*""""""ZQ?l„í°56ÇÆhU×À:XûzÕDÜŒ›p®Á=èñí"zÆGñ5ñŠãq¢ˆˆˆˆˆˆhËb{ì€m°5‰:Œ]°‹WMÀ5ø;®Á5x^DDDDDÔZ[gg§ˆpÖ¯¸ oU27)Û(ŒQ¾aØ »`G¼m"ÞÜ?p®Âx<%"""""j¥]Ä¢Ûë‹×Ú›ãFÑۖ®‰‘x‹ˆîÙá/»Æ¥¸Ï‹ˆˆˆˆˆ¢µ‹Xtb^ÞEDDDDDDOk`s¼ #±-ú‰èyëc}¹¸¿Çeø+戈ˆˆˆˆ¢´uvvŠX‹ã) oôÜûñîÇý˜¡³ð$ž´`°&ÖÁp ÇÚŽõÑ_9:qŽˆˆˆˆˆ¨Œv¯Šw‰¾´VÁã"""""¢ÎÄÏ°´¨’§qnÅ­¸w`ºx­™¸÷øWíX oÁ†Øcc,¦zþ‚'DDDDDDe´‹xÕ¡è/úRGàë"""""¢Žúã[ø¸huáï¸7â6üS,ªÙ¸÷âB¯jÇúØ[b­í,Q)m"þÏØLôµ»±ˆˆh¶¸IÙFaœˆˆhUÃpv­f6nÀÕø þ†§D_kúØÛ`kl†þZÃ\¬„§EDDDDDe´‹xÙ&ØL´‚õ±-þ."""""êbü +‹V0×àO¸Ç‹¢Õtâ܃3¼lql‹± ¶Ã }c<ž•Ò.âeGŠVò~ü]DDDDDÔÁQøˆ¾t?.Áïq¦ˆ*šŽñ/£[b$Fb{ô×g‰ˆˆˆˆˆÊiëììµ×ŽÇ°¢jšƒ~Ê2 Ã0MDD4Ëܤl£0NDD´Š~ø&>)úÂlŒÇE¸÷‹:„]ðv¼ kë³±"ž•ÒÁžXQu}My–Æ(Qª¥p>)ši*ÎÁ¡Š=ð}Ü/êb*.ÁqXâ?pæê9—ãyQ9 t¨®éø®SžQ¢5ñW¼S4ÃTœƒ±<ÆY˜(‚»ðMì‚p4þ€ÙÍ™"""""¢’¢î–Ã>ªë·˜‚1Ê3«Šˆˆˆˆˆ’l¿ccÑ›æà÷8 +â`\€i"æï9ü {bE?¢Ó™‰ EDDDDD%5DÝ‚ªë,/;³•¥ £EDDDDD)öÄ•XQô–;püƒDO›ŠŸa;l„ñO=ç |›bsü“Íß™"""""¢²¢ÎÞ‚-T×…˜æUc”g]l/"""""ªì38 í¢'Ý…O`e¿‹è}7áX¬„£q­×›Ž‹EDDDDDe5Du¨¶³¼Þ…˜¬<"""""¢ŠÚð-|Yô”Nü#ñ|“D4ßTü Û`;œƒÙ¸SDDDDDDeµuvvŠZê‡Ç0L5½€1ËëýÊ2 Ã0MDDô¦¸IÙFaœˆˆh†~øŽ=a:~“p·ˆÖ´ ãQY QWïÀ0ÕufùWg(ÏÒ%"""""ªbÎÂQbQMÄ×±:ŽÁÝ"Z×ã¸CDDDDDTZCÔU‡j;×¼ý +O‡ˆˆˆˆˆ¨‚8‰Eñ>5ñi<#""""""¢ ¢Ž–Á¾ªëIüɼÍÅ™Ê3«ŠˆˆˆˆˆV6çcÑ]ði¬‰¯c‚ˆˆˆˆˆˆˆ&jˆ::T×ù˜kþÆ(O:DDDDDD«ˆ °èŽ©ø"ÖÂ×1EDDDDDDDhˆ::RµiÁníÊs$ÚDDDDDD«€qx—XX³p ÖÆç1ADDDDDDDjˆºÙ[«®Gp7w†ò¬ƒDDDDDD+€ó±‡XXb#|ÿÑ¢n:TÛYèôæÆ¢Sy:DDDDDD«è‡Ó±X·awì‡{EDDDDDD´†¨“~8Bµ£kžÀåÊó }­ ¿ÀÁ¢«&ácØWˆˆˆˆˆˆˆhA Q'{`eÕu7nÒug(ÏRØ_DDDDDôµ“p¸èª3±NÆl-ª!ê¤Cµmáü Ó”§CDDDDDô¥Ïàã¢+ÀH†Šˆˆˆˆˆˆhq QC°Ÿj;Û™ŒqʳV}á(|Y¼™¹8›àrÑuq0S]7ã. ï åiÃhÑlûâÇâÍÜíp<^Q! Q£UÛ9ºçR<­‚ý𼈈ˆˆˆˆˆ4DéFbÕ5Xtc”g)("""""zˉØ]ÌËCØ?Q†(]‡j',º±ÊÔ!"""""zÃÑø˜˜—‹±9nQ˜†(Ù`ŒRmçèájåÙkŠˆˆˆˆˆž´=~ æå x7^Q †(Ù{±¸êšóõœ1ÊÓ†Ñ"""""¢§¬Œ_¡¿x­©Ø' SDDDDDDD¡¢d£UÛ¥x^Ï93•çH´‰ˆˆˆˆˆEÕçbEñZ`[üZDDDDDDDá¢TëbÕv¶žõ.VžáØIDDDDD,ªÿÁâµ®Ç6¸]DDDDDDD 4D©ŽTmÓ1NÏ;C™:DDDDDÄ¢8lj×ú5vÁS"""""""j¢!JÔÀhÕv &ëy—àå9ƒDDDDDDw¬ƒÓÄkŠƒð¢ˆˆˆˆˆˆˆiˆí†ÕTÛ™zÇ œ«1?ká;b.Fc¬ˆˆˆˆˆˆˆøÿ4D)­ÚžÄxÍsf+ÏXRDDDDD¼Q~Ž¥ÄG0VDDDDDDD¼NC”bW¬¡Ú.ÀÍó4.UžA8PDDDDD¼Ñ1ØE|§ŠˆˆˆˆˆˆˆÑ¥èP}c5ße꯵:¾.¾ƒ¯ˆˆˆˆˆˆˆˆyjˆ,‰TÛ#¸Fó]ˆÉʳ Ö¯8K©·óq¼ˆˆˆˆˆˆˆ˜¯†(Á¨ÚÎB§æ›† ”éHñ’#°—z»G SDDDDDDDÌWC” Cõ£ïœ¡LG¢MDDDDD½-ƒo«·{±/¦‹ˆˆˆˆˆˆˆjˆª[ »¨¶»q“¾ó'<®ˆêë\œ("""""""JCTY‡ê;[ë8C™:DDDDDÔË2ø¢úºG‰ˆˆˆˆˆˆˆ…ÖU5ª¾³µŽ±˜«<»`¸ˆˆˆˆˆúø<†ª§©8SDDDDDDDÄBkˆª:ƒTÛ5xHëxW(S‡ˆˆˆˆˆzØQ_Çâ.Ñ- QUªïL­ç e†ˆˆˆˆˆò}íêé—ø¥ˆˆˆˆˆˆˆè¶†¨¢5±«jëÄùZϘ¦Ü;q&ˆ–ÐÖÙÙ)*au<„6ÕvÎW kâAeÚWˆˆ®è‡ ° Þ‚± †£¡šÅ]¸·à6ü³ÔÛܤl£0NTÙ`¬ƒáXkc8ÖÁ*hS®é¸÷âNÜ‹»ðLuõ!œª~~ŠˆˆˆV³6ÁXëa=¬…~Ê1÷âÜ{p7îÄ ""è‡Í°¶Å¶X]ß…q¢ÕµclM±)6ÅÒÊ÷(nÃ͸×ãqÑtm¢>‹/©¶©XÓTÇUØIyÆ`´ˆ˜—¡ØÛa[lƒ%•o&nÂu¸Ç}êenR¶Q'ª`6Â[°6Â[°²x£¹¸ 7àzÜ€›1U”®wamõò 6Àó""¢/ Çl†Í1+‹qn¸ψˆ:X{ãíØËh=£0N´šaØ ;`kl†ÅÅ+žÀßp5þŒ›1Gôª¶ÎÎNÑòÚpÖQmgàÕòAüHy^Ä0LËcì°®xÅø3ÆãrÜ«l#p“²Â8ÑjVÁæØ [bs¬"Å\܉¿á*ü‰ÒŒ³ÔÏðSÑL±vÄŽØ ƒEW=ŠëñWü7`¶ˆ(Á&8ûâ­Zß(Œ}mvÇîØk‹…1ãñG\†;Dkëìì-oGüYõ탋UËü”çø©ˆúY ;àíx;F MtÅC¸ ¿Ãe˜¢,#p“²Â8Ñ—–ÆvØ[a ¬(šáa\ŽKq9žUÖ†›ñVõr¶Ä\Ñ›–ÅNØ ;bKô=e*®Æx\‰0SDTÅZ8‡bÕ2 ãD³ ÀŽxÞŽDOz ¿Åop9¦‹EÖÖÙÙ)ZÞñÕöVÄ,ÕsöWž¿`Gõ0ïÄØ KˆE5WàBüO«¾¸IÙFaœh¦áØ;b{lŒ†èk¸ãbÜ,ªfo\¬~vÂÕ""¢§5°öÂ^Ø m¢Y¦áϸãAQ'[ã-ªm ÎW¶Å±?ŽÂÛЦšFaœh†!Øûa,%šáEüçábLÝÒÖÙÙ)ZÚx K«¶Ÿâªi?üZ™Öý"Ê´,öÁx;ˆÞ2ãqÎdzªinR¶Q'zÓ*Ø »cw¬*ªàAüçátŠVwÞ¦^ÎÃ{DDDOŠ=±'öÄr¢UÜ‹q1þŠ9¢d_ŧUÛXE™VÁ1ø†ª¾Q'z˲8`7´‹¾4¿Åø-f‰.këìì-íPŒU}#q¹jZ Obåù >+¢°Þ·£]4Û,\Œ_â·˜¥:Fà&e…q¢'-…=°Fb}Quc,Æà.ÑŠFà&õ2 oÁ}""bQ¬€ýñ^ì‚6Ñê^Àoq..Å QšÇÿ¨¶‰¢,ã¿pÚ•cƉž4ûâP¼ýE+zgâç¸Y¼©¶ÎÎNÑÒ.Ūí)¬Š9ªë‡ø°ò<Š51WDµ½ïÃXN´Šgð3üh}#p“²Â8±¨ÖÅÞxvFQªkñSœÉ¢UœŽÑêåd|LDDtÇ ØaW4DUMÂE8ÄQ‚£ñÕצ ÛâÓx·2Â8ѶÅûñ^,-ªäœŠs0MÌS[gg§hY«â´©¶“ñ1Õ¶®V¦=ðGÕ3Gàhl!ZY'þ€“p):µ¦¸IÙFaœXX ì€ý±7Öu3gáû¸Mô¥axýÕÇT ÇÓ""¢«ÇèÀÛÐ¥y gã¸ETÙ8_õ Ä4Õµ1¾Œ}•mƉîŒÑ8Šª{?ÂÉx\¼NC´²ÑhS}gª¾¿âAeêQ-«áx ?Ä¢ÕµaOü·áh ÑÚúawœŠÇpŽÃº¢Ž–Äp+þ„}Ð&ú±è¯^¾ƒ§EDDWlŽSðÆ`w4D‰†á8ÜŒëñ!,-ªèe¤šVÅÜŠ}EÌÛ&ø žÀ÷°¡(Á2øÄØDüÚ:;;E˺몶G±:Ußñ9噆a˜$¢µmƒOâ@ôU÷$þ?ÁT­anR¶Q'æ§]ð^ìåEÌßø&Æb¦h†þx+©‰XDDÄü Áa8 ›‰:{gà¸ETÅf¸Qõ­…‡TÇøwü'ªQ'º¢ {á“)êâB|ת¹†hUÛc]Õw&:•á eZïÑšÚð.üÇ{ÑO”`%|ãß°„ˆ¾³!¾†‡q>„åE,؆8 ÷áà zÛ¾XI½œ„ ""b^6ÁñNÆf¢î⃸Wá@ô­îyeXZu¼ wá (âõÚqnÃo1RÔɾ¸¿Åfj¬!ZÕhe8W9îÁµÊÔ!¢µ´anÄo°½(Õrø6îLJÐ.¢9†â¸wàSXUÄÂ[ ?ÄÝ8 Ñ[ŽQ/q’ˆˆx­6ì+p+>€%Dü«pîÅDZ¤hU/(à ­oeœß`u¯7ƽ8‰:{'nÄ9XO 5D+Z«¾»q£²œ¡L;`]­a܈_a„¨‹•p*nÃÞ"zÏNƒÇq¶Ñ3ÖÄ܈=DO[»©—b‚ˆˆxɼ·ãb¼MD׬…ïâaœ€eD«™„¹ªo ÖvîÀ"^¯Ä}ø!Öñª÷àvœ„eÕHC´¢ý0Xõ£nÃ-Ê4  ¯OãoX_DsôÇ)8ýD‰&cKåêŸâDô¯8T½üXDDyÚð>Ü…ETW>ŽÛð6ÑÓ&©¾Ašg0.Á>"†ßá Ñ:VÁU8J5D+X ïP}³q®z«L«`¤ˆ…³2.ÅWÑ.¢ùŽÅo0H”fÎQ¾Oâ< `#õqnQ–Õñœ†Á"Ê°&®ÀIXBô”‰ªoæŒK±‹öÄ­x‡ˆÖ4?ÅwÑO…4D+8 Õ÷G<¯^Æb®2uˆèº‘¸»‹è[{á ,/Jó õ0 Ä`õv€z9MDDYFãVì!¢LŸÀØLô„)ªo Þ7—bkQwíø~‡åE´¾ã",¥"¢t(Ùêç \¡L£0XÄ‚µásø–ѶƕXU”äZÜ)¢¶ÃÕXI}í¯>fàleX¿Âé,¢làïø$ÚÄ¢˜®ú†è]ñl-êneü Ç‹¨–wâ* S Ñ׶Ćªo:.ROg(Óâx¯ˆùŒßà‹hˆh-b.ÄÕ·+nÁ(õ1'âb,+ºk²ê¤÷ À…ØFÔÝ®¸;Š¨¦øÖÓ⢯u(Ã%˜¨ž.À4eê1oàì-¢u­ñXU”b 抨µ1«ª—ÔËÙ""ª­¾„˱Šˆzz'nÂÖ¢;¦ª¾zG?œ‰‘¢î>‚Ë°¢ˆj[Á¦ZXCô¥Åpˆ2œ­¾¦`œ2m‡õE¼Þ;ðw¬/¢õ­+°¼(Áã¸LD½¬+°¼úØG}LÂ%""ªk.ÃgÑQo«ãj+Ö4Õ7Pï8 ˆ:€Ÿàd´‹(ÃP\…m´¨†èKû`YÕ7«·1Êõ>¯:—`°ˆêXÄ`Q‚ÓEÔϺ¸Ë(ßÒØI}œ""ªi'܈·‰ˆWôÇ)ø ˆ®š¢ ƒõ¬O࣢ΖÁp´ˆò,?bg-¨!úR‡2ŒÃ4õvžV¦#ÐOÔ]¾ !¢zÞŠó1@TÝ8LQ?ã",®l{ ]}œ'"¢šŽÅXIDÌËѸ+Š®˜¢ ƒôœ}p¢¨³áøvQ®%ñl£Å4D_†=•á1g)ÓÊØCÔÙœQm#ñcQuÓpŽˆzÚcÑP®½ÕÇ$\."¢Zà§8í"bA¶ÅµØX¼™éÊ0PÏØcÑuµ%®Áú"Ê·4.Å6ZHCô•ÃÑOõ½€ß‹—ŒU®QWƒq Þ#¢ GâßDÕýBD}í¯*SÞ©>.Â,Õ1Wà(ÑU«ã¯ØS,ÈeXÒ¢[ã°”¨«w`<†Š¨¥q 6Ñ"ÚE_9R~…Yâ%×á.l <ûa&ˆ:Šßbkeù&nÅEUý÷aõôŸ¸§+˦XQ}üZDDul€‹±¶ˆXXKá7ø~!æg*©¶¥-š6œŽõE]‚ÓÑ_ô”ñ$žÃ³xÏa²—MÆÌDíèA^¶4–Æ Š¡XËŠž¶,~q¿>Ö.úÂæØXίu¾¬<‹á`œ*êb.ÃÆ"ÊÓÀ™'DUŽ/‰¨¯á\§»«™øƒˆˆjØbˆˆè®vü+ã«b^f`jdÑ| û‰º: ?FC,¬Ù¸7â><€ûq?žÕ;–Àp¬µ1ëc3 ݵ2~‡íñ¬>Ô.úB‡2üãÅkÅ—•©§Š:X㱶ˆr-3±;æˆ*ú%¾ˆ61?Ïá<‡§ñ,žÃ ˜Š©˜€©˜ŽÉ^5S¼¬Kz½!XKc0–Æ2X +c%¬†ÅEoY çc <« »«ñ˜*"¢õ€±XLôµñ,æ`’—MÁl¯Z‹£?a†¢¿h_ÁPNñZ“±¬j¨û¶À7E]} ß]u?ÆãÜ„Û0CsMÃ?ðÿjul†-°5vÂ@ÑUëâ"ŒÄ‹úH»h¶8TÎÃñZáÏØIy¶Á¸K”lUŒÇÚ"Ê· þ¾!ªè\ÝÕÓ\<Šûq/£x á1ÌÐ÷–ÃXb}lŒµDOXcðNtª¶ØY}üVDDë;'£!zÛ³¸÷â<€âY¯´uvvŠ¦ºû¨¾G±:Å Á?1@yžÀê˜#J³<þ„D³LÃm¸àA<ˆñ:õ¬e± ÖÁ:XëcS Vo×c[l‚›”mÆ)Ç <…%•áEÜŒëpnÆݘ­|ý±öÀ;°%ÚDWÍÄ–¸Muý7¾ îÇ:""Z××ñŸ¢'LÃ_p9®Àm˜¦úaCl‡=0ˈžv&FcŽ¸[¨¶OãëÎH\&šeÆi Çàâµ^À™ø9nPƒ±ŽÆŽb^Þ‹s5Y»h¦±—2œ…N1/p1öWž•±~/J2—a#Ñ[¦ãü 7ãÜ‹9šçy<Ûü«5°)¶Å¶ØƒÔÇ–ø"U3çá}ªé!üÆ5¸³ÕÓ,\…«ð9¬Œðì€6± 0[a–jÚQ}\&"¢5µá#Åí¸Äß1]5ÍÁí¸?A?l…w`Olƒ6±¨õ²Ñ˜£Þ¦¨¾Î’8MÔÑáøxÅåø1.Ä õ2§ãt¼Äh,#^qîÀ효­³³S4Í¿áÛÊ°%nó³~­Lçà`QŠ¸;ˆž4Wa<þŒk1Su´cöÀHì€ÅD Faœ²ìŒ+Uø ãq5]±2LJ0\,Èp‚ê釉¤Ä""ZK~€‹î¸çáW¸G=¬Š÷âPl.Õ™8êëØ]µ}Çéºïà8ÑL£0NßÚ ¡Þfa,NÄmâµ–Àðÿ°šxɽØ“4I[gg§hš›±©ê»ˆY Obå™a˜ ª®~…w‹žð4~‹‹p¦*Ç@ŒÄ(ìƒåDUÂ8eiÃXS뙈+p).ÅbQ40ÇâÝho4ÛàFÕ²%®Ss±<žÑZNÆGÄÂx ?ÃܯÞÖÃ!8 «‰î:Ç¢S=þªí4¥k¶Àµhˆf…qúÎθ Ô×TœŒ“ð”X8 ŸÂzâ¨I¢YF`Se8W¼™8G™á¢?»Ţ˜€aG¬„÷c¦*Ë‹¸ïʉŸc’ˆ¾×‰ÓµŽ‡ð]ì†å°?NÅbQÍÅ¥Øát̯ՎÓÐOµì¨>nÅó""ZË×ñÑsp!öÁš8÷‹{ð Çþ¸BtLJñuõ5Kõ Ô5 ü Q'ã7 ž¦ã»XŸÂSâÍÌÄϱŽÁÓêí«I¢Y:”ãLÑg(W‡¨ºOã(Ñsp!Ä0|Á\õ0—ãý†ƒq…ˆ¾uº¾u;>X ÇáO˜#zËèÀúø9:Å+6ŇUËöêã*­åSøOñf¦â[XûábÌo4¿Æîx ~ŒébaüŽSOSUß@]ó>l!êdüK«§_`=‡§ÄšS±¾†éêëDlª Ú:;;E¯ë'0TõÝŠMEW´á~¬¥LáQEïÁ9ba=ã<&Þh=|ïÇ`ѪFaœ2Ç.šçœ³q›èk›ã$ì$^2ëáÕðÖPá|­áXœ"äYœ„S0AtÇJøO|‹‹®:g«—ŸàhÕv%vµ`Kã^¬ úÂ(ŒÓ\ƒp5F¨Ÿëñ1ü]ô¤áø vSOw` L׋¢öÆPe8KtU'ÎP®QE[ãt±0îÄÑXŸÆcb^îÁ¿a5ü?<*¢¹~©÷M©Økã3¸M´‚±3Æ?Å|U5¬€5ÔÇŸED´†ð}1?Ïãx¬Ž¯`‚è®'q†ã»˜!ºâ—ØI½LU}KzsŸÅ âx÷â:\Š q!ÆàtŒÁ…¸âr\[ñ0^Àl­©ÎÂõ2Ä6ø»èi`$ŽÆDõó|]/këìì½nöU†áxPtÕz¸[™žÂª˜#ªb%\•EW܉/â\Ì «‡ãs.ZÅ(ŒS¦¥ðêyW᧸/ŠV·¾‡CÕ['¶ÁuZÛÞ¸X=܇uEDô½q)o4ßÃ×0Aô†áø6öoæ9l‹ûÔÃIø„j»o1«à>,®^fâN܉»qÆcx³ôŒ¥0 C±<†a(VÀŠŠ¯`¼æùþC½\‚âqÑ +ã—Ø]ýì†?é%m¢W-'Юú®Á¶ba]ƒ­•io\"ª`1\‰mÄ›¹ _À¹˜+Õ¼ŸÅ*¢¯Â8åú%ŽÐ3&ãç8÷ˆ*:?Ã`õu9Fjm_ÄçÔÙ8LDDßZÃ2âÆà3xT4Ãîø.6 r¶Å Ê÷-¯ÚÁæïÇø€òÝñ¸7à6ÌR?‡àLõ1Çá¢Ùø/| õñ 6Æ‹zACô¶CÑ® g‰î£\¢*¾mÄ‚|«à¸GTÕØ7©¯Ý±«Ö¶¥úø»ˆˆ¾5¿Å2âµîÆ®GE³\Žø7Ló³ÎD?团ú›¿uð~eš€³0«aŸàFÌR?#ð3õq6Ã/D_˜‹/ãmxR}¬…¯ê% ÑÛŽT†Nœ'ºãÌV¦}±ŒhuGâb~æàûX§`¶è Óðe¬‹_Šè£ºçìƒõñ}L%¸ÛcŒúúºÖ6B}\+"¢ï À8¬-^1_À¦¸Rô…Ùø6ÅÕb~öÄ×D 2ŸE?åx?ÀÛ°<Å<&–ÁXB=|;âAÑ×®ÂÖ¸Y}| ›ë ћފ͔a<žÝñ þ Lpˆhe›àT1?×`>ŽD3<…#±+îѳæâ—Îex¶ÅŘ+J3GâKêiì£5 ÅJêa6nÑwNÆâ7`Sœ€¢¯Ý‹]ðILóòï8H´ºvô÷¯VÇáªoÎÃ;± >‚ñ˜-^цŸc¸òMÅ83E«x ;â"õÐÀÑÐâ7u(ǹbQŒQ®Ѫá\,.ÞhŽÇ¸]ô…+±)¾€Ù"zÎéºæØoÇxQºNü7ŽÂ\õs‚Ö4B}Ü""úÆ1ø€xI'¾íp—h%sqFàV1/§a=嚨 ƒü«ÿB?Õõ0>…Uñü³Ä¼}•ïì€_‰V4ûãêak|@kˆÞÒ‡)Ãlœ'ÅE˜¤L[á-¢}ˆ7º ›âDÌ}iNÀ¶ø‡ˆžq/þfþþ†·aO\+êæ4ŒÆ\õ²9v×z6U7‹ˆè;à»â%cw| ³D«ºÛâgâ–ĨLÊ0Äë-ÕtÃ:øž ²¾¦|ÃÖ¸E´²9ø¾¡¾†åõ †è-{ae¸ωE1 ¿R®ÑjÆûÅkÍÅ°î­äl“EôŒ_øWw`_lñ¢ÎÆb4檗×zÞª>nÑ|+àô—á­ø“¨‚i8GâEñZã$ÑÊz½c1ÕröÂæ8³Å›Y g£]Ù.Ânø§¨ŠOá¿•o|CjˆÞÒ¡cEOø¥r~¢U¬‚Š×z»áÌ­h>†}ñ‚ˆEs¦{Ù‡Mq‘ˆ—Å'ÕË;°‰Ö²‘ú¸YDDsõÃX¬"NÄ^x^TÍ/±¯õ¤<Ó”a W À±ªãnŒÂø½X?Àpe;ûcº¨š/á Ê×Íõ†è Cñ.e˜‹DO¸+Ó0ì%ZANÇñŠ?bS\)ªà"lŽ[DtßD\€c=|³E¼Þ÷ðõòZËúêã""šë3©Þ¦ã9¢ªnÅÖø«x­cue™¡ KzÕ{0L뛀ObcŒC§Xâpe; ïÃQU'àdekÃ7ô†è £¿2üEO˜‹±ÊÕ!ZÁ±Ø]¼âdì‰gE•<„íp†ˆî{>„gDÌßÿÃÅê㽪5¬†%ÕóxFDDóì€ÿVoOcgœ!Jð4FâWâCð ´‰V3Ø«> õŽõpf‹…5 §*Û·ðItŠªû8ÎR¶‘ØChˆÞС爞4F¹öÁr¢/­…oˆ—̇ð1ÌU4 Gà³"ºg–ˆ77£ñ zè#µ†õÕÇ?DD4ÏŒE?õu/¶Ãu¢$ÓðüP¼âmø¸rÌV†^¶>vÖºÄèÀ3¢»~„å”ëTü‡(E':ðgeû&QCô´±…2LÅoDOº·(Ó"úJ~‚AbÞŽ‹|‡a¦ˆˆÞñÄ õðA´é{oQÿÑ<§` õu3vÀ¢Dsp,¾*^ñu¬§ S”a(†àÃZ×° þ(Å!x·rýÇ¢S”d&Ä#ʵ)µˆ¢§u(Ç…˜&zÚÊÕ!úÊû±»x»`¼(É™Ø “EDôŽñ9õ°vÑ÷ÖU÷ˆˆhŽq¨úº»âQºÏàÓâ%‹ã§h­â{xÇi=Ïb_|SÅ¢XßS®_ãXtŠ=wãEå:íACô¤v®g‹Þp&æ*ÓØX4Ûòøñ0¶ÃÍ¢DW`¡šfˆžp?vÆm¢§}•ç÷øš¨»ÿƒÊôIÝÐ=á-ØJ9ÎÍp)žV¦8Dô¦Ïbõ4 âv\€ãEDô¬Ùøœò½[ßXU}<""¢w4ðC´©Ÿ#ðÿêiìƒ)êísXQÔÑýØ÷‹ž¶#Vž'1¢î^ć•iWlb!5DOèPŽGñWÑ sp–ruˆÞ²>¦¾>„ËD¼ê$üDDDÏ:)ÛH,¦ùVQˆˆèÀêç+8_Äü݆CÑ©¾–—DÝÜ]ñ˜èimø¦òÌÅaxFÄË.Å…Êô1 ©!U?¡g£S4Ëʵ6½á+诞¾ŠŸ‹øWÅÕ""zÎl|GÙaWÍ·ŠúxLDDÏŒ/©Ÿ?àó"ÞÜoðUõö~l Z¦ˆîz»â1ÑÀ¶Ês"þ$âõŽÇLå9ËZ ±¨ÞaÊqŽh¦ëq—r½Oô´8X=ýÿ-bÞfâ½xZDDÏ9 “•moÍ·ªúxZDDÏû,–W/âPÌÑ5ŸÇU꫾®Zf‹îxïÀc¢7´ãëÊó|VÄ¿ºßUž%ðA ¡!U‡r܃D³Q®ÃÐ_ô¤/ Mý<ŒC1GÄü=C1WDDϘ‚3•í]šo%õñ¸ˆˆž5ŸP/3q žÑuspžQ_ûb[Q²iØ÷ˆÞr4ÖV–9èÀ óö5LTž¡¡‹bQ Á¾Êq®è g*× ØKô”mñnõ3âyoîr|UDDÏù‰²­…55× êãi=ëKè¯^>ƒE,¼'p¸z;A”ì\+zËø/åù&®1/à;ʳ&vÕE ±(Æå+úÂC¸J¹:DO9A=}׋èº/âz=ãÜ®l»jžXB=<‹Ù""z΢^®À·Etߥø¾úzv%ú,.½éCXMY—D¼¹oã9åyŸ.jˆEÑ¡·á.ÑWÆ*×»0T,ªÍñõs N±pfá0LÑ3ÎU¶]5Ï êã9=ëkhSÏc4:E,šOá>õõyQšsñUÑ›–À*ÏÇð¢ˆ77ßSž°´.hˆîÚÛ(Ç™¢/‹™ÊÔ‡ŠEõßêçY¼"Þ=8ADDÏ8OÙvÕ<+¨çEDôœm±§zù±è^ÄûÑ©žvŶ¢wã(tŠÞô~ S– q±ˆ®û^T–%p°.hˆîêP–sE_š€ß(W‡Xa_õsþ)¢ûNÄ""Ý]¸K¹ÖÀššc¨úxNDDÏ9A½\Œ³Eôœ?ãDõõQ‚é8SDo€ÿT–Yø7 çYü\yÞ§ ¢;úá师¾v†rm†·Šî:^ýŒÁE"Íl|""Ý%ʶ­æXF}<'"¢gl‹w¨Éøˆˆž÷y<¦žÞ…MDÕ‡ÛDo;«)Ë÷ð€ˆ…w":•e[¬îM4Dwì••ãlÑ .Á ÊÕ!ºce®^žÇñ"zÆ ø©ˆˆE÷[eÛRs VDDôŒÏ©—Ïà=o*>¡¾ŽUö[üHô¶6¯,ÏãË"ºç\¦<ïõ&¢;ŽTŽNœ+ZÁLœ£\‡¡¿XXCõr<žÑs>ƒ ""Í_1C¹¶ÖƒÕÇ$‹n¼S}\‡SDôž_á÷êéP Uô,ŽÍ°7Þ¢,_ÂÝ÷Cå9Ø›hˆ…5û)Ç•xB´Š1ʵö c |P½ŒÇé"zÖ3øªˆˆE3×)×è§÷ V“ED,ºO©—ã0WDïú(f¨Ÿþøˆ¨¢ãð”h†ã•å)üHÄ¢¹O*ËæXÛ4ÄÂz/WŽsD+ùT®±0Á²êcŽE§ˆžw2ž±hþ¬\±¡Þ7X}L±hVÇ{ÕÇÙø«ˆÞw?¾¯ž>„ZÓd1/ÀXÑ oÅ®ÊòeL±hfã å9È4ÄÂêPŽÙ8O´’NŒQ®wayÑUS/§âN½c¾("bÑ\£l›é}ƒÔÇT‹æ£è§¦ã?E4ÏWð‚úYiMsÄMÃ1¢Y>¡,â'"zÆXåeba¬‡í”ãr<'ZÍXåêÃDWlêc"NÑ»~ŽGEDtßuʶ‘Þ·´ú˜,"¢ûáêã[xDDóLÀWÔÓ±¢*¾E3,‹C•åÛ˜)¢gÜ‚Û•e+¬`>bat(ËXÑŠîÁµÊÕ!ºâCêåËxVDoŠˆè¾'ðŒr½Eï >戈è¾#1D=&‹ˆèžcÔÇW0EDß™¯ªŸå°hUÿ…NÑ,G+ËÙxFDï¸PYcGóÐ]±4F)ÇT\$ZÝ劽ż¬‹íÔÇ—0SDs=Žq""ºç!e[[ï ""dRÏáG"úÞixTý.ZÑ•ø½h–A8DYNÑ{~§<#ÍCCtÅ{°„r\„i¢Õ]„IÊÕ!æe´úx?Ñ7~&"¢{V¶áz×@± c1õðC¼(¢ïÍÄ7ÕÏ;±Œh5_Ít–RŽkqˆÞóLS–]ÍCCtE‡²œ%ª`~¥\{cyñF‡ª“0[D߸ OˆˆXx+ÛÚ""¢/u¨‡éøžˆÖñsLR/ph%×á2ÑLïS–Ÿˆè]Óqµ²lÞ !Þ̺ØA9^À¥¢*~©\í8L¼Ö®&â4}gαðžÇdå.""úÊúØF=œŽgD´Ž)ø©úy¯h%_Í´2vRŽqŽˆÞw¹²ôÇöÞ !ÞÌ‘ÊòkÌUq%W®ñZ‡¨aŠˆ¾u®ˆˆîù§r­!""úÊáêãD­çû˜£^vŲ¢<€ E3€6å8“Eô¾«•çmÞ !¤ÑÊr–¨’¹«\›b„xÅ{ÔÃl|_Dß»ˆˆXx/(ת""¢¯¼G=\†{D´ž‡p¡zi`”h'c®h¦÷(Ëé"šãÌT–·yƒ†XÝ°šr<ƒ?‰ª£lâ%[`5õð+<&¢5\("bá½ \K`iÑl[`=õð#­ëêçÑצâ4ÑL+cåxWŠhŽé¸AY6C¯Ñ 2ZYÎÁQ5·ãå: Ä~êãÇ"ZÇ%""Þ Ê¶²è K‹ˆèºƒÔÓ¸HDëúT/»aèKç`¢h¦Цç`®ˆæ¹^YǦ^£!æg) ,爪:C¹†â]b?õð þ$¢uü/ŠˆX8/(ÛÊ¢'4DDtÝêág˜%¢uÍÅiêe1ì!úÒi¢ÙS–sD4×Mʳµ×hˆù9•ãQüETÕ™˜«\êmMl¬~†¹"ZÇ üIDÄ™¡lÃDDD3mŒuÔÃi"ZßÏ1W½ì#úÊÝø‹h¦•±r<ŽkD4× Ê³×hˆùéP–sÐ)ªê \®\{aEõõNõ0?ÑzÆ‹ˆX83”m¨è ƒDDtÍ(õðW<(¢õ=Ž?¨—‘¢¯üB4ÛžÊr:E4ט­,Ûx†˜—µ±“²œ-ªn¬rµã0õõNõðG‹ˆX°6ŒT¾Ùø­ˆêù¦«å°©h–{qh¶½”å÷"úÎCÊóVÿ§!^kI¨,cEIæà,åZïRKc+å›KD´¶;DDtÝTe¬÷ÌTCDD,Ø[1Tù®Âó"ªçEüQ½ì.šå7¢Ù†aSåx÷ˆè;+Ï&þOC¼Ö¤,ç‰Òœ¡lêc{4”ïjLÑÚîÑus•mq½gŠú,"bÁÞ¦Ɖ¨®‹ÔË6¢Y~/šmge¹JDßzLy–ÁrþWC¼V‡²\ƒûEi®Ç]ʵVT;ª‡‹E´¾Ç1SDD×LR¶Åõž©êcˆˆˆ©.Q]£S}l#šaþ"šm'eù³ˆ¾5Ó”g]ÿ«!^±vQ–sD©Æ(W;S;©‡‹E´¾N<"""^2X>‹ˆ˜¿¶W¾;ñˆˆêz7¨Õ0Lô¶¿âEÑl;)ËÕ"úÞʳ®ÿÕ¯8RY:qŽ(Õ™ÊÖ¡|íØZùîÇÝ"ªáQ]3AÙÚôž‰êcˆˆˆùÛË(ße"ªïRõ²•èmWŠfŒM”ãEüCDß{VyÖõ¿â%m8RY®Â¢Tá*åÚ[*Û¦X\ùþ(¢:ž=iq¬·áPüNÂ9¸àë¢ Ò{&©!""æo'õp™ˆê»\½l#zÛ_E³m†rÜŒÙ"úÞDåY×ÿj/Ù k*ËÙ¢tg`gåêÀõʵ•z/¢:ž c1¬…5±&ÖÄšXkbEonqÕ4YÙÚõžIêc%ó·½òÍÂxÕ÷WLÃêa+Ñ›:qh¶•å­a¢ò¬éµ‹—t(Ëlœ/JwNÆe:Çc†2m£Æ‹¨ŽçDÄ5°ÖÃzXëc=¬Ž6õ4Gt× êc–Äÿjkå»SDTßtü#ÕÃVúÆbêá.LͶ£²Ü*¢5LQžUý¯v1)ËåxV”n‚ÿ_{ø/Yà×g&!•’ЫôN JUD¤‹"R¤\ì]wu±b/kAV],ë/ŠRPAQAz‰tEº„’©÷¿¼|x¤¤Ü™;ó<ßs8û+Ó¼¿P¦—+ß-xPD÷˜"¢nk`3l†M±)6 ñ\³Ä’zD]VÃÍ""žm$ÖW¾‹D”ãØE–ø[{ U‡¿‰vkb+eù›ˆÎ0]yVÆ€b?,«,'ŠZüû+W~¡<ƒ±¡ò](¢»<,¢Ë`3LÀVØ›b¤XTóÄ’zX]VÁÍ""žíåh(ßE"ÊñWuÙw‹V¸M´Ûú¦ q£ˆh•Xi èQ–¹øµ¨Åoñ(Æ(ÓX *Ë&¨|Ñ]f‰(Ï@lŒ—ãx96Ç ±4žKêuYEDÄ¿š —ˆ(ÇX€ê°Î­0Y´Û–Êr'žÑ¦+ÓêÕm-ì¤,gcš¨Å\œŠw+Ó¼_W–ñêp¹ˆî2WD÷‰í°vÀ6.úÚbI=Œ^4ÔaUÿj å» Š(Ç,\‹ ê°±h•[E»m¥,·ˆè •iÕêv8Êrª¨Í x·rõàëʲ¹òÍÀ­"ºËlÝgy¼;blŠ¦hµybIõâŒS‡UEDü«Í•ï¯"Ês &¨Ã†¢Uní6^Y&‹ˆV7P½8\YfáLQ›KpÖV¦Mðr\©+ß•X(""úÚ¼»`gl&úÃ,±4Æ8uXYDij-ƒ”ïå¹R=6­0ˆvÛJY&+Ç0Ft³ñÊ4n zí€u”åL<.jÓ‹ŸáÓÊÕƒ+•cCå»\D÷™)¢ó40{c7l¢,DS,‰{°¡:¬!"âÙ6Â@å»FDy®Q1XSD_ºO´Û£,“•ãsØBDç×T¯å9IÔêgÊv0+ÃH¬®|׊è>óEt†Ø?ƸŸÁv :Å ±¤PuDD<ۆʷ“D”ç&ÌU D_»O´ÛfÊó°ˆhµšê4 *ËTü^Ôê6\®\cðzeXOn‹c¼ÀÃ8GbEå¹_=Æb”ˆˆÚPùnÃ,噇ëÕcuÑ×í¶¾òüCD´Ú˜¦:½ #”å Ì5û©²õ(ÃzÊ·7‹ˆˆ—² Þóñþ»`èSÅ’ºO]ÖñOë+ß$嚤kˆ¾ö€h·õ”gŠˆhµáMuêQž“EíNÅ|åÚ+ë~ë(ßdÌÏg Þ‹¿à^ü7vFSD=îW—õDDüÓ†Êw³ˆrݨ«‹¾vŸh· ”e­6r ú¬•e .P†Ïas±¤Çe€Ãð5Ým]å»^DD<Ó2؇ãõ$J0],©»ÕeCÿ´¶òÝ,¢\·ªÇꢯýC´ÛºÊò ²ŒÑ™F TŸÃÐP–S±@÷…aˆç׃¯énk+ß""âIãq$Á8Qš…bIÝ¥.‰ˆxÊ(,§|7‹(×Í걚èkˆvŠ5”åaeiˆèLêÏÊsŠ2ìƒA"^ØFØ—ë^«+ß""ê5â=ØV”l–XRcF¨ÃF""žò2u¸ED¹îÀ| T¾5D_›&Úi=åyXD´Ã¦ºlõ”å\¤ ‡ˆxi=ºW«)ß""ê³.¾Žûðl+J7O,»Ôc ÁË”ï>ÌQ®ù¸SÆaˆèKÓD;­§<‹ˆvÒT—å9½ºßX¼VÄK;ƒu§•°ŒòÝ%"¢¯Áoq+>‚1¢Oˆ¥q—z Áº""XUùîQ¾»ÕcÑ—¦‹vZ]yfŠˆvÜT¡x³òœ¤ ` ˆ—6ûèN«+ß|Ü#"¢lq ®ÄØ Q›'ÄÒ¸C]¶ÁjÊ÷wå»[=–}išh§U”g–ˆh‹¦zì‹‘Ê2W)Ã"]î´¢ò݃""Ê4ïÇm8ÄÒª{ÍKã6uÙ\D«)ßßE”ïïê1Fô•9˜#Úiuå™%"Úb zô(ÏÉÊ°v±èvÇÊx@wYYùQž¡x>†•D_¬{ÍKãfuÙRD++ßßE”ïï걜è+Oˆv[Yy¦‹ˆ¶hªÃjØEyNR†7 )bÑ5q˜î³‚òÝ/"¢ƒðnÜŠoa%ÿ´@,[Õe‚ˆVR¾{E”ïAõXNû Ñ·VQž™"¢-šêpÊr=nT†ýE,¾Ýgeå›""¢û5ñ6LÆÿ`5ÿj†X÷`–z¬ˆÕDDíÆ)ßå{X=ÆhŸe”mªh·Õ•g–ˆh‹¦:¡<'*üVÄâÛ[ë.c”ïÝíµ¸?Âê"^X¯XZ·©ËÖ"¢vã”ïaå{@=–ÑFcˆòÌmÑT¾m±òœª {c ˆ%Ó£»,§|‰ˆèNà,œ‡ÍE¼´ibiÝ .¯5‡¦ò= ¢|«Çr"ºÓ*Ê4]D´ÃMåëQžËp»2 bÉŒ!ºÇå›""¢»ŒÄ·pöítºl/"j6ZùžÀ,囃™ê0Tô•Y¢F‹ˆXrsšÊ6)Ï©Ê0»‰Xr£ñFÝcŒòMÑ=Þ„ñ! ±x¦‹¥õ7uÙƒDD­F*ßÃ"ê1MÄâ™'Úi´ˆˆ¥ÐT¶7b”²ôâdeØ ƒD,Ýc¤òMÑùÖÀ™8«ŠX2 ÅÒºN]†`+Q«QÊ7SD=f¨Ã(Ýi´ˆˆ¥ÐT¶åù îW†D,½]±ªî0\ùfˆˆè\ |7âõ"–ÎL±´îÅTuy¥ˆ¨Õ(å›!¢3Õ¡!¢;±ä¦5•kUìª<')ÃPì%bé5q˜î0LùfˆˆèL«áø6†‹N±P÷š/úÂ$uÙIDÔj´òÍQêÐÑF)Ó4ÑÓ›Êu(šÊ2§+Ã^"¢oôè|£ÕaºˆˆÎs®ÇkE§™®{=.úÂêò* 5ZFù¦‹¨Çtu%¢;V¦^ÑÓ›ÊÕ£<çcŠ2 ¢ïl€mu¶Aê0SDDç…SðsŒѷ戾p•ºŒÄËED†+ßta´ˆˆ%7£©L[c#å9Ic/}«Gg&""Úi \…E´Æ\Ñ®RŸED†(ßBa¸ˆˆ%7½©L=Ê3¿R†Ý0BDß:CDZ "¢3‰K±ŽˆÖ™-úÂd<¦.{ˆˆ %™-":Ù²Ê4DY–Ñ™¦7•g0Vžß`š2ì+¢ïÂu®QÊ7SDDÿ‚ÿÅ1Dtªà2œ‚ Eízq•ºl‘""Ê3WD=抈h¿!Ê2\Dgzl òìƒÑÊsª2,ƒ7Šhœ¬35DDD+­Œ_㢿-ÀdÜ„[q'îÂ]¸ Oˆx¶K±‹z À.8CDDYf‹¨Ç0ÑÉ(SCD´Ãƒ•§Gyfá×Ê°#–Ñ»bUÜ'""j²%Ϊ¢æâ&ÜŒq#nÂm˜+bÑ]¬>¯Ã"¢&£EDI‰ˆN6B™F‰ˆv¸o ²¬„Ý•ç,<® ˆh&ÃWDDD-vÇ/°¬h¥¸Wà*\‰I˜'bé]‚^4Ôco4±PDD9‹ˆÒÌQŸ{*Ë[ÐTž•¡‰7ˆh­|EDDÔàüE_»Â¥¸“ð¸ˆÖ˜†ë±™z¬€íp±ˆˆr QÁê0KDwj*Ó0Ñ÷T–噊ß+ÃöXYDkm€íñWÑn íó!|Kô•ûp.ÀŸq—ˆöº›©Ë>¸XDÔb¡ˆ(ÉPu˜-¢;T¦A"¢îo*Ç˱‰òœ9Ê°¯ˆöèýa¤ˆˆöøO|K,98ÄÆX =ø)îÑ~RŸýDDM¦+ßõ sED'YFD´Úý˜3P9z”édåØ_D{¼GáqQš/áh±$¦à×8Àl±4zE_ú£ú¬ ¸JDDFˆ¨Ç(u˜®}F‰è;s•i¸ˆhµ[ýŸ¦2 ÆÁÊ3(ì!¢=Fb_eª: Ñ:ŸÆÑbqLÁ÷± VÆ;ðkÌKkšèKÿÀ ês€ˆˆr QQê0Gû4DôÙÊ´ŒˆhµýŸ¦2¼c”ç4,P†ýD´Wè#DD´ÆÇðY±(žÀ)Ø«âÝ8 Dt¶ Ôç4DD f(ß(õ­SED'."ZíZÿg 2ô(ÓÉÊñ&íµ Vý:C¯:ŒÀ#""úÖ[ññR&áø¦‹è>àê²6¶Ã_EDé(ß(õ©SEt§'”i²Lµ¦Îr•ÿ3P÷[»+Ï=¸X6Æ"Ú«Ãñ%aš:ŒÑ·^Š2§â8\.¢»]ˆ .‡á¯"¢tS•o”ˆ:ŒVi"ºÓÊ4LYÖÑ¡šºß¡¨<§a¡2ì'¢ôˆv!"¢ïLÀ)hŠçz_ÆËð\.¢ûMÅ_Õç ¥›£|£DÔa¬zLd„ˆh‹¦î×£L'*Ç›Dôõ°½Î0_–Ñ7VÇÙ*žé5ñqÜ'¢,¿SŸÑx½ˆ(Ý4å"Ê·¢z<"¢;=®LCDD[4u·­°™òÜŽ«”aŒÑzt†™˜¯|+ŠˆXzCqVO{Áêø fŠ(ÓïÔéí"¢tÓÔaå[M=ÑW¦á"¢-šº[2¤ûŠè_oÆPaªò­("bé}/Oz_ƺø&Q¶Ix@}vÚ"¢dÓÕaUå[I=ÑS¦eED[4u¯A8D™NVŽýEô¯‘ØWgxLù–±tÞ…ÃÄ“NÁºø8¦Š¨C/~«> ¼]D”ìQuXQDùVQ‡'0SDwzL™†ˆˆ¶hê^{c¬ò\”al#¢ÿõè S•oeKn<¾-nÂkqîQŸ_ªÓ[±Œˆ(ÕÃê°ªˆò­¦‰è^S•iyÑMÝëe:I9öÑvÁúßcÊ7NDÄ’Š“0X½àK؈¨×y˜©>«`?Qª9˜¥|+‹(ßêêp¿ˆîõ˜2-/"Ú¢©;-½”éåøo4Ð@ 4Ð@ 4Ð@ 4Ð@ 4Ð@ 4Ð@ 4Ð@ 4Ð@ 4Ð@ 4Ð@ 4Ð@ 4Ð@ 4Ð@ 4Ð@ 4Ð@ 4Ð@ 4Ð@ 4Ð@ 4Ð@ 4Ð@ 4Ð@ 4Ð@ 4Ð@ 4Ð@ 4Ð@ 4Ð@#1[8\ÿ{LùÖ±dþ ª×MØŸÀu›ƒß©ÓûDDÉT¾ÕE”o]u¸[D÷zL™–à ÑrMÝéP TžËq»ˆö˜ÓÕã4ô¯©Ê·–ˆˆÅ÷j¼O½þp¥ˆxÚ/Õé•ØJD”jŠò­+¢lñŠ:Ü-¢{MU®q"¢åšºS2*¢½&ªÇºØAÿzLùc%‹n~¨N³pÞŽÇEÄ3ýsÔé#"¢T÷*ߺ"ʶ®zÜ+¢{=¦\+Šˆ–kê>ã±…òôâ$íu!þ®=ú×=ê°–ˆˆE÷¬§>Çö8ID<Ÿiø:½kˆˆݯ|«`˜ˆr­«w‹è^*× "¢åšºO2]„ûE´×BüT=Ä0ýç>ux™ˆˆE³þC}.ÂÖø›ˆx1§ªÓ|HD”è>uXGD¹6PÉ"º×c˜­Lkˆˆ–kê.ËàPe:QDÿø©zŒÀ›ôŸ{Õa=‹æ; .ga7<$"^Ê™˜¥NïÄ8Qš»Õa]åÚL=îÑÝîQ¦µEDË5u—×aœòÌÇ"úÇd\¬=úϽ갱ˆî4H´Ó›ðJuù)öÅã"bQ<Ž3Õi8>,"Js§:l.¢\ãÕá~ÌÑÝîQ¦uDDË5u—#”é|<$¢ÿLT±†þñæ)ßF"ºÓ0Ñ.ƒðUu™ˆ,‹ãgêõ>Œ%¹SÆ‹(ÓP¬¯wh¿"úֽʴ¶ˆh¹¦î1¯S¦“Eô¯Sñ¸:4p¸þÑ‹û”o ñÂÞƒuÕãD¼½"bq‹Õi>$"Jòf)ßæ"Ê´šêp³ö!¢oÝ«Lk‹ˆ–kê‡`噋_Šè_Óq†z†þq¯ò ÆÚ"ºÏÑËâSêq.ŽÄ±$àõúƉˆ’LV¾µ1BDy¶PDt¿{•i9Œ-ÕÔ=z”é·˜&¢ÿMTu±ƒþq§:ŒÑ}†ˆvxƪà 8sEÄÒ˜¨^£ðQQ’[Ôa3åy¹zÜ ¢ûÝ©\›Šˆ–jê›cKe:EDg¸÷¨Gþq³:LÑ}‹VŒW‡‡±7¦‹ˆ¥u#®P¯`eQŠ›Õakåy¥zÜ(¢ûÝ¢\[ˆˆ–jê=Ê4 gŠè ñ3õ8õßÍê0AD÷+ZíH¬¤‡â.ÑW~¨^CðyQŠ›Õa;eY©Ã£¸OD÷»³•i ÑRMoªLgc¶ˆÎ1Q=F`?íw«:¼ Ýe¬h¥ø¨:|¿}éDÌP¯#±™ˆ(Á ê°ƒˆ²l‹†:\-¢ ½¸E™¶-ÕÔùöÀ ÊôsåV\¢=ÚïV,T¾QXWDwYA´Ò^x™ò]…OŠˆ¾6 '¨Wß%¸ ó•oU¬.¢¯TkD”ã&eÚDDË4u¾#”i~/¢óLT°–öš‹;Õa{Ýe¬h¥w+ß¼óED+¯n»âu"¢ÛÍÃê°½ˆr¼R=®QŽ[”iÖ-ÓÔÙÆâõÊt:æˆè<§à uhàpíw“:¼JDw+ZeMì©|_ǵ"¢U®ÃÅêv†ˆˆn÷7uØQD–Åvêqµˆrܨ\¯-ÓÔÙÆ e:EDgš†_ªÇhh¯›Ôa'ÝeuÑ*oGCÙÀçDD«}[ÝÖÆGDD·»JvQ†±Œ:<‚[E”ãfåz•ˆh™¦ÎÖ£LSp¾ˆÎõõX¯Ò^W«Ã:XYD÷x™h…&Þª|ŸÂlÑj¿ÄÝêö ¬%"ºÙê°.ÖÑývUËD”åfÌV¦WŠˆ–iê\›b‚2†":×y¸_=z´×U걓ˆî° †ˆVØ«(Û˜("Úa>¾£nCq¼ˆèf×`:ì*¢ûí¡—ˆ(Ë|\«L/Ã*"¢%š:Wr,¢³-À êq†kŸÉ˜®»‹èŠV9Pù¾„"¢]~ˆYê¶;Ýj6®W‡ÝDt·—a]õ¸DDy.S®EDK4u¦x‹2݃‹Et¾‰ê±,öÓ>½¸Jö@CDçÛT´Bû)ÛÝ8ED´ÓTü¯8cED·ú«:¼ˈè^oRy¸DDy®T®ÝDDK4u¦Ý°¢2†…":ß͸L=z´×•ê°"¶Ñù6­°VV¶oa¾ˆh·o`žº­€ãDD·ºH–ÃN"º×¾êq9f‹(Ïʵ'"¢Ï5u¦å:QD÷˜¨;a-ís…zì%¢óm-ZáõÊ6ED¸?‡`?Ñ.R}Et§U°½z\(¢L“1U™VÂV"¢Ï5užå°2Ý«Dt“1G8\û\©{‹èlð‰h…×*Û¯0UDô—¯¡WDD·¹W‡7¢)¢û샆züQD™zq¥rí-"ú\Sç9ƒ”éDÝe*ÎT#ÐÐwâ>uØkˆè\Ûc€èkc±¥²Mýé&üJŒÃÑÝæê°2¶Ñ}öWÇq‘ˆrýI¹ö}®©óô(×)"ºÏDõX¯Ö>ªÇ":×N¢^ƒ†rMÃù"¢¿}^<éuxˆè6ç«Ç›Et—Õðõ¸sD”ëBåzV}ª©³lŒW(Óõ¸^D÷9ªGö¹P=ѹv­°‹²ƒy"¢¿]ƒÓÄ“¾MDD79_=ÆÝãp4Ôã÷úß­s)f)S‹ˆ>ÕÔYz”ëdÝiNPý±¬ö¸P=¶Á":Ï8l#ZáUÊv–ˆèÇ W Á©XVDt‹p:¬ˆÝEtÃÕå·úß­3V®CDDŸjêp˜r,¢{MTáØ_{LÆ}êqˆÎ³'š¢¯ džÊvž¨Ý`Ñ)nÄ©âIãxÑM~§‡‰èÛbõ¸“E”ïåÚ‰ˆ>ÓÔ9vÅJÊtnѽnÄêÑ£}.T·Šè<¯­0Måºÿµ*:Ég°@<éP¼CDt‹ß©Ç1JDç;R]~%¢(Û¡"¢Ï4uŽå:ED÷û‰z¼/ÓªÇØNDç‚=E+LP¶¿Š`ˆè$·àGâißÁ6"¢\Œiê0‡ˆèl£p¨ºœ)¢×â1å:DDŸhê £ñFeêÅÉ"ºßɘ«GhsÔåm":Çë0R´ÂË•ír 泘%ž4g`%Ñéæá7êñ>­ÃÕã\&¢ ñ[åZ¯}¢©3„ÁÊt1îÑýÁYêqZï^\­bYáÑ*›*Û"XAtšð-ñ´Up‹ˆN÷KõØ;‰èLM¼_]NÇBõø•²½ODô‰¦ÎУ\?QŽ‰ê±^­=ÎR8\Dÿ‰7ˆVYGÙnÁj¢} ‰§m‡£!":Ù9xB=Þ'¢3í†uÕådu9s”k¬/"–ZSÿÛÛ(Óœ!¢çàêÑ£=ÎR—£ÐÑ¿ÂPÑ Ëc¤rMÇý"XYt¢8Z<Ó!ø”ˆèd3ñ;õx#VÑy>¬.÷à¯"ê2ç)Û{EÄRkê=ÊuQŽùø™zìeµÞÕ¸_=ÖÇ"ú×;E«¬§l÷Šxʪ¢SMÄUâ™>‹ÃDD';U=âC":ËVØM]NA¯ˆúüJÙÞŽq"b©4õ¯&Þ¢\§ˆ(ÏOÔc8ö×z½øº%¢ÿŒÇÑ*ë(Ûý"ž²¾èT q”x®ÿÅî"¢S‰Yêñ,'¢s|B}~"¢Ng¢W¹†ãƒ"b©4õ¯]°ª2ÍÅ"Ês®Q#µÇ™ê²;¶Ñ?>(ZiMe›"‚aXKt²‹q¢x¦ep:&ˆˆN4gªÇp¼_DgØûªËÕ¸^DÂÅÊöAŒK¬©õ(×ï0MD™&ªÇŽXGëý©ËÑ"ÚoE*Zie›"‚-Ñî#˜.ži8ÎÁ&"¢ýT]ŽÂ0ýï?ÑP—Ÿˆ¨Û‰Ê6 ïK¬©ÿŒÂ¾Êu²ˆrˆyêq„Ö›‹SÕel,¢½Þ‡A¢•–W¶"ØNtƒñqñ\ãp.Öæ¸_=ÆâÝ"ú×F8D]æàDu; ó•í#%"–HSÿy3†(Ó,œ%¢\ãlõ8M­w¢º4ðií³,Þ+Zmœ²ÍÁŽ¢[ü®ϵ*ÎÅj"¢“,À êòqŒÑ¾„êrQ·‡q®²ÅÑ"b‰4õŸå:³D”m¢z¬‰´ÞE¸G]Ä&"Úãý+Zme›%j· ^#ºÅB¼ Äs­ ±šˆè$?R—±øˆˆþ±=Þ¨>?Oš¨|GaM±ØšúÇúØN¹NQ¾ßá!õèÑz q’º4ðU­·,þ]´ÃXe›'j÷j,+ºÉUø–x>ëàB¬&":Åd\ .Áò"Úï«ês=þ""žtQ¶!ø²ˆXlMý£G¹¦ã\囇“Ôc?ŒÐz'ªÏëð­õo+ÚaYe&j·¿èFŸÂ-âù¬ƒ?c]Ñ)¾¯.Ãñ)íµ^©>ßO›ƒŸ+ßÁØFD,–¦ökâ-Êõ ÌQ‡‰ê1 h½I˜¤>ÿ…†ˆÖX Ñ7‰š ÃA¢=w W<Ÿ—áOØLDt‚_áAuy/6ÑCq¬ú<ŠDÄ3ýPŽÇ@±ÈšÚog¬®\§Š¨Çµ˜¤=Úãûê3‡‰hÏb¸h—QÊ6XÔì@ŒÝê/8N¼Up¶ým.þG]à¿E´ÇÑXK}¾Ù"♮ǟ•o<>""YSûõ(ל'¢.ÕãUXGëý 3Õç¿°œˆ¾µÞ&¢ïŒ5{èvÇ-â…ŒÃØSDô·ã1W]vÆ"Zk|T}æá»:Û²"úÇ÷Ôá3XGD,’¦ö‰7)×/°@D]~Žùêq„Ö›Ÿ©Ï ø’ˆ¾ÓÀñ Úe¨òµÚ[‹n7oÁ|ñB†á,¼UDô§‡p¢ú|ÃD´Îq¬>?Å}:Û@ýã—x@ù†âûhˆˆ—ÔÔ^b¨r$¢>Sðõ8M­w¼:½ ÛŠèoǶ¢šÊ7NÔ꣢WâsâÅ Àÿâ hˆˆþò_ê³¾(¢5Å^êÓ‹¯Šˆ2ßU‡×â"â%5µWrÝ‹‹EÔé'ê±&vÒz“p‰ú4ð} ±tVÂWD»ÍR¾5E¶ÄDI¾„KÄKùNÁ0ÑnÄÙêóAl+¢o­„ãÔé4Ü&"^Ìñx\¾†-DÄ‹jjŸõ°ƒrŠ…"êô<¢=ÚãÔis#bé|cDô½Õеù¤(Í‚©â¥€?cUѾ¢>MLÄ`}çxŒQŸ^|QD¼”G0Qã$ /¨©}W¶“DÔk.NTý1Rë‚{ÕécØNÄ’éÁD™¥lË` Q“­ñ&Q¢»ðV±(&à*¼ZD´ÛÅø“úl€O‹è‡bu:‹â¿°@6±"â5µG‡)׸RDÝ&ªÇP¨õæâ[êÔÄO1\ÄâYßýi¦òm"jò5Q²_â»bQ¬ˆóðÑnǨÓâ•"–Î:øž:õâs"bQ݉“Ôãx»ˆx^Mí±ÖT®EÄÕ¸N=z´Çð˜:­‹ãD,ºep2FŠþô¨òm"jq^-J÷\#Å@‡“1BD´Ë…ø“ú4qƈX2ƒp FªÓ‰¸QD,Ž/£W=¾‡DÄ¿hje;ED":ÁåÛAÔà³XCÔâ.‚…bQ­‹Kña4DD«]„ߨӾxˆÅó¥^ßÁ]"bI|½ê±~‘"âÿ¯©õÀ0å:ED<í8W=GSëMÁÕkNÇhÏosü?±(†k½{•oU¬.Jör|XÝFªÏ98F,ŽÁø&~UDD«}½êt,¶±h6Ä ê5_KêFœ .[â—$"þšZ¯GÙNÏ4Q=VÇÎÚ㫘§^ëâ ñlËã×&Å2Zï.uØU”j0~ŒêÖT§/à×bqí‚ëp€ˆh¥I8Aá—XYÄ‹[gb¤zƒGEÄÒ8óÔegœˆ"BSk­W)ו¸]D<ÓYxT=z´ÇÝ8^ÝvÃwEüÓ0œ…µD'ù»:ì%Jõel&jÕ‹·àobqÁ©8 Ë‹ˆVù8W§•p‹x~p ÖS¯ñ]±´îÄwÔg?ü"*×ÔZ‡+ÛÉ"â¹æà$õxFj/ã u{'>"‚ø9¶æNu؃EivÇEífâ xH,‰ýq#Þ""Zá>|M½¶Å÷E<¿oaWu; óED_ø"¦©Ï;ð=4DT¬©u8B¹zqŠˆx>Õc(Ôà8ñ5$jÖÀñx£èD7a¡òÄ¢$«áç"žòw싹bIŒÃ ø=Ö}ík¸[½ŽÀgE<ÛÇðu; 版¾ò>«NïÆ÷ÐQ©¦Öy5ÖR®‹q¯ˆx>WâõèÑ>_Æ£êÖÄOñQ«cñvÑ©Çíêp°(Å œŠq"þé¯èKcW\O`°ˆè+³ñauû4Þ!â)Gâ+ê6G‰ˆ¾öÜ¢NïÆ1@D…šZ§GÙN/æ§ê±ÖÓSñ%± NÅ΢6_ÁE§»^öÅ8Q‚ïa;ÿê$ü§XCð܈½ED_9çªÛñxƒ¨ÝëðCñq< "úÚ<|H½Þ†S0LDešZcYì¯\ qºˆx1'`¡z¡}þ·‹Á8¯5hà›ø˜èרà )ºÝ¿ám"^ØWñ?bi­³ð[l,"úÂû1G½š8;‹ZíŒÓ0@Ý.Ã÷DD«œƒÓÕk?œåET¤©5öÇpåú/末G ©=æâßÅ“†âwØC”¬‰ïáâ[\¢ïÇ@Ñ­öljç3X<Óð+ÑöÄßp«nCq6vµÙgc¨ºÍAŠˆVúfª×¶¸ ˆ¨DSkô(Û©"bQLTÕ°‹öùÎOŠ3q€(Ñ`œ‚w‹¾0X{\†…ê°Ýh'œ€¦x>CÅ3-ÀÁø£è ð.LÆ1)"–Ô×qº ÅÙØYÔbgœ¡âS¸YD´Ú½ø´º½ —`hê{káÕÊ5§‹ˆEñkLUíõAÌOZ'ãm¢$£ñì/úÊPí1שÇÑ(ºÉ6ø5†ˆXtO`_\)úʲø îÀ`¨ˆX\óðV,P·¡8;‹Òí…³1T\Šo*Çhí8\¦nËá·ø š" ÖÔ÷W¶s0MD,Š98I=öÅ(ís¾!žÖÄð4E·[—âU¢[ýQ=6ÀÛE·Ø¿ÃHñb‹ç3 {á&Ñ—Æâk¸Á²"bq\‰¯Š¡8û‹R‰31TÌÂaX "ÚeÞ†¹êÖÀ1ø ƈ(TSßjàe;ID,ŽŸ¨Ç¼Y{}w‹gú~‰eE·Ú—aÑÍÎU—c0Jtºmp!–/e¨x!S°n}m%|wá?1JD,ªc0I,ƒSð.QšOâÇ žt&‹ˆv»ŸOÚ“°³ˆ5õ­Wamåš…³EÄ⸠·¨Göšw‰çzþ‚—‰nÒÄ'ñ[ŒÝîO˜£+âË¢“½¿ÇHKï^ì„ÛE+ŒÅ—q¾ŽÕDt—ñ2í5‡cŽhâxƒ†èvñ=|^<íø_Ñ_¾‚KÅ“VÃùø†ˆ(HSßêQ¶³1SD,®‰ê±Ö×^çàgâ¹Æãjì+ºÁ8üŸGS´Ê@íó8þ¤.ïÆ¢í‡s1R,ªÁâ¥Ü‹p§h•øîÀ x…ˆÎ5o¸Gh¿¿ácâiŸÁ)&ºÕXœ‹÷ˆ§Ý…wˆˆþ´‡c–xÚ‡p5^.¢M}g8P¶“DÄ’8 Õ£Gû}SÄsÆ8ƒE§Ú “°›hµeµ×/Õ¥0Rt’áT ‹c¨X÷b7Ü)Zi¼—ãR‚A":ÃËðYÜ…ÓñOÙEÿ8爧€‹±¦è6›ã*ì,ž6oÆTÑßnÇÄ3m„ËðmŒÑåšúÎ~XV¹¦ã±$îÃÔãp4µ×#x§x!À%ØTt’aøÎÅ*¢Dg`¡º¼ Ç‹N° ~€o¡)¢u&cGÜ.Úaü÷âkXWDû-‹\ˆ;ði¬êÙ¶Åí׋#ð€xÚx\ŽW‹nq0.Ášâ™þ—‹ˆNñ#œ"ž©‰âf(¢‹5õe;sDÄ’š¨«bí÷+œ ^È–¸ ŸÄ2¢¿íŒIxŸÎöW\§ƒµ×C¸P}ƇDZàbI ‹ã^¼׋vYÿÛp!Dz"Zg(öÃÉxÿ¯öÂ`'ýã!ˆâi+à|D§Zÿ‹1L<ÓÏpœˆè4ïÂâ¹VÆ)ø=¶Ñ…šúÆØIÙNKãW˜¦=úÇq·x!ƒðy\-E‹ÿ‡ó±®Îv'vÆ7•c¨ö;Q¾Ž=Dx5®Á+ÅÒ$׃Ø׊v{5~‚ñì‚"–ÞP¼'` ~7c¸E³«þs>!ž©‰OãXMtš­pÞ*žëZ¼SDt¢i8sÄóÙ×à'X]Ä’Yÿ‰h£¦¾q8Ê5Kã œªûb”ö›Š·`¡x1[à |cE; Ä{q+zt‡`¦‹¥q*fªÏœŽ­E» ÄpVKk¤XS°.ýa8Çpþ¯DCÄ¢[ïÀ™x¿Æ[0ÜâÛEÿúNÏõ*LÂÁ¢ ÄѸë‹çš‚}ñ¸ˆèTWã½â…4p8nÅ×0NÄK[ïß _Æ»´QÓÒkàe; DÄÒš¨Cðfýã/ø’x)ð܆b h•Ýp ¾‹1ºÃø¥§ÌPŽaÚoNU§aø 6­¶!.Â'Ð}a±¤¦awœ.úÓÊx?þ‚»ñßx-Šx¶x>‡Ëq~€×cˆ¥³VÕzу›ÄsÁ‰øVýeK\Ž/ax®¹x#îîÇø‘x1Cð¸ÇbeÏ6‡ãÜï`{ÿ´ ÖÐ&MKo¬«l'Šˆ¾ðWܦGê?ÇàÏbQ,‡oã:„¦è+Ûâ8›êsñ^ÿ4C9é?T¯q¸[‹V€ÿÀµØFô¥biÌÅ›ñ}Ñ VÃûq 8ˉ5°!Þ‡_ãQüŸÂ+ÐзvÑ¿fâxL<Ÿ}pŽDC´ËP|W`KñBÞŽ¿Šˆnñ>üU¼”¡8 wâx¬'j6Gâ,<„Ÿ`w ðüöÔ&MK¯GÙîÃÅ"¢¯LTm±¡þ±cŠXTâ$\ƒÐKj[œ‰K°“îóeÜâŸfˆ¥u)®T¯q8{ˆ¾´ .Ã×0XôµÁbi-À»ñqÑI–Ã[pÆEø$¶ÁQ¢&ÆãƒøÂMøÞ€ZkýïVìyâùŒÂq1¶­ÔÀ›q>†â…|'ˆˆn2oÂÝbQ Æ»p ~‹=Ð5X˜‚co öÒöÐ&MKgT¶S°PDô•Ÿ¢W=zôŸûq(ŠÅ±NÂõ8ƒÅ¢h`7ü—àõºÓ-ø²g›¡#ôŸo¨Û²8 ïKkyK0A´ÊPÑW¾Œ7cŽè4Mì€ÏãR<‚_áýØMÑÆa/|çâQ\ƒoc?ŒÓ^»¢¡ÿ]€÷‹³.ÅD¬$úÚËñœŒ5Å‹ù1ŽÝèØ3Å¢j`Oü7ãß°¢(ÉìŠoàÜŠoá5hZ<¯Å2Ú ÑÛÛk)¼'(ÛÖ¸BDô¥ßcWu¸k`þóQ|U,©)ø>ŽÇ}â¹–Åáø6ÔÝb\êÙFã1eø5Þ¨ ÄíXCüïÅl±8†â(‘¢Õ¾}iü ãD·˜Š‹q.Á•˜%:Él‰­0[c]gs\§3|/e&¾c1U,ñiˆ†x)¿Ãë±@}ŽÁg”kÆ‹Zì³1@,‰ùø&âlÌݤ‰ÍñZìŽWaˆ¾ó\¨Å½½½–ÂﱫrÝuDD_;?S=qŽþÓÀÉ8P,ùø5NÀo1OݶÁ‘8#”áKø„ÕÀBeø5Þ¨ÿ…cÅ“nÁ!¸Z¼”Ax+>ŽÕE»|}íe8›Šn´×ã2\‰kpæˆV[ëcclŠ-°%ÖÐþ ßÒ8‡ŠE1 ÇâXL‹c]|oÁ±(.ÂNÇà3Ê5 ãEMމõ~Óp>æ‰NÓÄæØ ;aG,§u¾†i±Foo¯%´îFC¹¾ˆOŠˆ¾6 b„:œ‚ƒô¯á¸ãE_x'㧸½ê°ÀaØXY&aÌñüfa˜î÷'ì¤ÿ ÅXI¾Š/à ñ\Cу£±ºh·Ÿ G´Â²ø)ö%˜›p-®Ã¸w‰%1ëa=¬‹±1ÖÇ@Ýë·xÎ1¿Á.bQMÅwð=< ^Ì+p±¨®Ák0M½ŽÁg”kÆ‹Ú|Lj¾2 gát\€é¢?ŒÅ6ØÛb[ŒÐ>×as-Öèííµ„>Ž/*Ûæ¸ND´Âð6u˜ƒ•0UÿZ—a%Ñ—îÃÙ8 àqeÙ{ãMØJ™fcnöÂÄŠºßŸ°“þõ|O<Ód|g‹'ûñA,/úËØO´JŸÁgD©fâ6Ü‚[q&ã.<¨^C°ÖšXkam¬å”i6–Ã\cþˆ­Å☇“q,®Oˆ7áCØN,®ë±3¦¨Û1øŒrMÂxQ£ãðÑ×æ㜋ßáZ,}m &`ÆcÖÕÿVÅýZ¨ÑÛÛk ÝŠõ”ëzl&"Zå•ø‹z¼Çë[ãB ­ð8ÎÇŸð\…ùºËòx-^ƒ=±ºò½ÿëÅ݆uu¿‹ð*ýk&cuñ\à¸T¶Ã{ðf ýí<ì*ZmLÄhQ“9¸wã~ü÷á!܇à~ÌÖ‹±‡°VÅJX+c,¯^;áO:Ërø36KâbLÄ©˜®NëáÕÄ’¸;cŠ8ŸQ®I/jÔÀÏpˆh¥ÇðW\„¿àJÌ‹j6ÄæØ›b¬®3½ ?ÖBÞÞ^K`{\¬lŸÂDD«4p+ÖU‡Ë°­ÎðFœŽ¦hµY¸ŵ¸w¡Wg€±-¶ÆöØX]NÀá^ÚÕØR÷›„ñúß!ø¹x!çâ ¸HùVÅ¡8‹Nr¶í°~ñ"žm&À4LÇtLÃTLÇtLÃtÌÁBL÷O31ßSæb¶§ŒBóÀŒF#± †c$FbFb$Fb Æa,â¥|ŸÒy–ÇEX_,©Çq~‚ °@ÙÆ`ô`;±4nØ"žô|B¹&a¼¨Õœ€ƒE»ÌÁ$\ƒ«p-þ†9êµ,ÖÀ:Xëc=¬Õt—Ó±¿jôööZ?À;”m]Ü."Zé“ø¼zl„›u†÷á;¢?ÌÀßp=îÀ¸ wâ­1ë`m¬‹M°96Â`õš„íð¸—v!^­ûMÂxý¯‹±x1Wá¿qf+Ç*ØoÄNhŠNt#6í2ßÅ‘"¢T—b;i5\ˆuÄÒz gáW8³•aMìƒ7âU(–Öõx-O;G)×$Œ5„_àõ¢¿ÌÇdÜ‚›p nÁø‡î6+ce¬„U± ÖÄšXc•cÆa¾iôööZLCñ F*וx…ˆhµ5pêðUü§Îñ|Bt’Yxâ<‚‡1ÕSfb>æc&c¨§ Ç(ŒÄ(¬ˆU°F‰çz /ÇͯñÝï&l¬3¼—£!^Ê œ„Sq!è.M¼{bO¼ åø<~Œð3師‹v; ßò"¢4 1Su¦Õp!Ö}å œ q!®ÁÝa^…° ¶}é ¼SÄ3‹£”kÆ‹Ú Â‰ØOtš9¸wãn<€)xã!LÅTÌÂ<}§Qž2#0#0#0 c1c1c±<–ÇõÙÑ"ÞÞ^‹éü\Ùþßíp^£÷c ,Ð9¾‹÷Š¨Ë<ì ,ºŸáPÝïïXKçø>Þ)Çœ³q>¦é<ƒ±vÄ«±–S¦³ñôâe¸C9¦a´èëâl%"Jó&üRçZçbSÑ Óñ\‚kqÔÿbl…­ð*l‰¦h…‹°7¦‰ç:G)×$ŒÁü‡ˆn6³0ÝSz1Íó[ÃýS#ÑÀH±¤¾ˆOj‘Foo¯ÅtvW®^¬‰{DD;ŽŸ¨Çž8Gçhâ"¢ïÂ,žÿÁ»u¿°ŠÎ1 7b±$â\„Kq&£Wû,M° 6ÃŒÇ@å»Ûbª§ ÀãXF9¢¿ —ðQ’ïá}:Ûò8›‰vø®Æm˜Œ;0wb®¾5ë`¬ƒµ±)6ÇÑ¿Â!x\<Ÿcq”rMÂxO€ãñv±¤®ÁVZ¤ÑÛÛk1¬Š»ÑT®‹ð*Ñ.Ãñ –U‡SpÎ2'à`åû:þÃâûþC÷›†Ñ:Ë>ø•è+³p3nĸ÷àALÁlL÷ÒFb$F`%¬ˆ°ÖÂË°6ƨÓcØ·y¶›±rŒÂtÑŸvÆD¬."JpÖ×ùFál¼Rô§©˜‚‡ñ0Å ,Àx³DC0ã0+a,†ˆþô#¼ Ä 9G)×$ŒñO |Kje<¨Z<‡¡©l'‰ˆvš…Óp¤:ì‹åð˜Î±=X¯Q®ðQKf¦2,«óü'á`цc&xq 0s0#<¥‘âÅÌþ¸Í¿º (Ç(LýélŽãp˜ˆèvëa Ü­³MÃî8 oýe4Fc=Ñí>/‰ˆx¶^ü'Â7DĒص@ÓâéQ¶…ø…ˆh·‰ê1ë'cG< "^ÌOñ*Ü'"bñ݉mq¶ˆXT{j¦E³F)Û¹˜&"úËø“z†:Û'qŠè>c7LÓ7f(Çpk!Å-":ÇÑøŒEsæ*ÇÑɦã(¼Wˆˆn²‹ît&àrñ\sñn'DD,¹ØÇ WD¼”=µ@Ó¢9BùNým¢z¬„Ýu¾ã°?Ñ=þˆÝ0Mß™¡ƒt¶éx#¦‰èÃW,º…˜¬cD7¸Ûâ}˜*"ºÁnº×Ø?O» ;àû""úÆB|{cªˆx10Nkzi+cwe›³EDûf©GîðK¼‰è|§c/ÌÖ·f(Ç(ïfì‡y"úÇB¼_³ø&+Çò¢[,Ä÷°ŽÇBÑÉ^‰!º×¼ oÅ"êvÆãJ}ï·Ø—ŠˆÒÀúXÓK; Me; 3ED›‰_¨Ç>XNw¸[c’ˆÎõ¼Oè{S•c„îp>Ñ~ã@üÐ’¹M9Ɖnó0Þƒ­ðgÑ©†b{ÝïÿakÜ"¢>ã8ÓDD´Î]Ø_/d}¬é¥õ(ßÉ"¢SLTA8X÷ø;vÀé":K/>†`Ö˜¡Ëê§àßD´ÏÃا[r·(ÇŠ¢[M«±?nhe¸0QD=.ÇxüPDD{ÌÃ`7Ü/"žk4õ¡¦·56R¶éøˆèÆßÕ£Gw™…p4Šè³°/¾¦µà eXVwùŽÑz7b[üÕÒ™¬«ˆnw:6Æû1EDt’]•cŽÄÁ˜*¢\óq vÀ­""ÚïØ¿Ï4ô¡¦×£|g`Žˆè ñSõx6Ö]zñì)"úÏÝØ¿Ö3”aYÝç+8ZDëœíp»¥7Y9–GSt»ùø.ÖÁg1KDt‚ £,'c3üQDy&áø,拈è?àŠ‡EÄÓöÔ‡š^Ø`¬|§ˆˆNóuéÑþ€ñø³ˆöû=¶Â$í3CFéN_ÁçEô­^|û`º¾q/žP†X^”bŽÁZøžý©•ç^¼ïÇ,Ýo.>‰WàZãDlŒ_ˆˆ'í©5½°7`´²MÁy"¢ÓÜŽ¿¨Çá¨;Ýñ9,ÑŸÇ^xD{ÍP†º×§ña}ã1ì…Ï`¡¾Ó‹Éʱ’(ÍÃøÖÆ·ñ„ˆè/»*S/¾‹Íp¡ˆîu6Ã1ODD療°îQ·­1VizaG(ߘ/":ÑDõX{è^ ðìˆ;E´Î?°>Úoª2,«»‹C1OÄ’û 6Ç9Zc²r¬,Jõ>„µñMÌí¶‹²Ý‰ñ6<&¢{<„#° ní2TD,©3±1¾…"êÔÄnúHÓó[ {(ßÏED§: ³Õ£G÷»ãñÿDô½s°9ÎÕf(òºß‰Ø3D,žø ^ƒ{µÎmʱ’(ÝøÖ—1MD´ËÚX[ÙzñclˆŸ‹èl p,ÖÇOÑ+Úi°ˆX3ño EÔiw}¤éù½”í~\,":Õ üR=^±ºßt¼{ã~Kïq¼{á!ýk†2,§ ¿Ç6¸MÄ¢¹ÛásX µnQŽ•E-ÆDZ:þ÷ŠˆvØEÂ[°®Ñy~-ðaLѽ®ÇkðfÜ%¢.{ ¡4=¿å; ED'›¨ƒp°rü›à"–ÜEØßE¯þ7C–SŽ›° ~/â…-Ä·°%®Ð“•cMQ›ø:ÖÆa˜$"ZiWuù¶Âñ˜ˆþw=öÄî¸ADD9NņøLQ‡±¥>Ðô¯^ŽM”ïÑé.À=êÑ£,Sñ.¼ 7‰Xt3p^ÛtŽ™Ê°œ²<†½ðeôŠx¶ë±þ kŸÉʱ¦¨Õ<ü ã±ÎÀÑ×vFS]æ㿱ŽÅ<íwŽÄ–8GDD™æàëXßÀ"Ê·—>Ðô¯z”ï\.":ÝBüT=&`Så¹[ࣘ)âÅýã8,ÔYf(ÃrʳÇnxP³q4¶ÂåÚï>ÌV†5Eð'쇵ñU<,"úÂüÃÔé1|ãdôŠh½{ðl„‰˜/"¢|àß±6¾y"Êt;îÔšžmV¾“ED·ø‰ºô(Ó<ü6ĉ"þÕd¼o½:ÓTe­\ça œ#jv6ÄW0Oÿ™¬ kˆø§»ñŸX ‡âO"bILÇ7±.öÇLu›Œƒ1çˆhña¬‹ã1WDD}À»±.¾y"ºß\œ†]°~®4=ÛÞ£|'‹ˆnq.V·` r݇C±-.Á | ›àlm†2 Â0åz{áí˜&j2 ¯Á~¸Gÿ›¬ Ã1VijÍÁ‰Ø â¿ðñR.Ã;°*>‚»Ä3]ƒ=±ÎÑ7îÁ‡±6ŽÅ\q7Þ—áXÌÑ}®À° ÄùèÕGšž­GùnÀu"¢›üT=VÄÊwvÀ¾¸NÔh¾‹õð5ÌÕùf(ÇrÊÖ‹ÿÅ&ø(Ý=x¶Â…:ǭʱ¦ˆv >ŠÕðzœŽ¹"âiSð-lŠmñ#Ì/æRìíð+ôŠX|Ã[°6ŽÅã""â¹îDZ>‰‡Dt¶;ñl‚­ñ<¢šþiEì©|§ˆˆns žPuèů0ãfQƒ^œ„ñ~üC÷˜¡Ë©Ã}ØâQšGðl€c¡Îr«r¬)â¥ÍÇÙØ+á}¸HD¦ãÿaO¬Œà bq]Š}±!¾'D¼´?`7lŸc¾ˆˆx)â‹X=¸ZDçxßÆvXGãF-ÖôO‡b ò("ºÍ4üR=^±ê±'c3‰ÛE‰zq 6Å!˜¬ûÌPŽqêr6Äð„èvàh¬…oâqi²r¼LÄây ßë°&>Š«E”m*NÄ>XoÅ9X –Ö­x7ÖÀðˆˆg›‰bÆcsŒÇæXEt‹é˜ŒÛpnÆ ¸Oˆè[ð=vĎ؃ŢšI¸ —àÜ.""âÅ ÄØ[`<6Å0Ñ sqn¸ 7âf̽½½"""*ÓÄ&ØÛa{¬§³q5.Æ_ðW<&"–Æ l±#vÀ²Ê÷.Ç_ñg\Ž'DDt‡ÑØ`Sl„õ±&ˆvêÅý¸wá܆ɸSDôŸÁØ0°9‰…¸ Ãå¸WáqKoÖÃ-° VCS¼”鸷c2nÇdÜŽ{±P¼ Foo¯ˆˆˆ0Ûb+l†M±ènãzü Wá*ÜŒ"¢•`<^-±6Ã`ÝëAü ×â\‰É""ʳ ÖÂúXë`-¬…51R,Ž^<„ñîý¸ wã.Ü‹¹"ºÇ2Ø°)ÖÃFX ”é~܈ëð7ü 7â í5kc=¬‹u±>ÖÁ l½xSpîÁ½¸÷àï¸3ÄkôööŠˆˆˆç5cSlŒµ±&ÖÄÊ:Ç Ü‰Ûq;nÇ͸SDD§ˆ±ÖÇúXëc´Î0wá.܆›p+nÂñ¤ÑX«`u¬„U±*VÄŠXC”k&Â#x` Æ#¸â^<„ù"ê° ÖÅúØë` ¬‚U1V皎p'nÇí¸·ãv<.""¢ó5°VÆÊX+aU¬Œ•0 £0 Ãô¯Y˜Š©˜Š©˜Š©˜ŠGñ ¦àA<„‡±@´T£··WDDD,¶ÁXkb5ŒÃŒÅŒÁ8Œò”Ñž2C<¿'0Óñ8fcÃÃxà¸÷â>LÝn$VÅjX«be,‡QÑ‘ž2ý°x³13ñÅ#xâ<€{ðˆˆˆè+ñ"Æa9ŒÆrå0Ã0 Ã1 Ã1Ë`†¡‘Ý\<îÙfb>f`¦a!¦a!¦c¦c:¦c¦a¦c:¦áÌKbVêXã°Fc4–ÃhŒÆh40 v documentation". # html_title = None # A shorter title for the navigation bar. Default is the same as html_title. # html_short_title = None # The name of an image file (relative to this directory) to place at the top # of the sidebar. html_logo = '../../docs-common/adacore-logo-white.png' # The name of an image file (within the static path) to use as favicon of the # docs. This file should be a Windows icon file (.ico) being 16x16 or 32x32 # pixels large. html_favicon = '../../docs-common/favicon.ico' # Add any paths that contain custom static files (such as style sheets) here, # relative to this directory. They are copied after the builtin static files, # so a file named "default.css" will overwrite the builtin "default.css". html_static_path = ['../../docs-common'] # If not '', a 'Last updated on:' timestamp is inserted at every page bottom, # using the given strftime format. # html_last_updated_fmt = '%b %d, %Y' # If true, SmartyPants will be used to convert quotes and dashes to # typographically correct entities. # html_use_smartypants = True # Custom sidebar templates, maps document names to template names. # html_sidebars = {} # Additional templates that should be rendered to pages, maps page names to # template names. # html_additional_pages = {} # If false, no module index is generated. # html_domain_indices = True # If false, no index is generated. # html_use_index = True # If true, the index is split into individual pages for each letter. # html_split_index = False # If true, links to the reST sources are added to the pages. html_show_sourcelink = False # If true, "Created using Sphinx" is shown in the HTML footer. Default is True. html_show_sphinx = False # If true, "(C) Copyright ..." is shown in the HTML footer. Default is True. # html_show_copyright = True # If true, an OpenSearch description file will be output, and all pages will # contain a tag referring to it. The value of this option must be the # base URL from which the finished HTML is served. # html_use_opensearch = '' # This is the file name suffix for HTML files (e.g. ".xhtml"). # html_file_suffix = None # Output file base name for HTML help builder. htmlhelp_basename = 'GNATcoll-Iconv' # -- Options for LaTeX output ------------------------------------------------- # The paper size ('letter' or 'a4'). # latex_paper_size = 'letter' # The font size ('10pt', '11pt' or '12pt'). # latex_font_size = '10pt' # Grouping the document tree into LaTeX files. List of tuples # (source start file, target name, title, author, documentclass # [howto/manual]). latex_documents = [ ('index', 'GNATcoll-Iconv.tex', u'GNATcoll Bindings - Iconv Documentation', u'AdaCore', 'manual'), ] # The name of an image file (relative to this directory) to place at the top of # the title page. # latex_logo = None # For "manual" documents, if this is true, then toplevel headings are parts, # not chapters. # latex_use_parts = False # If true, show page references after internal links. # latex_show_pagerefs = False # If true, show URL addresses after external links. # latex_show_urls = False # Additional stuff for the LaTeX preamble. # latex_preamble = '' # Documents to append as an appendix to all manuals. # latex_appendices = [] # If false, no module index is generated. # latex_domain_indices = True # -- Options for manual page output ------------------------------------------- # One entry per manual page. List of tuples # (source start file, name, description, authors, manual section). man_pages = [ ('index', 'gnatcoll-iconv', u'GNATcoll Bindings - Iconv Documentation', [u'AdaCore'], 1) ] # -- Options for Epub output -------------------------------------------------- # Bibliographic Dublin Core info. epub_title = u'GNATcoll Bindings - Iconv' epub_author = u'AdaCore' epub_publisher = u'AdaCore' epub_copyright = copyright # The language of the text. It defaults to the language option # or en if the language is not set. # epub_language = '' # The scheme of the identifier. Typical schemes are ISBN or URL. # epub_scheme = '' # The unique identifier of the text. This can be a ISBN number # or the project homepage. # epub_identifier = '' # A unique identification for the text. # epub_uid = '' # HTML files that should be inserted before the pages created by sphinx. # The format is a list of tuples containing the path and title. # epub_pre_files = [] # HTML files shat should be inserted after the pages created by sphinx. # The format is a list of tuples containing the path and title. # epub_post_files = [] # A list of files that should not be packed into the epub file. # epub_exclude_files = [] # The depth of the table of contents in toc.ncx. # epub_tocdepth = 3 # Allow duplicate toc entries. # epub_tocdup = True gnatcoll-bindings-25.0.0/docs-common/favicon.ico000066400000000000000000000015761464374334300215570ustar00rootroot00000000000000h(   Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡Ø·¡¼“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/DAREibgnatcoll-bindings-25.0.0/docs-common/important.png000066400000000000000000000026471464374334300221610ustar00rootroot00000000000000‰PNG  IHDR"":G ÂgAMAÖØÔOX2bKGDÿÿÿ ½§“ pHYsHHFÉk> IDATXÃí—KlTUÇÿçÜ÷½ó¸wf:ÓÒ™vf -m§@ÀðªÄ -ˆ |,uAŒñ±p#k7cb0ÀNbLL ¤D1ÊK * iZ! ¢ØÖJÛ±™>èc˜÷½wîuQ m[…ü×ç|ßï|¯|x¨‡š_Ì=°!°X„x€@Ï= ÍUã Ö_px+Ðcˆ.&¼ä~&ÖúòªÆÍ;š ¡­œ <Hyݣχš¶2áU[´ÀÒÕ/…Œç?]þg+c-1Á€\ŠàŠ S–}ló+ï,ÈÞB‹Õï‹®{«þ‰×«EY‚ÓmÁíUùDïÏŽ_¿i; pÿ#B((Ã?XÞ²’“=Eš›"Z߈Ææ- ¥­÷;"€2ÀnòD6ìŒl|©Æ©ùP]ÅÀçááP$¸44øÛE%9>r3­M˜™3ó¿o8'€SB«åC¼³2 ºƒ!Áá –·ÔT®ØÆVW‰X³R‚"3 ”À(pþä‘Â/ÃɉÉxfjt|lè÷ñ\*™°aÀÆ€m[£EÓŒ˜ºÈNå;˜²fçŠ(‚3à\¢èT‰(;¡¸\pk*TMÀÚÕ ê–É` B†n`|,‰áø4Šz–™ž™,êÙ©ÂØPoúì‘C£‰kWÞpèV§ì, ÇÁH­Ô³¾‘µ2§·ÊBu³ðh ¼*‹2/‡Šrág@ÈÍ÷°Ê ·Š\¾³hÁ²lÆ2rrjêºi[ÖQÇK©‘ Óí¤0â©{cµ«*i$L 3¨‰r¨‰Š¨®Qá— ·Cü-J 8–0QÐ LNNãÌgûÓ§Úöí‹÷¿ UR±†IZ¹‘Ròi>g,´,Êhª‡ÄA–9(Qä@él™ýË™É|6“EÇу7Î~²oÏÄpÿ{„2iØwÖîì]3s0›OŽŸK÷ù9^ˆk›Y!‰d‘»#%ÿ¼NžÏãôáýéo~°÷züê.™Ù 湩L!“ìœîó ¢ØªmdE„(°à¹¹A ¹,¾ûtêØG{w ^Ù =Ÿ£RæHFϦÎǬ¶ªfD€ãÐ9@(ô\8‡¶ÝoŽ÷u¿‰YjâŽ;%€Àd&Ï÷^ü)Ë]yèz¦iÁ¶ç›Sœ NÐKqP*ˆÌ*å5yË‹¾þ²9¹¼y ÌM Û¶aš€¤–Áé Ô(i7`K9@&¬3LExÎF^7Àæ(@$‘ËØ3E ºaS<àeg-€‰EƒF†]̺ çª"œ Ž+"“5@E6ÂX(±­† 8aè& º ÝbÁÉn€ µ<48=_ˆÚŽüÐ!"øy–³JçñGÏ%ôtœëjÿúKJ©knÙÛ´ÍjX›°(6\§heu½‰¡ü„,$w­ T^RKäkY&Rãø¾óä¿;=v­ûâiœ@}.wžy1¼býS ›¶{µêFFP—°¬ ×Ý ¢´ÔBˆŽZEƒ½Ñ} w®ã«öt¢ûcSÏí³Á¶Ï&®vè]×w±ýµèÚ'·ÊÞ fYv=fšbQß  `äÏ©»ááµWT”pG£ ÷œ¬;Ê Ò) Þeo €mÂø÷«¥ à®{òPÿoý Œ‡»n£,ñ’"zTXtSoftwarexÚsLÉOJUðÌMLO JML©/œÔ® ©MIEND®B`‚gnatcoll-bindings-25.0.0/docs-common/note.png000066400000000000000000000043071464374334300211040ustar00rootroot00000000000000‰PNG  IHDR"":G ÂbKGDÿÿÿ ½§“ pHYsHHFÉk>gIDATXÃí—kl[gÇçûØq|Kâع‘‹suœÛæ¦]Òµ ÓÚµ5ë†&b€´O“úBB|BÀ$$@ã ©hRÕ‚h«Q.em¤)¬£i:'nI¶Ù^Ü&qîqm×ñíø>¤ mÚn)Ò>ðH¯^éÕûüßÿÿÿ>çyáÿñ éÖ>< ”Y hŸÝ×úûû¿þÜsÏ“$i>Dý~ÿ‰Db4®®®~$õÿ5{cccïÑ£G£ÑXuäÈ‘ªõõu_0üÒõë×3¡PèÆÚÚÚÕp8|ejjê=`˜òŸžž@Eeee«ÕjEUU¬V+V«U¨¨¨äl6ÛyóæÍÎH$òÒüüüJ8} ¹\n,™LNq@á!r~,¿ßOKK‹¯££Ã P(H&“ȲLQQ‚ `4ikkÃëõŠŠ¢8ãñ¸3‘Hô-..f'&&~¿q~~~<‹] …B×’ÉdX¸;°Ö„®®®_?~üåÚÚZ2™ ‹‹‹¨ªºq«ÕŠÅbA¯×#¢("[«ªŠªªÌÏÏk“““LNN¦^}õÕãKKKÇÕ#öææ掲²24MC§ÓQ[[K¡P “ÉËåH$¬­­QWW‡Ñh@Ó´-P’$Q__/466âõzÍ'NœÐ/--=š4¢(¶ïÚµ«Ê`0 ±XŒL&ƒ^¯Çd2a·Û)//GÓ4$i£‚°ÅÈæ÷&;@ “ËåÞÞº# ’$¡×ë½­­­N£Ñˆªª”––’J¥Èf³$“IVVVÐ4 ‹Å‚ÝnÇd2¡Óéî° L&&&ÖgffÆúúúvÎH¡PÐ÷÷÷wº\.£(Šc6›QUEQP…|>ÏíÛ·™››Ãf³Q]]}ˆ;̋ŘÌçó‹£££$³½½½Ãår°´´ÄÈÈv»ŸÏGYY²,£iÚ€íÒlÎ’$‰DXZZnoš}ËC`2™*«««Û].š¦qúôY. ó׳çøÁwŽqöÌâñ8z½~ë¦lÎÛ‡(ŠLOO«@à]ŸÏ—Ûžï¡Œ¤R)¼^¯·¡¡Á!I…Bêê*‚S!ú[J˜[Ôøû…1®ú¯sàézzz°ÙlètºûØL&ÃÜÜÜh4ŽF£ìˆ úÁÁÁ=GÈd2TT8)â5U=Tv|ºT ã㣼ö›“xÚ.ñôÓOáp8°ÙlX­VdYF–eDQ$355b£üß”Æl6˜Çn·ÛªªX,:»zhöîCäLâ%ÚZJس§ö®ÃÌD³œþãVWWÉçóD"Âá0Š¢luttôýgžyfñA9ÈÈÑÔÝÝ]¥×ëQU•ÙÙYú¿ÉðŸc8g~IEQYYIr½@dAA,Å"UDÐ)+µQZZBQ‘ñNáÚ¨ åååìò=Æz*Áo¼( ìÞÝM»·Ë”ͱ{aaÖx;7[ìé\.ó‘)Ù»wïw_|ñÅ£Afz!ÏZReaMAEbÉW¦Òh¤³J ²ˆx×/Ý`0àñ´ÑÚÒÈùóá›oj==íìß7`DSßÍ›7l+ËÑ+l¼îrøða¢ÑhëÐÐз8P¤FYÄd”0›Dry°[$”‚ÆZ²ÀªÂbLAŒ²€Nº·¬ÛívææfoÿèÇ?üí{SS!³Y®{òɽEfK©72‰[ÿÜ”é³:tˆñññÊt:­¸Ýn,f3Ó^UÕ(³¡ªW4ÒY•èŠÂJ\¡Ê¡G+([[(âôéÓs™túWo½5»üìÀÀÀ—}¾=ûË¥/ÍÌL¿L¶žµ¥¥…7n”655}Áív÷»\®ÝõõõM>ŸÏèñxd»Ý.˜L&ôz=‹……‚Á ñxœ‹/*'OžüùÂÂÂ÷ï2h¹ÉdÚ¯Ó銉ęMy>ªy6æÒÒÒš’’’=%%%Otvv¶õööV7448«ªª 555Øív6›¦x<ÎÄÄÁ`+W®d.\¸p2¯¸¸x)•Jmß_஧ÅNºø»Ãx‡§···³¹¹¹»¢¢¢£¶¶Öb6›‰F£- FÀï–——_cÛ³áañ¨@¶3æeÙYSSó¸N§«SUµH$Â+++WUU ¹O°ÿâ'<Øg#þ Þ.n¢fRÌIEND®B`‚gnatcoll-bindings-25.0.0/docs-common/tip.png000066400000000000000000000041371464374334300207340ustar00rootroot00000000000000‰PNG  IHDR"":G ÂbKGDÿÿÿ ½§“ pHYsHHFÉk>ÿIDATXÃÍ—klÕÇçÎìÃk¯ml‹Ä8N(!)!@bL¡P PC)êKU•Z µ¤V Vê‡B%*P¥RT)¨‘ª€ªªR*¨ú—ÔðHÄu¤«¹«»ç7ÿ{ÎÿÜ…ÿ“KÎõ€ŽlDA$Y¢ ¸ä®61¸4Jæj“¹$adÓÂY㘳C\‘DÁ%Y'&]o¯anRZ©C»}·ðùI jD@A5 ¤ÔI¢@ .Òd);ÔNQ§¨Ö£É@å³)¢#—7*QSÁñÄÉ€É"’Iæ’IæøÉs⟢”ÔÞJ‡òçV$ÐÚWA$Ù %¹ƒAœAmMÅEŠ .r¸Ø¢Ö‚u¨ZÔ)‚Ò M£2þrˆ&HYÊñQñió=mõ¼vÏä>8´/—­ŸÏ Qºþ&Ü|M¦ÒÓ›‰wçbTâôŨ«oöÙё˨§9*">‘,=9ïåfÚÿøôø€Ÿ-Ü ˜/ œß^ô½ ¨Î¡ñH”÷\¾Îí}øwm£­³QLGàBTcDm QuU¤¢aKƒŠHãeiÉdúíѵïáîë®îÿÖM_éë¹|Ãy[MR¦¶Ì'£Ó¼þæx´÷É¡OFg·?ñ«ü+¥D9®‚F 0Í¥8PmÙØ ’$Û¡&ƒñr´ø¹{¨·«‡—¾`ê¼5Q£‡×B\ièVP'à xüçÍÒÀ-ׯì+¶eÒôIS¨)¨4 šækWû™ ûü+·mº(’*N“"¨bPƤ§ Tæ½èüî\‡ñÓçbÔ…h 6HµÖè$ÍAM•U¥·[X¿Úô½ý¡ë¤5UBROk¸ûh|kÀ ”¹øÂÖL[¤:H«#ÆFŽPèl£«·lµUJ“³ä³2~\WØ÷ÕP»§fµ•™'ФDu¹Å'9L´j«h¼tŸ®²¦×yÿÐÌTX.A\;O6[&›pa™Œ136A¾Å‹´µ;°åTÁ 'NVùè¿öã­[dŠ9E“ÜhF®˜„–ŽÆ“U ;&ªúýÛ2¾¶orxzrìDóˆgåê +VgY³¡•b‡cÕº<½útv[ˆ°‹Ø°Ì»ÃálPfï¦[X¤Údh§(RwDWwFÔ:ÔZÂØn½Ý›ŽÃÊÎç^<¾¨ñ<Ø9ˆæð(‘ñ«œ×³îŠ-àûÄ•pl¬Ì¿_sï}÷VÞâ¤&Ç¥>£g!UÃ*êX‹ÚX².ÞºE^}áÕ©—^ë¤âæ ž%*A<‹¸Ú_ÉŒ^G”=>¾¦ýõ}Ý—PâB˜,? .…n‘A‹î7MX€C‰¡ŠYýU3WúÙô±K6l oÕ*å2ž±l¾,C¦v>3Þc‚°i;ÎX-§IÂ׎‹º"Húƒ‚SÏÓxtfzª488ØV(ð<8Ž9ztçâ±uýœ ZW¢ÒѨÆiAä*E÷+Ð Œ/ÁÔ®\{k|hÏžÝ3ímëׯ§³³“0 : Ã‡Ž<÷“Ì`O—œ§ƒX–¬MÂì_ö\r„ôñžyžÂýgSi¹;›Íæ}ßÇ©RY,è??¸ïàC ¡§øÆç9#ŒbèCný&+÷¼Ë•;º<ý=<óÁ¿Ø×éã&Ï8+Ä9AÎ# """) for pkg, f in sorted(list): if '__' in f: # An internal package with a specific naming scheme continue menu = pkg.replace(".", "/").replace("_", "__") # Do we have a submenu ? in_front = False for pkg2, b in list: if b.startswith(f + "-"): item = menu[menu.rfind("/") + 1:] menu = menu + "/<" + item + ">" break out.write(""" Editor.edit "%(file)s.ads" %(package)s /Help/%(menu)s GNAT Components Collection """ % {"file": f, "menu": menu, "package": pkg}) out.write("""''' import GPS GPS.parse_xml(XML) """) out.close() gnatcoll-bindings-25.0.0/gmp/000077500000000000000000000000001464374334300157725ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/gmp/README.md000066400000000000000000000006141464374334300172520ustar00rootroot00000000000000The GNAT Components Collection (GNATCOLL) - GMP =============================================== This is the GMP component of the GNAT Components Collection. It is an interface to the GNU Multiple Precision (GMP) arithmetic library. Dependencies ------------ This component requires the following external components, that should be available on your system: - gprbuild - gnatcoll-core - gmp gnatcoll-bindings-25.0.0/gmp/examples/000077500000000000000000000000001464374334300176105ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/gmp/examples/gmp_examples.gpr000066400000000000000000000003011464374334300227750ustar00rootroot00000000000000with "gnatcoll_gmp"; project GMP_Examples is for Main use ("square_triangular_numbers.adb", "isprime.adb"); for Object_Dir use "obj"; for Exec_Dir use "."; end GMP_Examples; gnatcoll-bindings-25.0.0/gmp/examples/isprime.adb000066400000000000000000000066511464374334300217400ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2017, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ -- This program allows a user to determine whether a given (big) integer is a -- prime number. It is based directly on the example provided by the -- underlying C implementation of the GMP. Note that the input can be -- expressed in bases other than base 10, if desired, by using C prefixes such -- as "0x" and so forth. -- -- This program also illustrates use of an underlying C library routine that -- does not have a corresponding Ada binding already defined elsewhere. with Ada.Text_IO; use Ada.Text_IO; with GNATCOLL.GMP.Integers; use GNATCOLL.GMP.Integers; with GNATCOLL.GMP.Integers.IO; use GNATCOLL.GMP.Integers.IO; with Interfaces.C; use Interfaces.C; with GNATCOLL.GMP.Lib; use GNATCOLL.GMP.Lib; procedure IsPrime is N : Big_Integer; Result : int; function mpz_probab_prime_p (this : access constant mpz_t; x : int) return int; pragma Import (C, mpz_probab_prime_p, "__gmpz_probab_prime_p"); begin loop Put ("Enter candidate number (return to quit): "); declare Input : constant String := Get_Line; begin if Input'Length = 0 then return; else Set (N, Input, 0); -- base 0 allows the input to define the base end if; end; Result := mpz_probab_prime_p (As_mpz_t (N), 5); Put (N); case Result is when 0 => Put_Line (" is not a prime"); when 1 => Put_Line (" is a probable prime"); when 2 => Put_Line (" is a prime"); when others => Put_Line ("Unexpected result from mpz_probab_prime_p:" & Result'Img); return; end case; end loop; end IsPrime; gnatcoll-bindings-25.0.0/gmp/examples/square_triangular_numbers.adb000066400000000000000000000055001464374334300255430ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2017, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ -- This program prints the first 50 "square triangular numbers", i.e., those -- that are both perfect squares and also are the sum of consecutive integers -- starting at one. The time required to calculate these numbers is also -- displayed. with GNAT.IO; use GNAT.IO; with GNATCOLL.GMP.Integers; use GNATCOLL.GMP.Integers; with GNATCOLL.GMP.Integers.IO; use GNATCOLL.GMP.Integers.IO; with Ada.Calendar; use Ada.Calendar; procedure Square_Triangular_Numbers is Values : array (1 .. 50) of Big_Integer; Start : Time; Elapsed : Duration; begin Start := Clock; Set (Values (1), To => 1); -- the first square triangular number Set (Values (2), To => 36); -- the second square triangular number for N in 3 .. Values'Last loop Set (Values (N), To => (34 * Values (N - 1)) - Values (N - 2) + 2); end loop; Elapsed := Clock - Start; for K in Values'Range loop Put (Values (K)); New_Line; end loop; Put_Line ("Computed" & Values'Last'Img & " values in" & Elapsed'Img & " seconds"); end Square_Triangular_Numbers; gnatcoll-bindings-25.0.0/gmp/gmp_support.c000066400000000000000000000025031464374334300205150ustar00rootroot00000000000000/*------------------------------------------------------------------- G N A T C O L L -- -- Copyright (C) 2009-2017, AdaCore -- -- GPS is free software; you can redistribute it and/or modify it -- under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- General Public License for more details. You should have received -- a copy of the GNU General Public License along with this library; -- if not, write to the Free Software Foundation, Inc., 59 Temple -- Place - Suite 330, Boston, MA 02111-1307, USA. -- ---------------------------------------------------------------------*/ #include void gnatcoll_gmp_test() { mpz_t integ; mpz_init (integ); } gnatcoll-bindings-25.0.0/gmp/gnatcoll-gmp-integers-io.adb000066400000000000000000000044151464374334300232550ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2017, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with GNATCOLL.GMP.Lib; use GNATCOLL.GMP.Lib; package body GNATCOLL.GMP.Integers.IO is --------- -- Put -- --------- procedure Put (This : Big_Integer; Base : Integer := 10; Stream : Interfaces.C_Streams.FILEs := Interfaces.C_Streams.stdout) is use Interfaces.C; Written : size_t; begin Written := mpz_out_str (Stream, Int (Base), This.Value'Access); if Written = 0 then raise Failure; end if; end Put; end GNATCOLL.GMP.Integers.IO; gnatcoll-bindings-25.0.0/gmp/gnatcoll-gmp-integers-io.ads000066400000000000000000000046551464374334300233040ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2017, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with Interfaces.C_Streams; package GNATCOLL.GMP.Integers.IO is pragma Preelaborate; procedure Put (This : Big_Integer; Base : Integer := 10; Stream : Interfaces.C_Streams.FILEs := Interfaces.C_Streams.stdout); -- Output This on Stream, as a string of digits in base Base. The base -- argument may vary from 2 to 62 or from -2 to -36. -- -- For Base in the range 2..36, digits and lower-case letters are used; for -- -2..-36, digits and upper-case letters are used; for 37..62, digits, -- upper-case letters, and lower-case letters (in that significance order) -- are used. -- -- Raises Failure if the entire sequence of digits is not written. end GNATCOLL.GMP.Integers.IO; gnatcoll-bindings-25.0.0/gmp/gnatcoll-gmp-integers-misc.adb000066400000000000000000000054141464374334300236010ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2017, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with GNATCOLL.GMP.Lib; use GNATCOLL.GMP.Lib; package body GNATCOLL.GMP.Integers.Misc is -------------------- -- As_Signed_Long -- -------------------- function As_Signed_Long (This : Big_Integer) return Long is begin return mpz_get_si (This.Value'Access); end As_Signed_Long; ---------------------- -- Fits_Signed_Long -- ---------------------- function Fits_Signed_Long (This : Big_Integer) return Boolean is begin return mpz_fits_slong_p (This.Value'Access) /= 0; end Fits_Signed_Long; --------- -- Odd -- --------- function Odd (This : Big_Integer) return Boolean is begin return mpz_odd_p (This.Value'Access) /= 0; end Odd; ---------- -- Even -- ---------- function Even (This : Big_Integer) return Boolean is begin return mpz_even_p (This.Value'Access) /= 0; end Even; ---------- -- Swap -- ---------- procedure Swap (This, That : in out Big_Integer) is begin mpz_swap (This.Value'Access, That.Value'Access); end Swap; end GNATCOLL.GMP.Integers.Misc; gnatcoll-bindings-25.0.0/gmp/gnatcoll-gmp-integers-misc.ads000066400000000000000000000046201464374334300236200ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2017, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ package GNATCOLL.GMP.Integers.Misc is pragma Preelaborate; function As_Signed_Long (This : Big_Integer) return Long; -- If This fits into a signed long integer, returns the value of This. -- Otherwise returns the least significant part of This, with the same sign -- as This. pragma Inline (As_Signed_Long); function Fits_Signed_Long (This : Big_Integer) return Boolean; pragma Inline (Fits_Signed_Long); function Odd (This : Big_Integer) return Boolean; function Even (This : Big_Integer) return Boolean; pragma Inline (Odd); pragma Inline (Even); procedure Swap (This, That : in out Big_Integer); pragma Inline (Swap); end GNATCOLL.GMP.Integers.Misc; gnatcoll-bindings-25.0.0/gmp/gnatcoll-gmp-integers-number_theoretic.adb000066400000000000000000000041561464374334300262060ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2017, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with GNATCOLL.GMP.Lib; use GNATCOLL.GMP.Lib; package body GNATCOLL.GMP.Integers.Number_Theoretic is ------------- -- Get_GCD -- ------------- procedure Get_GCD (Input1 : Big_Integer; Input2 : Big_Integer; Output : out Big_Integer) is begin mpz_gcd (Output.Value'Access, Input1.Value'Access, Input2.Value'Access); end Get_GCD; end GNATCOLL.GMP.Integers.Number_Theoretic; gnatcoll-bindings-25.0.0/gmp/gnatcoll-gmp-integers-number_theoretic.ads000066400000000000000000000041631464374334300262250ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2017, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ package GNATCOLL.GMP.Integers.Number_Theoretic is pragma Preelaborate; procedure Get_GCD (Input1 : Big_Integer; Input2 : Big_Integer; Output : out Big_Integer); -- Set Output to the greatest common divisor of Input1 and Input2. The -- result is always positive even if one or both input operands are -- negative. pragma Inline (Get_GCD); end GNATCOLL.GMP.Integers.Number_Theoretic; gnatcoll-bindings-25.0.0/gmp/gnatcoll-gmp-integers-random.adb000066400000000000000000000062741464374334300241330ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2017, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with GNATCOLL.GMP.Lib; use GNATCOLL.GMP.Lib; package body GNATCOLL.GMP.Integers.Random is ------------ -- Number -- ------------ function Number (State : Generator; N : Big_Integer) return Big_Integer is begin return Result : Big_Integer do mpz_urandomm (Result.Value'Access, As_gmp_randstate_t (State), N.Value'Access); end return; end Number; --------------------- -- Generate_Number -- --------------------- procedure Generate_Number (State : in out Generator; Into : out Big_Integer; N : Big_Integer) is begin mpz_urandomm (Into.Value'Access, As_gmp_randstate_t (State), N.Value'Access); end Generate_Number; ----------------- -- Number_Bits -- ----------------- function Number_Bits (State : Generator; N : Unsigned_Long) return Big_Integer is begin return Result : Big_Integer do mpz_urandomb (Result.Value'Access, As_gmp_randstate_t (State), N); end return; end Number_Bits; -------------------------- -- Generate_Number_Bits -- -------------------------- procedure Generate_Number_Bits (State : in out Generator; Into : out Big_Integer; N : Unsigned_Long) is begin mpz_urandomb (Into.Value'Access, As_gmp_randstate_t (State), N); end Generate_Number_Bits; end GNATCOLL.GMP.Integers.Random; gnatcoll-bindings-25.0.0/gmp/gnatcoll-gmp-integers-random.ads000066400000000000000000000051461464374334300241510ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2017, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with GNATCOLL.GMP.Random_State; use GNATCOLL.GMP.Random_State; package GNATCOLL.GMP.Integers.Random is pragma Preelaborate; function Number (State : Generator; N : Big_Integer) return Big_Integer; -- Generate a uniform random integer in the range 0 to N-1, inclusive procedure Generate_Number (State : in out Generator; Into : out Big_Integer; N : Big_Integer); -- Generate a uniform random integer in the range 0 to N-1, inclusive function Number_Bits (State : Generator; N : Unsigned_Long) return Big_Integer; -- Generate a uniformly distributed random integer in the range 0 to -- 2^N-1, inclusive procedure Generate_Number_Bits (State : in out Generator; Into : out Big_Integer; N : Unsigned_Long); -- Generate a uniformly distributed random integer in the range 0 to -- 2^N-1, inclusive end GNATCOLL.GMP.Integers.Random; gnatcoll-bindings-25.0.0/gmp/gnatcoll-gmp-integers-root_extraction.adb000066400000000000000000000074061464374334300260740ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2017, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with GNATCOLL.GMP.Lib; use GNATCOLL.GMP.Lib; package body GNATCOLL.GMP.Integers.Root_Extraction is ---------- -- SQRT -- ---------- function SQRT (This : Big_Integer) return Big_Integer is begin return Result : Big_Integer do mpz_sqrt (Result.Value'Access, This.Value'Access); end return; end SQRT; -------------- -- Get_SQRT -- -------------- procedure Get_SQRT (This : Big_Integer; Into : out Big_Integer) is begin mpz_sqrt (Into.Value'Access, This.Value'Access); end Get_SQRT; ------------------------ -- Get_SQRT_Remainder -- ------------------------ procedure Get_SQRT_Remainder (This : Big_Integer; Root : out Big_Integer; Remainder : out Big_Integer) is begin mpz_sqrtrem (Root.Value'Access, Remainder.Value'Access, This.Value'Access); end Get_SQRT_Remainder; -------------- -- Nth_Root -- -------------- function Nth_Root (This : Big_Integer; N : Unsigned_Long) return Big_Integer is Dummy : Int; pragma Unreferenced (Dummy); begin return Result : Big_Integer do Dummy := mpz_root (Result.Value'Access, This.Value'Access, N); end return; end Nth_Root; ------------------ -- Get_Nth_Root -- ------------------ procedure Get_Nth_Root (This : Big_Integer; N : Unsigned_Long; Into : out Big_Integer; Exact : out Boolean) is Was_Exact : Int; begin Was_Exact := mpz_root (Into.Value'Access, This.Value'Access, N); Exact := Was_Exact /= 0; end Get_Nth_Root; ---------------------------- -- Get_Nth_Root_Remainder -- ---------------------------- procedure Get_Nth_Root_Remainder (This : Big_Integer; N : Unsigned_Long; Root : out Big_Integer; Remainder : out Big_Integer) is begin mpz_rootrem (Root.Value'Access, Remainder.Value'Access, This.Value'Access, N); end Get_Nth_Root_Remainder; end GNATCOLL.GMP.Integers.Root_Extraction; gnatcoll-bindings-25.0.0/gmp/gnatcoll-gmp-integers-root_extraction.ads000066400000000000000000000067221464374334300261150ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2017, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ package GNATCOLL.GMP.Integers.Root_Extraction is pragma Preelaborate; function SQRT (This : Big_Integer) return Big_Integer; -- Returns the truncated integer part of the square root of This. pragma Inline (SQRT); procedure Get_SQRT (This : Big_Integer; Into : out Big_Integer); -- Set Into to the truncated integer part of the square root of This pragma Inline (Get_SQRT); procedure Get_SQRT_Remainder (This : Big_Integer; Root : out Big_Integer; Remainder : out Big_Integer); -- Set Root to the truncated integer part of the square root of This. Set -- Remainder to the remainder This-Root*Root, which will be zero if This is -- a perfect square. If Root and Remainder are the same variable, the -- results are undefined. pragma Inline (Get_SQRT_Remainder); function Nth_Root (This : Big_Integer; N : Unsigned_Long) return Big_Integer; -- Returns the truncated integer part of the Nth root of This. pragma Inline (Nth_Root); procedure Get_Nth_Root (This : Big_Integer; N : Unsigned_Long; Into : out Big_Integer; Exact : out Boolean); -- Set Into to the truncated integer part of the Nth root of This. On -- return, Exact will be True if the computation was exact, i.e., if Into -- is This to the Nth power, and will be False otherwise. pragma Inline (Get_Nth_Root); procedure Get_Nth_Root_Remainder (This : Big_Integer; N : Unsigned_Long; Root : out Big_Integer; Remainder : out Big_Integer); -- Set Root to the truncated integer part of the Nth root of This. Set -- Remainder to the remainder, This-Root**N. pragma Inline (Get_Nth_Root_Remainder); end GNATCOLL.GMP.Integers.Root_Extraction; gnatcoll-bindings-25.0.0/gmp/gnatcoll-gmp-integers.adb000066400000000000000000000546301464374334300226540ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-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 -- -- . -- -- -- ------------------------------------------------------------------------------ with Interfaces.C.Strings; package body GNATCOLL.GMP.Integers is use GNATCOLL.GMP.Lib; ---------------- -- Initialize -- ---------------- procedure Initialize (This : in out Big_Integer) is begin mpz_init (This.Value'Access); end Initialize; -------------- -- Finalize -- -------------- procedure Finalize (This : in out Big_Integer) is begin mpz_clear (This.Value'Access); end Finalize; --------- -- Set -- --------- procedure Set (This : out Big_Integer; To : String; Base : Int := 10) is use Interfaces.C.Strings; Result : Int; Input : chars_ptr := New_String (To); begin Result := mpz_set_str (This.Value'Access, Input, Base); Free (Input); if Result /= 0 then raise Failure; end if; end Set; ---------- -- Make -- ---------- function Make (This : String; Base : Int := 10) return Big_Integer is begin return Result : Big_Integer do Set (Result, This, Base); end return; end Make; --------- -- Set -- --------- procedure Set (This : out Big_Integer; To : Big_Integer) is begin mpz_set (This.Value'Access, To.Value'Access); end Set; --------- -- Set -- --------- procedure Set (This : out Big_Integer; To : Long) is begin mpz_set_si (This.Value'Access, To); end Set; --------- -- Set -- --------- procedure Set_UL (This : out Big_Integer; To : Unsigned_Long) is begin mpz_set_ui (This.Value'Access, To); end Set_UL; --------- -- Set -- --------- procedure Set (This : out Big_Integer; To : access constant mpz_t) is begin mpz_set (This.Value'Access, To); end Set; --------- -- "=" -- --------- function "=" (Left : Big_Integer; Right : Big_Integer) return Boolean is begin return mpz_cmp (Left.Value'Access, Right.Value'Access) = 0; end "="; --------- -- "=" -- --------- function "=" (Left : Big_Integer; Right : Long) return Boolean is begin return mpz_cmp_si (Left.Value'Access, Right) = 0; end "="; --------- -- "=" -- --------- function "=" (Left : Long; Right : Big_Integer) return Boolean is begin return mpz_cmp_si (Right.Value'Access, Left) = 0; end "="; --------- -- ">" -- --------- function ">" (Left : Big_Integer; Right : Big_Integer) return Boolean is begin return mpz_cmp (Left.Value'Access, Right.Value'Access) > 0; end ">"; --------- -- ">" -- --------- function ">" (Left : Big_Integer; Right : Long) return Boolean is begin return mpz_cmp_si (Left.Value'Access, Right) > 0; end ">"; --------- -- ">" -- --------- function ">" (Left : Long; Right : Big_Integer) return Boolean is begin return mpz_cmp_si (Right.Value'Access, Left) < 0; end ">"; ---------- -- ">=" -- ---------- function ">=" (Left : Big_Integer; Right : Big_Integer) return Boolean is begin return mpz_cmp (Left.Value'Access, Right.Value'Access) >= 0; end ">="; ---------- -- ">=" -- ---------- function ">=" (Left : Big_Integer; Right : Long) return Boolean is begin return mpz_cmp_si (Left.Value'Access, Right) >= 0; end ">="; ---------- -- ">=" -- ---------- function ">=" (Left : Long; Right : Big_Integer) return Boolean is begin return mpz_cmp_si (Right.Value'Access, Left) <= 0; end ">="; --------- -- "<" -- --------- function "<" (Left : Big_Integer; Right : Big_Integer) return Boolean is begin return mpz_cmp (Left.Value'Access, Right.Value'Access) < 0; end "<"; --------- -- "<" -- --------- function "<" (Left : Big_Integer; Right : Long) return Boolean is begin return mpz_cmp_si (Left.Value'Access, Right) < 0; end "<"; --------- -- "<" -- --------- function "<" (Left : Long; Right : Big_Integer) return Boolean is begin return mpz_cmp_si (Right.Value'Access, Left) > 0; end "<"; ---------- -- "<=" -- ---------- function "<=" (Left : Big_Integer; Right : Big_Integer) return Boolean is begin return mpz_cmp (Left.Value'Access, Right.Value'Access) <= 0; end "<="; ---------- -- "<=" -- ---------- function "<=" (Left : Big_Integer; Right : Long) return Boolean is begin return mpz_cmp_si (Left.Value'Access, Right) <= 0; end "<="; ---------- -- "<=" -- ---------- function "<=" (Left : Long; Right : Big_Integer) return Boolean is begin return mpz_cmp_si (Right.Value'Access, Left) >= 0; end "<="; --------- -- Add -- --------- procedure Add (To : in out Big_Integer; This : Unsigned_Long) is begin mpz_add_ui (To.Value'Access, To.Value'Access, This); end Add; --------- -- Add -- --------- procedure Add (To : in out Big_Integer; This : Big_Integer) is begin mpz_add (To.Value'Access, To.Value'Access, This.Value'Access); end Add; --------- -- Add -- --------- procedure Add (Result : out Big_Integer; Op1, Op2 : Big_Integer) is begin mpz_add (Result.Value'Access, Op1.Value'Access, Op2.Value'Access); end Add; --------- -- "+" -- --------- function "+" (Left, Right : Big_Integer) return Big_Integer is begin return Result : Big_Integer do mpz_add (Result.Value'Access, Left.Value'Access, Right.Value'Access); end return; end "+"; --------- -- "+" -- --------- function "+" (Left : Big_Integer; Right : Unsigned_Long) return Big_Integer is begin return Result : Big_Integer do mpz_add_ui (Result.Value'Access, Left.Value'Access, Right); end return; end "+"; --------- -- "+" -- --------- function "+" (Left : Unsigned_Long; Right : Big_Integer) return Big_Integer is begin return Result : Big_Integer do mpz_add_ui (Result.Value'Access, Right.Value'Access, Left); end return; end "+"; -------------- -- Subtract -- -------------- procedure Subtract (From : in out Big_Integer; This : Unsigned_Long) is begin mpz_sub_ui (From.Value'Access, From.Value'Access, This); end Subtract; -------------- -- Subtract -- -------------- procedure Subtract (From : in out Big_Integer; This : Big_Integer) is begin mpz_sub (From.Value'Access, From.Value'Access, This.Value'Access); end Subtract; -------------- -- Subtract -- -------------- procedure Subtract (Result : out Big_Integer; Op1, Op2 : Big_Integer) is begin mpz_sub (Result.Value'Access, Op1.Value'Access, Op2.Value'Access); end Subtract; --------- -- "-" -- --------- function "-" (Left, Right : Big_Integer) return Big_Integer is begin return Result : Big_Integer do mpz_sub (Result.Value'Access, Left.Value'Access, Right.Value'Access); end return; end "-"; --------- -- "-" -- --------- function "-" (Left : Big_Integer; Right : Unsigned_Long) return Big_Integer is begin return Result : Big_Integer do mpz_sub_ui (Result.Value'Access, Left.Value'Access, Right); end return; end "-"; --------- -- "-" -- --------- function "-" (Left : Unsigned_Long; Right : Big_Integer) return Big_Integer is begin return Result : Big_Integer do mpz_sub_ui (Result.Value'Access, Right.Value'Access, Left); Negate (Result); end return; end "-"; -------------- -- Multiply -- -------------- procedure Multiply (This : in out Big_Integer; By : Long) is begin mpz_mul_si (This.Value'Access, This.Value'Access, By); end Multiply; -------------- -- Multiply -- -------------- procedure Multiply (This : in out Big_Integer; By : Big_Integer) is begin mpz_mul (This.Value'Access, This.Value'Access, By.Value'Access); end Multiply; -------------- -- Multiply -- -------------- procedure Multiply (Result : out Big_Integer; Op1, Op2 : Big_Integer) is begin mpz_mul (Result.Value'Access, Op1.Value'Access, Op2.Value'Access); end Multiply; --------- -- "*" -- --------- function "*" (Left, Right : Big_Integer) return Big_Integer is begin return Result : Big_Integer do mpz_mul (Result.Value'Access, Left.Value'Access, Right.Value'Access); end return; end "*"; --------- -- "*" -- --------- function "*" (Left : Long; Right : Big_Integer) return Big_Integer is begin return Result : Big_Integer do mpz_mul_si (Result.Value'Access, Right.Value'Access, Left); end return; end "*"; --------- -- "*" -- --------- function "*" (Left : Big_Integer; Right : Long) return Big_Integer is begin return Result : Big_Integer do mpz_mul_si (Result.Value'Access, Left.Value'Access, Right); end return; end "*"; ------------ -- Divide -- ------------ procedure Divide (Q : in out Big_Integer; N : Big_Integer; D : Unsigned_Long) is Dummy : Long; pragma Unreferenced (Dummy); begin if D = 0 then raise Constraint_Error; end if; Dummy := mpz_tdiv_q_ui (Q.Value'Access, N.Value'Access, D); end Divide; ------------ -- Divide -- ------------ procedure Divide (Q : in out Big_Integer; N : Big_Integer; D : Big_Integer) is begin if mpz_cmp_ui (D.Value'Access, 0) = 0 then raise Constraint_Error; end if; mpz_tdiv_q (Q.Value'Access, N.Value'Access, D.Value'Access); end Divide; --------- -- "/" -- --------- function "/" (Left, Right : Big_Integer) return Big_Integer is begin if mpz_cmp_ui (Right.Value'Access, 0) = 0 then raise Constraint_Error; end if; return Result : Big_Integer do mpz_tdiv_q (Q => Result.Value'Access, N => Left.Value'Access, D => Right.Value'Access); end return; end "/"; --------- -- "/" -- --------- function "/" (Left : Big_Integer; Right : Unsigned_Long) return Big_Integer is Dummy : Long; pragma Unreferenced (Dummy); begin if Right = 0 then raise Constraint_Error; end if; return Result : Big_Integer do Dummy := mpz_tdiv_q_ui (Q => Result.Value'Access, N => Left.Value'Access, D => Right); end return; end "/"; ----------- -- "rem" -- ----------- function "rem" (Left : Big_Integer; Right : Big_Integer) return Big_Integer is begin if mpz_cmp_ui (Right.Value'Access, 0) = 0 then raise Constraint_Error; end if; return Result : Big_Integer do mpz_tdiv_r (R => Result.Value'Access, N => Left.Value'Access, D => Right.Value'Access); -- the result takes the sign of N, as required by the RM end return; end "rem"; ----------- -- "rem" -- ----------- function "rem" (Left : Big_Integer; Right : Unsigned_Long) return Big_Integer is Dummy : Long; pragma Unreferenced (Dummy); begin if Right = 0 then raise Constraint_Error; end if; return Result : Big_Integer do Dummy := mpz_tdiv_r_ui (R => Result.Value'Access, N => Left.Value'Access, D => Right); -- the result is always non-negative so we have to set the sign to -- that of Left if Sign (Left) /= Sign (Result) then Negate (Result); end if; end return; end "rem"; ------------- -- Get_Rem -- ------------- procedure Get_Rem (Result : out Big_Integer; N, D : Big_Integer) is begin if mpz_cmp_ui (D.Value'Access, 0) = 0 then raise Constraint_Error; end if; mpz_tdiv_r (Result.Value'Access, N.Value'Access, D.Value'Access); -- the result takes the sign of N, as required by the RM end Get_Rem; ------------------ -- Floor_Divide -- ------------------ function Floor_Divide (N, D : Big_Integer) return Big_Integer is begin if mpz_cmp_ui (D.Value'Access, 0) = 0 then raise Constraint_Error; end if; return Result : Big_Integer do mpz_fdiv_q (Result.Value'Access, N.Value'Access, D.Value'Access); end return; end Floor_Divide; ----------------- -- Ceil_Divide -- ----------------- function Ceil_Divide (N, D : Big_Integer) return Big_Integer is begin if mpz_cmp_ui (D.Value'Access, 0) = 0 then raise Constraint_Error; end if; return Result : Big_Integer do mpz_cdiv_q (Result.Value'Access, N.Value'Access, D.Value'Access); end return; end Ceil_Divide; --------------------- -- Floor_Remainder -- --------------------- function Floor_Remainder (N, D : Big_Integer) return Big_Integer is begin if mpz_cmp_ui (D.Value'Access, 0) = 0 then raise Constraint_Error; end if; return Result : Big_Integer do mpz_fdiv_r (Result.Value'Access, N.Value'Access, D.Value'Access); end return; end Floor_Remainder; -------------------- -- Ceil_Remainder -- -------------------- function Ceil_Remainder (N, D : Big_Integer) return Big_Integer is begin if mpz_cmp_ui (D.Value'Access, 0) = 0 then raise Constraint_Error; end if; return Result : Big_Integer do mpz_cdiv_r (Result.Value'Access, N.Value'Access, D.Value'Access); end return; end Ceil_Remainder; ----------- -- "and" -- ----------- function "and" (Left, Right : Big_Integer) return Big_Integer is begin return Result : Big_Integer do mpz_and (Rop => Result.Value'Access, Op1 => Left.Value'Access, Op2 => Right.Value'Access); end return; end "and"; ---------- -- "or" -- ---------- function "or" (Left, Right : Big_Integer) return Big_Integer is begin return Result : Big_Integer do mpz_ior (Rop => Result.Value'Access, Op1 => Left.Value'Access, Op2 => Right.Value'Access); end return; end "or"; ----------- -- "xor" -- ----------- function "xor" (Left, Right : Big_Integer) return Big_Integer is begin return Result : Big_Integer do mpz_xor (Rop => Result.Value'Access, Op1 => Left.Value'Access, Op2 => Right.Value'Access); end return; end "xor"; ----------- -- "not" -- ----------- function "not" (This : Big_Integer) return Big_Integer is begin return Result : Big_Integer do mpz_com (Rop => Result.Value'Access, Op => This.Value'Access); end return; end "not"; --------- -- "-" -- --------- function "-" (Left : Big_Integer) return Big_Integer is begin return Result : Big_Integer do mpz_neg (Result.Value'Access, Left.Value'Access); end return; end "-"; ------------ -- Negate -- ------------ procedure Negate (This : in out Big_Integer) is begin mpz_neg (This.Value'Access, This.Value'Access); end Negate; ---------- -- "**" -- ---------- function "**"(Left : Big_Integer; Right : Unsigned_Long) return Big_Integer is begin return Result : Big_Integer do mpz_pow_ui (Result.Value'Access, Left.Value'Access, Right); end return; end "**"; ---------------- -- Raise_To_N -- ---------------- procedure Raise_To_N (This : in out Big_Integer; N : Unsigned_Long) is begin mpz_pow_ui (This.Value'Access, This.Value'Access, N); end Raise_To_N; ----------- -- "abs" -- ----------- function "abs" (Left : Big_Integer) return Big_Integer is begin return Result : Big_Integer do mpz_abs (Result.Value'Access, Left.Value'Access); end return; end "abs"; ------------- -- Get_Abs -- ------------- procedure Get_Abs (Result : out Big_Integer; From : Big_Integer) is begin mpz_abs (Result.Value'Access, From.Value'Access); end Get_Abs; ----------- -- "mod" -- ----------- function "mod" (Left : Big_Integer; Right : Big_Integer) return Big_Integer is begin if mpz_cmp_ui (Right.Value'Access, 0) = 0 then raise Constraint_Error; end if; return Result : Big_Integer do Get_Mod (Result, Left, Right); end return; end "mod"; ----------- -- "mod" -- ----------- function "mod" (Left : Big_Integer; Right : Long) return Big_Integer is begin if Right = 0 then raise Constraint_Error; end if; return Result : Big_Integer do declare Temp_Right : Big_Integer; begin Set (Temp_Right, To => Right); Get_Mod (Result, Left, Temp_Right); end; end return; end "mod"; ------------- -- Get_Mod -- ------------- procedure Get_Mod (Result : out Big_Integer; N, D : Big_Integer) is begin if mpz_cmp_ui (D.Value'Access, 0) = 0 then raise Constraint_Error; end if; if Sign (N) /= -1 and Sign (D) /= -1 then -- neither is negative mpz_mod (Result.Value'Access, N.Value'Access, D.Value'Access); else -- The GMP library provides operators defined by C semantics, but the -- semantics of Ada's mod operator are not the same as C's when -- negative values are involved. We do the following to implement the -- required Ada semantics. declare Temp_Left : Big_Integer; Temp_Right : Big_Integer; Temp_Result : Big_Integer; begin Set (Temp_Left, To => N); Set (Temp_Right, To => D); if Sign (N) = -1 then -- N is negative Negate (Temp_Left); end if; if Sign (D) = -1 then -- D is negative Negate (Temp_Right); end if; -- now both Temp_Left and Temp_Right are nonnegative mpz_mod (Temp_Result.Value'Access, Temp_Left.Value'Access, Temp_Right.Value'Access); if mpz_cmp_ui (Temp_Result.Value'Access, 0) = 0 then -- if Temp_Result is zero we are done Set (Result, To => Temp_Result); else if Sign (N) = -1 then -- N is negative if Sign (D) = -1 then -- D is negative too Set (Result, To => Temp_Result); Negate (Result); else -- N is negative but D is not Set (Result, Temp_Right - Temp_Result); end if; else -- N is not negative if Sign (D) = -1 then -- D is negative -- Set (Result, Temp_Result - Temp_Right); mpz_sub (Result.Value'Access, Temp_Result.Value'Access, Temp_Right.Value'Access); else -- neither is negative Set (Result, To => Temp_Result); end if; end if; end if; end; end if; end Get_Mod; ----------- -- Image -- ----------- function Image (This : Big_Integer; Base : Integer := 10) return String is use Interfaces.C, Interfaces.C.Strings; Number_Digits : constant size_t := mpz_sizeinbase (This.Value'Access, Int (abs Base)); Buffer : String (1 .. Integer (Number_Digits) + 2); -- The correct number to allocate is 2 more than Number_Digits in order -- to handle a possible minus sign and the null-terminator. Result : chars_ptr; begin Result := mpz_get_str (Buffer'Address, Int (Base), This.Value'Access); return Value (Result); end Image; -------------- -- As_mpz_t -- -------------- function As_mpz_t (This : Big_Integer) return access constant GNATCOLL.GMP.Lib.mpz_t is begin return This.Value'Unchecked_Access; end As_mpz_t; ---------- -- Sign -- ---------- function Sign (This : Big_Integer) return Integer is begin return Integer (mpz_sgn (This.Value'Access)); end Sign; end GNATCOLL.GMP.Integers; gnatcoll-bindings-25.0.0/gmp/gnatcoll-gmp-integers.ads000066400000000000000000000312631464374334300226720ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-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 -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package defines an arbitrary precision integer type based on the -- underlying GNU Multiple Precision library. The name of the type is -- "Big_Integer." -- -- Most Ada operations and operators are supported for type Big_Integer, -- except that the type is limited private in order to enforce the underlying -- semantics required by the library implementation. Assignment is performed -- via the Set routines, and the equality operator is explicitly defined. -- -- Most of the Ada routines are direct calls to the underlying C routines, -- except where the Ada semantics differ. The routines all have pragma Inline -- applied so that no additional overhead is incurred over that of a direct -- call to the C routine (when the body consists of only such a call). -- -- Note that using the operators returning Big_Integer objects will result in -- temporaries, except when used as the initial value in object declarations. -- These temporaries are automatically initialized when created but will thus -- incur some overhead. Procedural versions of the arithmetic operators are -- therefore included, matching those of the underlying GMP library in C -- (except in name), which avoid temporaries and operate directly on the -- operands. with GNATCOLL.GMP.Lib; with Ada.Finalization; package GNATCOLL.GMP.Integers is pragma Preelaborate; type Big_Integer is tagged limited private; -- The type is limited because clients should not use predefined -- assignment; nor should they use predefined equality. This matches the -- semantics of the underlying GMP library in C. For assignment, use the -- Set routines. The equality operator is explicitly redefined. -- The underlying C version of the GMP requires the user to manually -- initialize the arbitrary precision integer objects (i.e., those of type -- mpz_t). Likewise, users are expected to clear these objects to reclaim -- the memory allocated. Initialization and clearing are performed -- automatically in this Ada version. Failure : exception; -- Assignment procedure Set (This : out Big_Integer; To : String; Base : Int := 10); -- Set the value of This from To, a string containing a number expressed in -- base Base. White space is allowed in the string and is simply ignored. -- -- The value of Base may vary from 2 to 62. For bases up to 36, case is -- ignored; upper-case and lower-case letters have the same value. For -- bases 37 to 62, upper-case letter represent the usual 10..35 while -- lower-case letter represent 36..61. -- -- Raises Failure if the entire string To is not a valid number in base -- Base. Note that a leading "+" is not valid, although a leading "-" -- denotes a negative integer. function Make (This : String; Base : Int := 10) return Big_Integer; -- Constructs a Big_Integer from This, using the same rules as procedure -- Set above. procedure Set (This : out Big_Integer; To : Big_Integer); -- Set the value of This from To. procedure Set (This : out Big_Integer; To : Long); -- Set the value of This from To. procedure Set_UL (This : out Big_Integer; To : Unsigned_Long); -- Set the value of This from To. procedure Set (This : out Big_Integer; To : access constant GNATCOLL.GMP.Lib.mpz_t); -- Set the value of This from To. pragma Inline (Set); pragma Inline (Set_UL); -- Relationals function "=" (Left : Big_Integer; Right : Big_Integer) return Boolean; function "=" (Left : Big_Integer; Right : Long) return Boolean; function "=" (Left : Long; Right : Big_Integer) return Boolean; function ">" (Left : Big_Integer; Right : Big_Integer) return Boolean; function ">" (Left : Big_Integer; Right : Long) return Boolean; function ">" (Left : Long; Right : Big_Integer) return Boolean; function "<" (Left : Big_Integer; Right : Big_Integer) return Boolean; function "<" (Left : Big_Integer; Right : Long) return Boolean; function "<" (Left : Long; Right : Big_Integer) return Boolean; function ">=" (Left : Big_Integer; Right : Big_Integer) return Boolean; function ">=" (Left : Big_Integer; Right : Long) return Boolean; function ">=" (Left : Long; Right : Big_Integer) return Boolean; function "<=" (Left : Big_Integer; Right : Big_Integer) return Boolean; function "<=" (Left : Big_Integer; Right : Long) return Boolean; function "<=" (Left : Long; Right : Big_Integer) return Boolean; pragma Inline ("="); pragma Inline (">"); pragma Inline ("<"); pragma Inline (">="); pragma Inline ("<="); -- Addition procedure Add (To : in out Big_Integer; This : Unsigned_Long); procedure Add (To : in out Big_Integer; This : Big_Integer); procedure Add (Result : out Big_Integer; Op1, Op2 : Big_Integer); -- Result := Op1 + Op2; -- No temporaries required. function "+" (Left, Right : Big_Integer) return Big_Integer; function "+" (Left : Big_Integer; Right : Unsigned_Long) return Big_Integer; function "+" (Left : Unsigned_Long; Right : Big_Integer) return Big_Integer; pragma Inline (Add); pragma Inline ("+"); -- Subtraction procedure Subtract (From : in out Big_Integer; This : Unsigned_Long); procedure Subtract (From : in out Big_Integer; This : Big_Integer); procedure Subtract (Result : out Big_Integer; Op1, Op2 : Big_Integer); -- Result := Op1 - Op2; -- No temporaries required. function "-" (Left, Right : Big_Integer) return Big_Integer; function "-" (Left : Big_Integer; Right : Unsigned_Long) return Big_Integer; function "-" (Left : Unsigned_Long; Right : Big_Integer) return Big_Integer; pragma Inline (Subtract); pragma Inline ("-"); -- Unary function "-" (Left : Big_Integer) return Big_Integer; procedure Negate (This : in out Big_Integer); pragma Inline ("-"); pragma Inline (Negate); -- Multiplication procedure Multiply (This : in out Big_Integer; By : Long); procedure Multiply (This : in out Big_Integer; By : Big_Integer); procedure Multiply (Result : out Big_Integer; Op1, Op2 : Big_Integer); -- Result := Op1 * Op2; -- No temporaries required. function "*" (Left : Big_Integer; Right : Big_Integer) return Big_Integer; function "*" (Left : Long; Right : Big_Integer) return Big_Integer; function "*" (Left : Big_Integer; Right : Long) return Big_Integer; pragma Inline (Multiply); pragma Inline ("*"); -- Division -- The Divide, "/" and "rem" subprograms below implement the "truncate" -- division. See the other functions after them for the "ceil" and -- "truncate" division. procedure Divide (Q : in out Big_Integer; N : Big_Integer; D : Unsigned_Long); procedure Divide (Q : in out Big_Integer; N : Big_Integer; D : Big_Integer); function "/" (Left, Right : Big_Integer) return Big_Integer; function "/" (Left : Big_Integer; Right : Unsigned_Long) return Big_Integer; pragma Inline (Divide); pragma Inline ("/"); function "mod" (Left : Big_Integer; Right : Big_Integer) return Big_Integer; function "mod" (Left : Big_Integer; Right : Long) return Big_Integer; procedure Get_Mod (Result : out Big_Integer; N, D : Big_Integer); pragma Inline ("mod"); pragma Inline (Get_Mod); function "rem" (Left : Big_Integer; Right : Big_Integer) return Big_Integer; function "rem" (Left : Big_Integer; Right : Unsigned_Long) return Big_Integer; procedure Get_Rem (Result : out Big_Integer; N, D : Big_Integer); pragma Inline ("rem"); pragma Inline (Get_Rem); function Truncate_Divide (N, D : Big_Integer) return Big_Integer renames "/"; function Truncate_Remainder (N, D : Big_Integer) return Big_Integer renames "rem"; function Floor_Divide (N, D : Big_Integer) return Big_Integer; function Floor_Remainder (N, D : Big_Integer) return Big_Integer; function Ceil_Divide (N, D : Big_Integer) return Big_Integer; function Ceil_Remainder (N, D : Big_Integer) return Big_Integer; pragma Inline (Floor_Divide); pragma Inline (Floor_Remainder); pragma Inline (Ceil_Divide); pragma Inline (Ceil_Remainder); -- Logical and Bit Manipulation function "and" (Left, Right : Big_Integer) return Big_Integer; pragma Inline ("and"); function "or" (Left, Right : Big_Integer) return Big_Integer; pragma Inline ("or"); function "xor" (Left, Right : Big_Integer) return Big_Integer; pragma Inline ("xor"); function "not" (This : Big_Integer) return Big_Integer; pragma Inline ("not"); -- Highest Precedence Operators function "**"(Left : Big_Integer; Right : Unsigned_Long) return Big_Integer; procedure Raise_To_N (This : in out Big_Integer; N : Unsigned_Long); function "abs" (Left : Big_Integer) return Big_Integer; procedure Get_Abs (Result : out Big_Integer; From : Big_Integer); pragma Inline ("**"); pragma Inline (Raise_To_N); pragma Inline ("abs"); pragma Inline (Get_Abs); -- Miscellaneous functionality function Image (This : Big_Integer; Base : Integer := 10) return String; -- Returns This as a string of digits in base Base. The base argument -- may vary from 2 to 62 or from -2 to -36. -- -- Does not include a leading blank if This is >= 0. -- -- For Base in the range 2..36, digits and lower-case letters are -- used; for -2..-36, digits and upper-case letters are used; for -- 37..62, digits, upper-case letters, and lower-case letters (in -- that significance order) are used. function As_mpz_t (This : Big_Integer) return access constant GNATCOLL.GMP.Lib.mpz_t; -- This function is useful for passing Big_Integer values to routines from -- gmplib that do not have an Ada binding defined by this package. In that -- case the user will define the binding but will not be able to pass -- Big_Integer objects as parameters to their routine. This function -- provides the required visibility to the internal mpz_t component of a -- Big_Integer object. For example, the user might do the following: -- -- function mpz_probab_prime_p (this : access constant mpz_t; x : Int) -- return Int; -- pragma Import (C, mpz_probab_prime_p, "__gmpz_probab_prime_p"); -- -- N : Big_Integer; -- Result : Int; -- ... -- Result := mpz_probab_prime_p (As_mpz_t (N), 5); pragma Inline (As_mpz_t); function Sign (This : Big_Integer) return Integer; -- Returns +1 if This > 0, 0 if This = 0, and -1 if This < 0. pragma Inline (Sign); private type Big_Integer is new Ada.Finalization.Limited_Controlled with record Value : aliased GNATCOLL.GMP.Lib.mpz_t; end record; procedure Initialize (This : in out Big_Integer); procedure Finalize (This : in out Big_Integer); end GNATCOLL.GMP.Integers; gnatcoll-bindings-25.0.0/gmp/gnatcoll-gmp-lib.ads000066400000000000000000000523641464374334300216250ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-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 -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package provides a direct interface to the GNU Multiple Precision -- numeric library implementation in the C language. The names of the routines -- and types follow those of the C implementation. In addition, the intended -- semantics of the types are actually enforced by the Ada compiler. -- Specifically, C programmers are not intended to perform copying via -- assignment or comparisons via predefined equality. We use a limited private -- type to enforce those expectations. Note that the low-level Ada numeric -- types used in the interfaces are defined in the root Ada package named GMP. -- Ada programmers can program at this level (i.e., using this package) but -- are intended to use the higher level interfaces defined in other child -- packages. For example, arbitrary precision integers are supported by -- package GMP.Integers and children of that package. -- The C library uses a single shared namespace and types reference each other -- as needed, such that a single package is the most direct, clean way to -- model it. The entire GMP library at the C language level is intended to be -- defined here, but not all routines are currently defined. Other routine -- interfaces can be added as needed, in the future. -- Individual major sections of the GMP library C binding are separated by -- comment lines containing the names of the corresponding sections. For -- example, the "Integer Functions" section is defined first, followed by -- "Random Number Functions". These section names correspond to the GMP -- library documentation. In addition, each major section is further divided -- in to subsections with comments indicating the name of the subsection. -- These subsection names also correspond to the names used in the GMP library -- documentation. For example, the "Integer Functions" section is subdivided -- into "Initialization", "Assignment", "Combined Initialization and -- Assignment", and so forth. Ada programmers can, therefore, use the GMP -- library documentation and more easily find the required C binding (if they -- must program at this level). with Interfaces.C.Strings; use Interfaces.C.Strings; with Interfaces.C_Streams; with System; package GNATCOLL.GMP.Lib is pragma Preelaborate; type mpz_t is limited private; -- Following the C interface, clients are not intended to access the -- fields of this type, for the sake of upward compatibility. Nor are they -- intended to do simple copying via assignment or comparisons via -- predefined equality. We use a limited private type to enforce those -- expectations. type gmp_randstate_t is limited private; -- Following the C interface, clients are not intended to access the -- fields of this type for the sake of upward compatibility. Nor are they -- intended to do simple copying via assignment or comparisons via -- predefined equality. We use a limited private type to enforce those -- expectations. type mpq_t is limited private; -- Following the C interface, clients are not intended to access the fields -- of this type, for the sake of upward compatibility. Nor are they -- intended to do simple copying via assignment or comparisons via -- predefined equality. We use a limited private type to enforce those -- expectations. -- Integer Functions --------------------------------------------------------- -- Initialization procedure mpz_init (this : access mpz_t); pragma Import (C, mpz_init, "__gmpz_init"); procedure mpz_clear (this : access mpz_t); pragma Import (C, mpz_clear, "__gmpz_clear"); -- Assignment procedure mpz_set (ROP : access mpz_t; OP : access constant mpz_t); pragma Import (C, mpz_set, "__gmpz_set"); procedure mpz_set_si (ROP : access mpz_t; OP : Long); pragma Import (C, mpz_set_si, "__gmpz_set_si"); procedure mpz_set_ui (ROP : access mpz_t; OP : Unsigned_Long); pragma Import (C, mpz_set_ui, "__gmpz_set_ui"); function mpz_set_str (this : access mpz_t; str : chars_ptr; base : Int) return Int; pragma Import (C, mpz_set_str, "__gmpz_set_str"); procedure mpz_swap (ROP1, ROP2 : access mpz_t); pragma Import (C, mpz_swap, "__gmpz_swap"); -- Combined initialization and assignment procedure mpz_init_set (ROP : access mpz_t; OP : access constant mpz_t); pragma Import (C, mpz_init_set, "__gmpz_init_set"); procedure mpz_init_set_si (ROP : access mpz_t; OP : Long); pragma Import (C, mpz_init_set_si, "__gmpz_init_set_si"); function mpz_init_set_str (ROP : access mpz_t; STR : chars_ptr; BASE : Int) return Int; pragma Import (C, mpz_init_set_str, "__gmpz_init_set_str"); -- Conversion function mpz_get_str (STR : System.Address; BASE : Int; OP : access constant mpz_t) return chars_ptr; pragma Import (C, mpz_get_str, "__gmpz_get_str"); function mpz_get_si (OP : access constant mpz_t) return Long; pragma Import (C, mpz_get_si, "__gmpz_get_si"); -- Arithmetic procedure mpz_add (ROP : access mpz_t; OP1, OP2 : access constant mpz_t); pragma Import (C, mpz_add, "__gmpz_add"); procedure mpz_add_ui (ROP : access mpz_t; OP1 : access constant mpz_t; OP2 : Unsigned_Long); pragma Import (C, mpz_add_ui, "__gmpz_add_ui"); procedure mpz_sub (ROP : access mpz_t; OP1, OP2 : access constant mpz_t); pragma Import (C, mpz_sub, "__gmpz_sub"); procedure mpz_sub_ui (ROP : access mpz_t; OP1 : access constant mpz_t; OP2 : Unsigned_Long); pragma Import (C, mpz_sub_ui, "__gmpz_sub_ui"); procedure mpz_mul (ROP : access mpz_t; OP1, OP2 : access constant mpz_t); pragma Import (C, mpz_mul, "__gmpz_mul"); procedure mpz_mul_si (ROP : access mpz_t; OP1 : access constant mpz_t; OP2 : Long); pragma Import (C, mpz_mul_si, "__gmpz_mul_si"); procedure mpz_neg (ROP : access mpz_t; OP : access constant mpz_t); pragma Import (C, mpz_neg, "__gmpz_neg"); procedure mpz_abs (ROP : access mpz_t; OP : access constant mpz_t); pragma Import (C, mpz_abs, "__gmpz_abs"); -- Division procedure mpz_tdiv_q (Q : access mpz_t; N, D : access constant mpz_t); pragma Import (C, mpz_tdiv_q, "__gmpz_tdiv_q"); function mpz_tdiv_q_ui (Q : access mpz_t; N : access constant mpz_t; D : Unsigned_Long) return Long; -- returns the remainder but puts the quotient in Q pragma Import (C, mpz_tdiv_q_ui, "__gmpz_tdiv_q_ui"); procedure mpz_tdiv_r (R : access mpz_t; N, D : access constant mpz_t); pragma Import (C, mpz_tdiv_r, "__gmpz_tdiv_r"); -- R will have the same sign as N. function mpz_tdiv_r_ui (R : access mpz_t; N : access constant mpz_t; D : Unsigned_Long) return Long; -- return value is the absolute value of the remainder pragma Import (C, mpz_tdiv_r_ui, "__gmpz_tdiv_r_ui"); procedure mpz_mod (R : access mpz_t; N, D : access constant mpz_t); pragma Import (C, mpz_mod, "__gmpz_mod"); -- result is always non-negative procedure mpz_fdiv_q (Q : access mpz_t; N, D : access constant mpz_t); pragma Import (C, mpz_fdiv_q, "__gmpz_fdiv_q"); procedure mpz_cdiv_q (Q : access mpz_t; N, D : access constant mpz_t); pragma Import (C, mpz_cdiv_q, "__gmpz_cdiv_q"); procedure mpz_fdiv_r (Q : access mpz_t; N, D : access constant mpz_t); pragma Import (C, mpz_fdiv_r, "__gmpz_fdiv_r"); procedure mpz_cdiv_r (Q : access mpz_t; N, D : access constant mpz_t); pragma Import (C, mpz_cdiv_r, "__gmpz_cdiv_r"); -- Logical and Bit Manipulation procedure mpz_and (Rop : access mpz_t; Op1, Op2 : access constant mpz_t); pragma Import (C, mpz_and, "__gmpz_and"); procedure mpz_ior (Rop : access mpz_t; Op1, Op2 : access constant mpz_t); pragma Import (C, mpz_ior, "__gmpz_ior"); procedure mpz_xor (Rop : access mpz_t; Op1, Op2 : access constant mpz_t); pragma Import (C, mpz_xor, "__gmpz_xor"); procedure mpz_com (Rop : access mpz_t; Op : access constant mpz_t); pragma Import (C, mpz_com, "__gmpz_com"); -- Exponentiation procedure mpz_pow_ui (ROP : access mpz_t; BASE : access constant mpz_t; EXP : Unsigned_Long); pragma Import (C, mpz_pow_ui, "__gmpz_pow_ui"); -- Root Extraction procedure mpz_sqrt (ROP : access mpz_t; OP : access constant mpz_t); pragma Import (C, mpz_sqrt, "__gmpz_sqrt"); function mpz_root (ROP : access mpz_t; OP : access constant mpz_t; N : Unsigned_Long) return Int; pragma Import (C, mpz_root, "__gmpz_root"); procedure mpz_sqrtrem (ROP1 : access mpz_t; ROP2 : access mpz_t; OP : access constant mpz_t); pragma Import (C, mpz_sqrtrem, "__gmpz_sqrtrem"); procedure mpz_rootrem (ROOT : access mpz_t; REMAINDER : access mpz_t; U : access constant mpz_t; N : Unsigned_Long); pragma Import (C, mpz_rootrem, "__gmpz_rootrem"); -- Number Theoretic procedure mpz_gcd (ROP : access mpz_t; Op1, Op2 : access constant mpz_t); pragma Import (C, mpz_gcd, "__gmpz_gcd"); -- Comparison function mpz_cmp (OP1, OP2 : access constant mpz_t) return Int; pragma Import (C, mpz_cmp, "__gmpz_cmp"); function mpz_cmp_si (OP1 : access constant mpz_t; OP2 : Long) return Int; pragma Import (C, mpz_cmp_si, "__gmpz_cmp_si"); function mpz_cmp_ui (OP1 : access constant mpz_t; OP2 : Unsigned_Long) return Int; pragma Import (C, mpz_cmp_ui, "__gmpz_cmp_ui"); function mpz_sgn (OP : access constant mpz_t) return Int; pragma Import (C, mpz_sgn, "gmp_mpz_sgn"); -- our wrapper for their macro -- Logical and Bit Manipulation -- Input / Output function mpz_out_str (file : Interfaces.C_Streams.FILEs; base : Int; this : access constant mpz_t) return Interfaces.C.size_t; pragma Import (C, mpz_out_str, "__gmpz_out_str"); -- Random procedure mpz_urandomb (ROP : access mpz_t; STATE : access constant gmp_randstate_t; -- should really be access-to-variable to match semantics N : Unsigned_Long); pragma Import (C, mpz_urandomb, "__gmpz_urandomb"); procedure mpz_urandomm (ROP : access mpz_t; STATE : access constant gmp_randstate_t; -- should really be access-to-variable to match semantics N : access constant mpz_t); pragma Import (C, mpz_urandomm, "__gmpz_urandomm"); -- Import and Export -- Miscellaneous function mpz_fits_slong_p (OP : access constant mpz_t) return Int; pragma Import (C, mpz_fits_slong_p, "__gmpz_fits_slong_p"); function mpz_sizeinbase (this : access constant mpz_t; base : Int) return Interfaces.C.size_t; pragma Import (C, mpz_sizeinbase, "__gmpz_sizeinbase"); function mpz_odd_p (OP : access constant mpz_t) return Int; pragma Import (C, mpz_odd_p, "gmp_mpz_odd_p"); -- our wrapper for their macro function mpz_even_p (OP : access constant mpz_t) return Int; pragma Import (C, mpz_even_p, "gmp_mpz_even_p"); -- our wrapper for their macro -- Random Number Functions --------------------------------------------------- -- State Initialization procedure gmp_randinit_default (STATE : access gmp_randstate_t); pragma Import (C, gmp_randinit_default, "__gmp_randinit_default"); procedure gmp_randinit_mt (STATE : access gmp_randstate_t); pragma Import (C, gmp_randinit_mt, "__gmp_randinit_mt"); procedure gmp_randinit_set (ROP : access gmp_randstate_t; OP : access constant gmp_randstate_t); pragma Import (C, gmp_randinit_set, "__gmp_randinit_set"); procedure gmp_randclear (STATE : access gmp_randstate_t); pragma Import (C, gmp_randclear, "__gmp_randclear"); -- State Seeding procedure gmp_randseed (STATE : access gmp_randstate_t; SEED : access constant mpz_t); pragma Import (C, gmp_randseed, "__gmp_randseed"); procedure gmp_randseed_ui (STATE : access gmp_randstate_t; SEED : Unsigned_Long); pragma Import (C, gmp_randseed_ui, "__gmp_randseed_ui"); -- Misc function gmp_urandomb_ui (STATE : access gmp_randstate_t; N : Unsigned_Long) return Long; pragma Import (C, gmp_urandomb_ui, "__gmp_urandomb_ui"); function gmp_urandomm_ui (STATE : access gmp_randstate_t; N : Unsigned_Long) return Long; pragma Import (C, gmp_urandomm_ui, "__gmp_urandomm_ui"); -- Rational Number Functions procedure mpq_canonicalize (this : access constant mpq_t) with Import => True, Convention => C, External_Name => "__gmpq_canonicalize"; -- Remove any factors that are common to the numerator and denominator of -- This, and make the denominator positive. -- Initialization and Assignment procedure mpq_init (this : access mpq_t) with Import => True, Convention => C, External_Name => "__gmpq_init"; -- Initialize this and set it to 0/1. Each variable should normally only be -- initialized once, or at least cleared out (using the function mpq_clear) -- between each initialization. NOTE: since we automatically handle memory -- management through controlled type, we perform this check directly in -- the Set functions. procedure mpq_clear (this : access mpq_t) with Import => True, Convention => C, External_Name => "__gmpq_clear"; -- Free resources allocated for this. Make sure to call this function for -- all mpq_t variables when you are done with them. NOTE: this is ensured -- by the use of a controlled type. procedure mpq_set (this : access mpq_t; op : access constant mpq_t) with Import => True, Convention => C, External_Name => "__gmpq_set"; -- Assign this from op procedure mpq_set_z (this : access mpq_t; op : access constant mpz_t) with Import => True, Convention => C, External_Name => "__gmpq_set_z"; -- Assign this from op procedure mpq_set_ui (this : access mpq_t; op1, op2 : Unsigned_Long) with Import => True, Convention => C, External_Name => "__gmpq_set_ui"; -- Set the value of this to op1/op2 procedure mpq_set_si (this : access mpq_t; op1 : Long; op2 : Unsigned_Long) with Import => True, Convention => C, External_Name => "__gmpq_set_si"; -- Set the value of this to op1/op2 function mpq_set_str (this : access mpq_t; str : chars_ptr; base : Int) return Int with Import => True, Convention => C, External_Name => "__gmpq_set_str"; -- See Rational.Set procedure mpq_swap (rop1, rop2 : access mpq_t) with Import => True, Convention => C, External_Name => "__gmpq_swap"; -- Swap the values rop1 and rop2 efficiently -- Conversion function mpq_get_d (op : access constant mpq_t) return Double with Import => True, Convention => C, External_Name => "__gmpq_get_d"; -- Convert op to a double, truncating if necessary (i.e. rounding towards -- zero). -- -- See Rational_Numbers.To_Double for more details. procedure mpq_set_d (this : access mpq_t; op : Double) with Import => True, Convention => C, External_Name => "__gmpq_set_d"; -- Set this to the value of op. There is no rounding, this conversion -- is exact. function mpq_get_str (str : System.Address; base : Int; op : access constant mpq_t) return chars_ptr with Import => True, Convention => C, External_Name => "__gmpq_get_str"; -- Convert op to a string of digits in base base. The base argument may -- vary from 2 to 62 or from -2 to -36. The string will be of the form -- "num/den", or if the denominator is 1 then just "num". -- -- For base in the range 2..36, digits and lower-case letters are used; for -- -2..-36, digits and upper-case letters are used; for 37..62, digits, -- upper-case letters, and lower-case letters (in that significance order) -- are used. -- -- str should point to a block of storage large enough for the result, that -- being -- -- mpz_num_sizeinbase (op, base) -- + mpz_den_sizeinbase (op, base) + 3 -- -- The three extra bytes are for a possible minus sign, possible slash, and -- the null-terminator. -- -- A pointer to the result string is returned, being either the allocated -- block, or the given str. -- Arithmetic procedure mpq_add (this : access mpq_t; op1, op2 : access constant mpq_t) with Import => True, Convention => C, External_Name => "__gmpq_add"; procedure mpq_sub (this : access mpq_t; op1, op2 : access constant mpq_t) with Import => True, Convention => C, External_Name => "__gmpq_sub"; procedure mpq_mul (this : access mpq_t; op1, op2 : access constant mpq_t) with Import => True, Convention => C, External_Name => "__gmpq_mul"; procedure mpq_div (this : access mpq_t; op1, op2 : access constant mpq_t) with Import => True, Convention => C, External_Name => "__gmpq_div"; procedure mpq_neg (this : access mpq_t; op : access constant mpq_t) with Import => True, Convention => C, External_Name => "__gmpq_neg"; procedure mpq_abs (this : access mpq_t; op : access constant mpq_t) with Import => True, Convention => C, External_Name => "__gmpq_abs"; -- Comparisons function mpq_cmp (op1, op2 : access constant mpq_t) return Int with Import => True, Convention => C, External_Name => "__gmpq_cmp"; function mpq_cmp_z (op1 : access constant mpq_t; op2 : access constant mpz_t) return Int with Import => True, Convention => C, External_Name => "__gmpq_cmp_z"; function mpq_equal (op1, op2 : access constant mpq_t) return Int with Import => True, Convention => C, External_Name => "__gmpq_equal"; -- Integer Functions procedure mpq_get_num (num : access mpz_t; op : access constant mpq_t) with Import => True, Convention => C, External_Name => "__gmpq_get_num"; -- Get the numerator of a rational procedure mpq_get_den (den : access mpz_t; op : access constant mpq_t) with Import => True, Convention => C, External_Name => "__gmpq_get_den"; -- Get the denumerator of a rational procedure mpq_set_num (op : access constant mpq_t; num : access constant mpz_t) with Import => True, Convention => C, External_Name => "__gmpq_set_num"; -- Set the numerator of a rational procedure mpq_set_den (op : access constant mpq_t; den : access constant mpz_t) with Import => True, Convention => C, External_Name => "__gmpq_set_den"; -- Set the denumerator of a rational private type mpz_t is record mp_alloc : Int; mp_size : Int; mp_d : System.Address; end record; pragma Convention (C, mpz_t); type gmp_randstate_t is limited record mp_seed : mpz_t; mp_alg : Int; mp_lc : System.Address; end record; pragma Convention (C, gmp_randstate_t); type mpq_t is record num : mpz_t; den : mpz_t; end record with Convention => C; end GNATCOLL.GMP.Lib; gnatcoll-bindings-25.0.0/gmp/gnatcoll-gmp-mpz_even_p.c000066400000000000000000000026771464374334300226760ustar00rootroot00000000000000/*--------------------------------------------------------------------- -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2017, AdaCore -- -- -- -- GPS is free software; you can redistribute it and/or modify it -- -- under the terms of the GNU General Public License as published by -- -- the Free Software Foundation; either version 2 of the License, or -- -- (at your option) any later version. -- -- -- -- This program is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- -- General Public License for more details. You should have received -- -- a copy of the GNU General Public License along with this library; -- -- if not, write to the Free Software Foundation, Inc., 59 Temple -- -- Place - Suite 330, Boston, MA 02111-1307, USA. -- ---------------------------------------------------------------------*/ #include /* a wrapper for mpz_even_p because it is only a macro and therefore cannot be imported */ int gmp_mpz_even_p (mpz_t OP) { return mpz_even_p (OP); } gnatcoll-bindings-25.0.0/gmp/gnatcoll-gmp-mpz_odd_p.c000066400000000000000000000026741464374334300225040ustar00rootroot00000000000000/*--------------------------------------------------------------------- -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2017, AdaCore -- -- -- -- GPS is free software; you can redistribute it and/or modify it -- -- under the terms of the GNU General Public License as published by -- -- the Free Software Foundation; either version 2 of the License, or -- -- (at your option) any later version. -- -- -- -- This program is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- -- General Public License for more details. You should have received -- -- a copy of the GNU General Public License along with this library; -- -- if not, write to the Free Software Foundation, Inc., 59 Temple -- -- Place - Suite 330, Boston, MA 02111-1307, USA. -- ---------------------------------------------------------------------*/ #include /* a wrapper for mpz_odd_p because it is only a macro and therefore cannot be imported */ int gmp_mpz_odd_p (mpz_t OP) { return mpz_odd_p (OP); } gnatcoll-bindings-25.0.0/gmp/gnatcoll-gmp-mpz_sign.c000066400000000000000000000026721464374334300223550ustar00rootroot00000000000000/*--------------------------------------------------------------------- -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2017, AdaCore -- -- -- -- GPS is free software; you can redistribute it and/or modify it -- -- under the terms of the GNU General Public License as published by -- -- the Free Software Foundation; either version 2 of the License, or -- -- (at your option) any later version. -- -- -- -- This program is distributed in the hope that it will be useful, -- -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- -- General Public License for more details. You should have received -- -- a copy of the GNU General Public License along with this library; -- -- if not, write to the Free Software Foundation, Inc., 59 Temple -- -- Place - Suite 330, Boston, MA 02111-1307, USA. -- ---------------------------------------------------------------------*/ #include /* a wrapper for mpz_sgn because mpz_sgn is only a macro and therefore cannot be imported */ int gmp_mpz_sgn (mpz_t OP) { return mpz_sgn(OP); } gnatcoll-bindings-25.0.0/gmp/gnatcoll-gmp-random_state.adb000066400000000000000000000076071464374334300235160ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2017, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ package body GNATCOLL.GMP.Random_State is use GNATCOLL.GMP.Lib; ---------------- -- Initialize -- ---------------- procedure Initialize (This : out Generator) is begin gmp_randinit_default (This.G'Access); end Initialize; --------------------------------- -- Initialize_Mersenne_Twister -- --------------------------------- procedure Initialize_Mersenne_Twister (This : out Generator) is begin gmp_randinit_mt (This.G'Access); end Initialize_Mersenne_Twister; --------- -- Set -- --------- procedure Set (This : out Generator; To : Generator) is begin gmp_randinit_set (This.G'Access, To.G'Access); end Set; ----------- -- Clear -- ----------- procedure Clear (This : in out Generator) is begin gmp_randclear (This.G'Access); end Clear; -------------- -- Set_Seed -- -------------- procedure Set_Seed (This : in out Generator; Seed : Big_Integer) is begin gmp_randseed (This.G'Access, As_mpz_t (Seed)); end Set_Seed; -------------- -- Set_Seed -- -------------- procedure Set_Seed (This : in out Generator; Seed : Unsigned_Long) is begin gmp_randseed_ui (This.G'Access, Seed); end Set_Seed; ------------------------- -- Uniform_Number_Bits -- ------------------------- function Number_Bits (This : Generator; N : Unsigned_Long) return Long is That : Generator renames This'Unrestricted_Access.all; begin return gmp_urandomb_ui (That.G'Access, N); end Number_Bits; -------------------- -- Uniform_Number -- -------------------- function Number (This : Generator; N : Unsigned_Long) return Long is That : Generator renames This'Unrestricted_Access.all; begin return gmp_urandomm_ui (That.G'Access, N); end Number; ------------------------ -- As_gmp_randstate_t -- ------------------------ function As_gmp_randstate_t (This : Generator) return access constant GNATCOLL.GMP.Lib.gmp_randstate_t is begin return This.G'Unchecked_Access; end As_gmp_randstate_t; end GNATCOLL.GMP.Random_State; gnatcoll-bindings-25.0.0/gmp/gnatcoll-gmp-random_state.ads000066400000000000000000000105731464374334300235330ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2017, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with GNATCOLL.GMP.Lib; with GNATCOLL.GMP.Integers; use GNATCOLL.GMP.Integers; package GNATCOLL.GMP.Random_State is pragma Preelaborate; type Generator is tagged limited private; -- State Initialization procedure Initialize (This : out Generator); -- Initialize This with a default algorithm. The choice will be a -- compromise between speed and randomness, and is recommended for -- applications with no special requirements. Currently the choice is -- Initialize_Mersenne_Twister. procedure Initialize_Mersenne_Twister (This : out Generator); -- Initialize This for a Mersenne Twister algorithm. This algorithm -- is fast and has good randomness properties. procedure Set (This : out Generator; To : Generator); -- Initialize This with a copy of the algorithm and state from To. procedure Clear (This : in out Generator); -- Free all memory occupied by This. -- State Seeding procedure Set_Seed (This : in out Generator; Seed : Big_Integer); -- Set an initial seed value into This. procedure Set_Seed (This : in out Generator; Seed : Unsigned_Long); -- Set an initial seed value into This. -- Misc function Number_Bits (This : Generator; N : Unsigned_Long) return Long; -- Return a uniformly distributed random number of N bits, ie. in the -- range 0 to 2^N-1 inclusive. N must be less than or equal to the -- number of bits in an `unsigned long'. function Number (This : Generator; N : Unsigned_Long) return Long; -- Return a uniformly distributed random number in the range 0 to -- N-1, inclusive. function As_gmp_randstate_t (This : Generator) return access constant GNATCOLL.GMP.Lib.gmp_randstate_t; -- This function is useful for passing Generator values to routines from -- gmplib that do not have an Ada binding defined by this package. In that -- case the user will define the binding but will not be able to pass -- Generator objects as parameters to their routine. This function provides -- the required visibility to the internal gmp_randstate_t component of a -- Generator object. The type should really be access-to-variable since the -- routines will be modifying the state of the referenced Generator object, -- but that will not support use within functions. However it doesn't -- really matter since the underlying C routines just use it as an address -- anyway. Alternatively we could have two of these functions, one with a -- read-write view. private type Generator is tagged limited record G : aliased GNATCOLL.GMP.Lib.gmp_randstate_t; end record; end GNATCOLL.GMP.Random_State; gnatcoll-bindings-25.0.0/gmp/gnatcoll-gmp-rational_numbers.adb000066400000000000000000000354511464374334300244000ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2022, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with GNATCOLL.GMP.Integers.Misc; use GNATCOLL.GMP.Integers.Misc; with Interfaces.C.Strings; package body GNATCOLL.GMP.Rational_Numbers is use GNATCOLL.GMP.Lib; ------------------ -- Canonicalize -- ------------------ procedure Canonicalize (This : in out Rational) is begin if not This.Canonicalized then mpq_canonicalize (This.Value'Access); This.Canonicalized := True; end if; end Canonicalize; ------------------ -- Is_Canonical -- ------------------ function Is_Canonical (This : Rational) return Boolean is begin return This.Canonicalized; end Is_Canonical; --------- -- Set -- --------- procedure Set (This : out Rational; To : Rational; Canonicalize : Boolean := True) is begin This.Canonicalized := To.Canonicalized; mpq_set (This.Value'Access, To.Value'Access); if Canonicalize then This.Canonicalize; end if; end Set; procedure Set (This : out Rational; To : Big_Integer) is begin -- This is canonical for sure as the denominator is set to 1 by -- construction. This.Canonicalized := True; mpq_set_z (This.Value'Access, As_mpz_t (To)); end Set; procedure Set (This : out Rational; Num : Long; Den : Unsigned_Long := 1; Canonicalize : Boolean := True) is begin if Den = 0 then raise Failure with "cannot set number with 0 as denominator"; end if; This.Canonicalized := False; mpq_set_si (This.Value'Access, Num, Den); if Canonicalize then This.Canonicalize; end if; end Set; procedure Set (This : out Rational; To : String; Base : Int := 10; Canonicalize : Boolean := True) is use Interfaces.C.Strings; Result : Int; Input : chars_ptr := New_String (To); begin This.Canonicalized := False; Result := mpq_set_str (This.Value'Access, Input, Base); Free (Input); if Result /= 0 then raise Failure with "cannot parse " & To & " (base: " & Base'Image & ")"; end if; if This.Denominator = 0 then raise Failure with "cannot set number with 0 as denominator"; end if; if Canonicalize then This.Canonicalize; end if; end Set; procedure Set (This : out Rational; To : Double) is begin if To /= To then raise Failure with "cannot set number from a NaN"; elsif To > Double'Last or else To < Double'First then raise Failure with "cannot set number from infinity"; end if; -- Set from Double is canonical by construction This.Canonicalized := True; mpq_set_d (This.Value'Access, To); end Set; ---------- -- Swap -- ---------- procedure Swap (R1, R2 : in out Rational) is Canonicalized : constant Boolean := R1.Canonicalized; begin mpq_swap (R1.Value'Access, R2.Value'Access); R1.Canonicalized := R2.Canonicalized; R2.Canonicalized := Canonicalized; end Swap; ----------- -- Image -- ----------- function Image (This : Rational; Base : Integer := 10) return String is use Interfaces.C, Interfaces.C.Strings; Num : constant Big_Integer := Numerator (This); Den : constant Big_Integer := Denominator (This); Result : chars_ptr; Number_Digits : constant size_t := mpz_sizeinbase (As_mpz_t (Num), Int (abs Base)) + mpz_sizeinbase (As_mpz_t (Den), Int (abs Base)); Buffer : String (1 .. Integer (Number_Digits) + 3); -- The correct number to allocate is 3 more than Number_Digits in -- order to handle a possible minus sign, possible slash, and the -- null-terminator. begin Result := mpq_get_str (Buffer'Address, Int (Base), This.Value'Access); return Value (Result); end Image; --------------- -- To_Double -- --------------- function To_Double (This : Rational) return Double is begin return mpq_get_d (This.Value'Access); end To_Double; -------------------------- -- Operand_Precondition -- -------------------------- procedure Operand_Precondition (This : Rational; Name : String := "") is begin if not This.Canonicalized then raise Failure with (if Name /= "" then Name & " " else Name) & "operand must be canonicalized"; end if; end Operand_Precondition; --------- -- "+" -- --------- function "+" (Left, Right : Rational) return Rational is begin return Result : Rational do Operand_Precondition (Left, "Left"); Operand_Precondition (Right, "Right"); mpq_add (Result.Value'Access, Left.Value'Access, Right.Value'Access); end return; end "+"; --------- -- "-" -- --------- function "-" (Left, Right : Rational) return Rational is begin return Result : Rational do Operand_Precondition (Left, "Left"); Operand_Precondition (Right, "Right"); mpq_sub (Result.Value'Access, Left.Value'Access, Right.Value'Access); end return; end "-"; function "-" (Left : Rational) return Rational is begin return Result : Rational do Operand_Precondition (Left); mpq_neg (Result.Value'Access, Left.Value'Access); end return; end "-"; --------- -- "*" -- --------- function "*" (Left, Right : Rational) return Rational is begin return Result : Rational do Operand_Precondition (Left, "Left"); Operand_Precondition (Right, "Right"); mpq_mul (Result.Value'Access, Left.Value'Access, Right.Value'Access); end return; end "*"; --------- -- "/" -- --------- function "/" (Left, Right : Rational) return Rational is begin return Result : Rational do Operand_Precondition (Left, "Left"); Operand_Precondition (Right, "Right"); -- Since GNAT signal handlers can be disabled, do not rely on the -- runtime to raise a Contraint_Error (SIGFPE), but raise an explicit -- Failure exception on division by zero. -- Use Result as a temporary to compare Right to 0 since Rational -- numbers are set to 0/1 by default. if mpq_equal (Right.Value'Access, Result.Value'Access) = 0 then mpq_div (Result.Value'Access, Left.Value'Access, Right.Value'Access); else raise Failure with "Division by zero"; end if; end return; end "/"; ----------- -- "abs" -- ----------- function "abs" (Left : Rational) return Rational is begin return Result : Rational do Operand_Precondition (Left); mpq_abs (Result.Value'Access, Left.Value'Access); end return; end "abs"; ---------- -- "**" -- ---------- function "**" (Left : Rational; Right : Big_Integer) return Rational is R : constant Unsigned_Long := Unsigned_Long (abs As_Signed_Long (Right)); begin Operand_Precondition (Left, "Left"); if not Fits_Signed_Long (Right) then raise Failure with "Exponent too big, exponentiation won't fit in memory"; end if; return Result : Rational do if Right = 0 then Result.Set (1); else if Right < 0 then -- 1/Left ** -Right Result.Set_Num (Left.Denominator ** (R)); Result.Set_Den (Left.Numerator ** (R)); else -- Left ** Right Result.Set_Num (Left.Numerator ** R); Result.Set_Den (Left.Denominator ** R); end if; Result.Canonicalize; end if; end return; end "**"; ------- -- = -- ------- function "=" (Left, Right : Rational) return Boolean is begin Operand_Precondition (Left, "Left"); Operand_Precondition (Right, "Right"); return mpq_equal (Left.Value'Access, Right.Value'Access) /= 0; end "="; function "=" (Left : Rational; Right : Big_Integer) return Boolean is begin Operand_Precondition (Left, "Left"); return mpq_cmp_z (Left.Value'Access, As_mpz_t (Right)) = 0; end "="; function "=" (Left : Big_Integer; Right : Rational) return Boolean is begin Operand_Precondition (Right, "Right"); return mpq_cmp_z (Right.Value'Access, As_mpz_t (Left)) = 0; end "="; ------- -- > -- ------- function ">" (Left, Right : Rational) return Boolean is begin Operand_Precondition (Left, "Left"); Operand_Precondition (Right, "Right"); return mpq_cmp (Left.Value'Access, Right.Value'Access) > 0; end ">"; function ">" (Left : Rational; Right : Big_Integer) return Boolean is begin Operand_Precondition (Left, "Left"); return mpq_cmp_z (Left.Value'Access, As_mpz_t (Right)) > 0; end ">"; function ">" (Left : Big_Integer; Right : Rational) return Boolean is begin Operand_Precondition (Right, "Right"); return mpq_cmp_z (Right.Value'Access, As_mpz_t (Left)) < 0; end ">"; ------- -- < -- ------- function "<" (Left, Right : Rational) return Boolean is begin Operand_Precondition (Left, "Left"); Operand_Precondition (Right, "Right"); return mpq_cmp (Left.Value'Access, Right.Value'Access) < 0; end "<"; function "<" (Left : Rational; Right : Big_Integer) return Boolean is begin Operand_Precondition (Left, "Left"); return mpq_cmp_z (Left.Value'Access, As_mpz_t (Right)) < 0; end "<"; function "<" (Left : Big_Integer; Right : Rational) return Boolean is begin Operand_Precondition (Right, "Right"); return mpq_cmp_z (Right.Value'Access, As_mpz_t (Left)) > 0; end "<"; -------- -- >= -- -------- function ">=" (Left, Right : Rational) return Boolean is begin Operand_Precondition (Left, "Left"); Operand_Precondition (Right, "Right"); return mpq_cmp (Left.Value'Access, Right.Value'Access) >= 0; end ">="; function ">=" (Left : Rational; Right : Big_Integer) return Boolean is begin Operand_Precondition (Left, "Left"); return mpq_cmp_z (Left.Value'Access, As_mpz_t (Right)) >= 0; end ">="; function ">=" (Left : Big_Integer; Right : Rational) return Boolean is begin Operand_Precondition (Right, "Right"); return mpq_cmp_z (Right.Value'Access, As_mpz_t (Left)) <= 0; end ">="; -------- -- <= -- -------- function "<=" (Left, Right : Rational) return Boolean is begin Operand_Precondition (Left, "Left"); Operand_Precondition (Right, "Right"); return mpq_cmp (Left.Value'Access, Right.Value'Access) <= 0; end "<="; function "<=" (Left : Rational; Right : Big_Integer) return Boolean is begin Operand_Precondition (Left, "Left"); return mpq_cmp_z (Left.Value'Access, As_mpz_t (Right)) <= 0; end "<="; function "<=" (Left : Big_Integer; Right : Rational) return Boolean is begin Operand_Precondition (Right, "Right"); return mpq_cmp_z (Right.Value'Access, As_mpz_t (Left)) >= 0; end "<="; --------------- -- Numerator -- --------------- function Numerator (This : Rational) return Big_Integer is Num : aliased mpz_t; begin return Result : Big_Integer do mpz_init (Num'Access); mpq_get_num (Num'Access, This.Value'Access); Set (Result, Num'Access); mpz_clear (Num'Access); end return; end Numerator; ----------------- -- Denominator -- ----------------- function Denominator (This : Rational) return Big_Integer is Den : aliased mpz_t; begin return Result : Big_Integer do mpz_init (Den'Access); mpq_get_den (Den'Access, This.Value'Access); Set (Result, Den'Access); mpz_clear (Den'Access); end return; end Denominator; ------------- -- Set_Num -- ------------- procedure Set_Num (This : in out Rational; Num : Big_Integer; Canonicalize : Boolean := True) is begin mpq_set_num (This.Value'Access, As_mpz_t (Num)); This.Canonicalized := False; if Canonicalize then This.Canonicalize; end if; end Set_Num; ------------- -- Set_Den -- ------------- procedure Set_Den (This : in out Rational; Den : Big_Integer; Canonicalize : Boolean := True) is begin if Den = 0 then raise Failure with "cannot set denominator to 0"; end if; mpq_set_den (This.Value'Access, As_mpz_t (Den)); This.Canonicalized := False; if Canonicalize then This.Canonicalize; end if; end Set_Den; ---------------- -- Initialize -- ---------------- overriding procedure Initialize (This : in out Rational) is begin mpq_init (This.Value'Access); end Initialize; -------------- -- Finalize -- -------------- overriding procedure Finalize (This : in out Rational) is begin mpq_clear (This.Value'Access); end Finalize; end GNATCOLL.GMP.Rational_Numbers; gnatcoll-bindings-25.0.0/gmp/gnatcoll-gmp-rational_numbers.ads000066400000000000000000000213551464374334300244170ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2022, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with GNATCOLL.GMP.Integers; use GNATCOLL.GMP.Integers; with GNATCOLL.GMP.Lib; with Ada.Finalization; package GNATCOLL.GMP.Rational_Numbers is type Rational is tagged limited private; -- The type is limited because clients should not use predefined -- assignment; nor should they use predefined equality. This matches the -- semantics of the underlying GMP library in C. For assignment, use the -- Set routines. The equality operator is explicitly redefined. -- The underlying C version of the GMP requires the user to manually -- initialize the rational number objects (i.e., those of type -- mpq_t). Likewise, users are expected to clear these objects to reclaim -- the memory allocated. Initialization and clearing are performed -- automatically in this Ada version. Failure : exception; procedure Canonicalize (This : in out Rational); -- Remove any factors that are common to the numerator and denominator of -- This, and make the denominator positive. -- -- All rational arithmetic functions assume operands have a canonical form, -- and canonicalize their result. The canonical form means that the -- denominator and the numerator have no common factors, and that the -- denominator is positive. Zero has the unique representation 0/1. -- -- Set procedures canonicalize the assigned variable by default (see Set -- methods below) so you don't have to worry about it. If you do not need -- explicitly to handle non-canonical values, you don't have to use this -- procedure, every rational number is automatically canonicalized. function Is_Canonical (This : Rational) return Boolean; -- Return whether This is in canonical form -- Assignment procedure Set (This : out Rational; To : Rational; Canonicalize : Boolean := True); -- Copy the To rational number to This procedure Set (This : out Rational; To : Big_Integer); -- Set This rational to a Big_Integer procedure Set (This : out Rational; Num : Long; Den : Unsigned_Long := 1; Canonicalize : Boolean := True); -- Set This rational to "Num/Den" integers procedure Set (This : out Rational; To : String; Base : Int := 10; Canonicalize : Boolean := True); -- Set This from the string To in the given Base. -- -- The string can be an integer like "41" or a fraction like "41/152". The -- fraction must be in canonical form, or if not then Canonicalize must -- be called. -- -- The numerator and optional denominator are parsed the same as in -- Integers.Set. White space is allowed in the string, and is simply -- ignored. The base can vary from 2 to 62, or if base is 0 then the -- leading characters are used: 0x or 0X for hex, 0b or 0B for binary, 0 -- for octal, or decimal otherwise. Note that this is done separately for -- the numerator and denominator, so for instance 0xEF/100 is 239/100, -- whereas 0xEF/0x100 is 239/256. -- -- Raise a Failure exception if the string is not valid or if the -- denominator is 0. procedure Set (This : out Rational; To : Double); -- Set This to a Double procedure Swap (R1, R2 : in out Rational); -- Swap two Rational numbers -- Output function Image (This : Rational; Base : Integer := 10) return String; -- See GMP.Lib.mpq_get_str for more documentation about Base -- Conversion function To_Double (This : Rational) return Double; -- Convert This to a double, truncating if necessary (i.e. rounding towards -- zero). -- -- If the exponent from the conversion is too big or too small to fit a -- double then the result is system dependent. For too big numbers an -- infinity is returned when available. For too small numbers, 0.0 is -- normally returned. Hardware overflow, underflow and denorm traps may or -- may not occur. -- Arithmetic function "+" (Left, Right : Rational) return Rational; function "-" (Left, Right : Rational) return Rational; function "*" (Left, Right : Rational) return Rational; function "/" (Left, Right : Rational) return Rational; function "-" (Left : Rational) return Rational; function "abs" (Left : Rational) return Rational; function "**" (Left : Rational; Right : Big_Integer) return Rational; -- Comparisons function "=" (Left : Rational; Right : Rational) return Boolean; function "=" (Left : Rational; Right : Big_Integer) return Boolean; function "=" (Left : Big_Integer; Right : Rational) return Boolean; function ">" (Left : Rational; Right : Rational) return Boolean; function ">" (Left : Rational; Right : Big_Integer) return Boolean; function ">" (Left : Big_Integer; Right : Rational) return Boolean; function "<" (Left : Rational; Right : Rational) return Boolean; function "<" (Left : Rational; Right : Big_Integer) return Boolean; function "<" (Left : Big_Integer; Right : Rational) return Boolean; function ">=" (Left : Rational; Right : Rational) return Boolean; function ">=" (Left : Rational; Right : Big_Integer) return Boolean; function ">=" (Left : Big_Integer; Right : Rational) return Boolean; function "<=" (Left : Rational; Right : Rational) return Boolean; function "<=" (Left : Rational; Right : Big_Integer) return Boolean; function "<=" (Left : Big_Integer; Right : Rational) return Boolean; -- Integer functions function Numerator (This : Rational) return Big_Integer; -- Return the numerator of This function Denominator (This : Rational) return Big_Integer; -- Return the denominator of This procedure Set_Num (This : in out Rational; Num : Big_Integer; Canonicalize : Boolean := True); -- Set the numerator of This procedure Set_Den (This : in out Rational; Den : Big_Integer; Canonicalize : Boolean := True); -- Set the denominator of This private type Rational is new Ada.Finalization.Limited_Controlled with record Value : aliased GNATCOLL.GMP.Lib.mpq_t; Canonicalized : Boolean := True; -- Canonical form is required by all rational arithemtic operations. -- This member keeps track of whether Value was canonicalized, so -- that we both never do arithmetic on non-canonical forms and -- canonicalize values at most once. Since all rational arithemtic -- operations return a canonicalized result, we set it to True by -- default. Only some assignment functions can produce non-canonical -- values. end record; overriding procedure Initialize (This : in out Rational); overriding procedure Finalize (This : in out Rational); procedure Operand_Precondition (This : Rational; Name : String := ""); -- Check that This is in canonical form, if not, raise an exception saying -- that Name is not canonicalized. end GNATCOLL.GMP.Rational_Numbers; gnatcoll-bindings-25.0.0/gmp/gnatcoll-gmp.ads000066400000000000000000000045501464374334300210530ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2022, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ -- An Ada interface to the GNU Multiple Precision (GMP) arithmetic library. -- See child packages for specific types, such as package GMP.Integers. with Interfaces.C; package GNATCOLL.GMP is pragma Pure; -- We define these numeric types here so that clients of the Ada binding -- do not also have to import package Interfaces.C themselves. -- These types correspond to those used by the underlying C implementation -- of the GMP library itself. type Int is new Interfaces.C.int; type Long is new Interfaces.C.long; type Unsigned_Long is new Interfaces.C.unsigned_long; type Double is new Interfaces.C.double; end GNATCOLL.GMP; gnatcoll-bindings-25.0.0/gmp/gnatcoll_gmp.gpr000066400000000000000000000102001464374334300211430ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2015-2020, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with "gnatcoll_core"; library project GnatColl_GMP is Version := External ("GNATCOLL_VERSION", "0.0"); Name := "gnatcoll_gmp"; type Build_Type is ("DEBUG", "PROD"); Build : Build_Type := External ("GNATCOLL_BUILD_MODE", External ("BUILD", "PROD")); type Library_Type_Type is ("relocatable", "static", "static-pic"); Library_Type : Library_Type_Type := External ("LIBRARY_TYPE", "static"); for Source_Dirs use ("."); for Library_Kind use Library_Type; for Object_Dir use "obj/" & Project'Library_Kind; for Library_Dir use "lib/" & Project'Library_Kind; for Library_Name use Name; for Languages use ("Ada", "C"); case Library_Type is when "relocatable" => for Leading_Library_Options use External_As_List ("LDFLAGS", " "); for Library_Version use "lib" & Name & Gnatcoll_Core.So_Ext & "." & Version; for Library_Options use ("-lgmp"); when others => null; end case; package Compiler is case Build is when "DEBUG" => for Switches ("Ada") use ("-g", "-O0", "-gnata", "-gnatVa", "-gnatQ", "-gnatyg", "-gnateE", "-gnatwaCJe", "-fstack-check", "-gnatwae"); for Switches ("C") use ("-g", "-Wall" ,"-Werror"); when "PROD" => -- Do not use -gnatwe for production mode for Switches ("Ada") use ("-O2", "-gnatn", "-gnatwaCJ", "-gnatyg", "-gnatwa"); for Switches ("C") use ("-O2", "-Wall"); end case; for Switches ("Ada") use Compiler'Switches ("Ada") & External_As_List ("ADAFLAGS", " "); for Switches ("C") use Compiler'Switches ("C") & External_As_List ("CFLAGS", " ") & External_As_List ("CPPFLAGS", " "); end Compiler; package Binder is case Build is when "DEBUG" => for Switches ("Ada") use ("-E"); when "PROD" => null; end case; end Binder; package Builder is case Build is when "DEBUG" => for Global_Configuration_Pragmas use "../gnat_debug.adc"; when "PROD" => null; end case; end Builder; package Ide is for VCS_Kind use "Git"; end Ide; package Linker is for Linker_Options use ("-lgmp"); end Linker; package Install is for Artifacts ("share/examples/gnatcoll/gmp") use ("examples/*"); end Install; end GnatColl_GMP; gnatcoll-bindings-25.0.0/gmp/setup.py000077500000000000000000000042301464374334300175060ustar00rootroot00000000000000#!/usr/bin/env python import logging import os import sys sys.path.append(os.path.dirname(os.path.dirname(os.path.abspath(__file__)))) from setup_support import SetupApp class GNATCollGMP(SetupApp): name = 'gnatcoll_gmp' project = 'gnatcoll_gmp.gpr' description = 'GNATColl GMP bindings' def create(self): super(GNATCollGMP, self).create() self.build_cmd.add_argument( '--debug', help='build project in debug mode', action="store_true", default=False) def update_config(self, config, args): logging.info('%-26s %s', 'Libraries kind', ", ".join(config.data['library_types'])) # Set library version with open(os.path.join(config.source_dir, '..', 'version_information'), 'r') as fd: version = fd.read().strip() config.set_data('GNATCOLL_VERSION', version, sub='gprbuild') # Set build mode config.set_data('BUILD', 'DEBUG' if args.debug else 'PROD', sub='gprbuild') logging.info('%-26s %s', 'Build mode', config.data['gprbuild']['BUILD']) # Set GNATCOLL_OS if 'darwin' in config.data['canonical_target']: gnatcoll_os = 'osx' elif 'windows' in config.data['canonical_target']: gnatcoll_os = 'windows' else: # Assume this is an Unix system gnatcoll_os = 'unix' config.set_data('GNATCOLL_OS', gnatcoll_os, sub='gprbuild') def variants(self, config, cmd): result = [] for library_type in config.data['library_types']: gpr_vars = {'LIBRARY_TYPE': library_type, 'XMLADA_BUILD': library_type, 'GPR_BUILD': library_type} if cmd == 'install': result.append((['--build-name=%s' % library_type, '--build-var=LIBRARY_TYPE'], gpr_vars)) else: result.append(([], gpr_vars)) return result if __name__ == '__main__': app = GNATCollGMP() sys.exit(app.run()) gnatcoll-bindings-25.0.0/gnat_debug.adc000066400000000000000000000000331464374334300177530ustar00rootroot00000000000000pragma Initialize_Scalars; gnatcoll-bindings-25.0.0/iconv/000077500000000000000000000000001464374334300163255ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/iconv/README.md000066400000000000000000000033121464374334300176030ustar00rootroot00000000000000The GNAT Components Collection (GNATCOLL) - Iconv ================================================= This is the Iconv component of the GNAT Components Collection. It is an interface to libiconv. There are multiple variants of libiconv: on some Unix systems it is part of the C library, whereas other systems have installed the GNU libiconv separately. Those variants work slightly differently. For historical reasons, international text is often encoded using a language or country dependent character encoding. With the advent of the internet and the frequent exchange of text across countries - even the viewing of a web page from a foreign country is a "text exchange" in this context -, conversions between these encodings have become important. They have also become a problem, because many characters which are present in one encoding are absent in many other encodings. To solve this mess, the Unicode encoding has been created. It is a super-encoding of all others and is therefore the default encoding for new text formats like XML. However, many computers still operate in locale with a traditional (limited) character encoding. Some programs, like mailers and web browsers, must be able to convert between a given text encoding and the user's encoding. Other programs internally store strings in Unicode, to facilitate internal processing, and need to convert between internal string representation (Unicode) and external string representation (a traditional encoding) when they are doing I/O. Libiconv is a conversion library for both kinds of applications. Dependencies ------------ This component requires the following external components, that should be available on your system: - gprbuild - gnatcoll-core - iconv gnatcoll-bindings-25.0.0/iconv/docs/000077500000000000000000000000001464374334300172555ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/iconv/docs/Makefile000066400000000000000000000000431464374334300207120ustar00rootroot00000000000000include ../../docs-common/Makefile gnatcoll-bindings-25.0.0/iconv/docs/conf.py000066400000000000000000000016171464374334300205610ustar00rootroot00000000000000# -*- coding: utf-8 -*- # # GNATcoll Bindings - Iconv documentation build configuration file # Load the base setup exec(open('../../docs-common/common_conf.py').read()) # General information about the project. project = u'GNATcoll Bindings - Iconv' # Output file base name for HTML help builder. htmlhelp_basename = 'GNATcoll-Iconv' # Grouping the document tree into LaTeX files. List of tuples # (source start file, target name, title, author, documentclass # [howto/manual]). latex_documents = [ ('index', 'GNATcoll-Iconv.tex', u'GNATcoll Bindings - Iconv Documentation', u'AdaCore', 'manual'), ] # One entry per manual page. List of tuples # (source start file, name, description, authors, manual section). man_pages = [ ('index', 'gnatcoll-iconv', u'GNATcoll Bindings - Iconv Documentation', [u'AdaCore'], 1) ] # Bibliographic Dublin Core info. epub_title = u'GNATcoll Bindings - Iconv' gnatcoll-bindings-25.0.0/iconv/docs/index.rst000066400000000000000000000024211464374334300211150ustar00rootroot00000000000000GNATcoll Bindings - Iconv: Converting between character encodings ================================================================= .. index:: iconv .. index:: charset .. highlight:: ada This package provides a binding to the libiconv library. This library is standard on most Unix systems. When it is not provided by the system, the GNU libiconv package can be installed instead. Using GNATCOLL.Iconv ==================== Use the ``gnatcoll_iconv`` project in your project files. For instance:: with "gnatcoll_iconv"; project Default is ... end Default; API === The whole API is documented in :file:`gnatcoll-iconv.ads`. Here is a simple code sample that converts from iso-8859-1 encoding to UTF8:: with GNATCOLL.Iconv; use GNATCOLL.Iconv; procedure Main is EAcute : constant Character := Character'Val (16#E9#); -- in iso-8859-1 Result : constant String := Iconv ("Some string " & EAcute, To_Code => UTF8, From_Code => ISO_8859_1); begin null; end Main; A more advanced (and somewhat more efficient) API is available via the ``Iconv`` procedure. In that procedure, you control the input and output buffers, so you will need less overall memory when you are converting big buffers. gnatcoll-bindings-25.0.0/iconv/gnatcoll-iconv.adb000066400000000000000000000242121464374334300217150ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2013-2017, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with Interfaces.C; use Interfaces.C; with Interfaces.C.Strings; use Interfaces.C.Strings; with Ada.Unchecked_Conversion; with GNAT.OS_Lib; use GNAT.OS_Lib; with GNATCOLL.Traces; use GNATCOLL.Traces; package body GNATCOLL.Iconv is Me : constant Trace_Handle := Create ("ICONV"); C_E2BIG : constant Integer; -- C_EINVAL : constant Integer; C_EILSEQ : constant Integer; pragma Import (C, C_E2BIG, "gnatcoll_errno_e2big"); -- pragma Import (C, C_EINVAL, "gnatcoll_errno_einval"); pragma Import (C, C_EILSEQ, "gnatcoll_errno_eilseq"); -- C errno values, defined in iconv_support.c function C_Iconv (cd : System.Address; inbuf : access chars_ptr; inbytesleft : access size_t; outbuf : access chars_ptr; outbytesleft : access size_t) return size_t; pragma Import (C, C_Iconv, "gnatcoll_iconv"); function C_Iconv_Open (tocode, fromcode : chars_ptr) return System.Address; pragma Import (C, C_Iconv_Open, "gnatcoll_iconv_open"); procedure C_Iconv_Close (State : System.Address); pragma Import (C, C_Iconv_Close, "gnatcoll_iconv_close"); function Conv is new Ada.Unchecked_Conversion (System.Address, chars_ptr); ---------------- -- Iconv_Open -- ---------------- function Iconv_Open (To_Code : String := UTF8; From_Code : String := Locale; Transliteration : Boolean := False; Ignore : Boolean := False) return Iconv_T is use System; State : Iconv_T; Tocode, Fromcode : chars_ptr; begin if Transliteration then if Ignore then Tocode := New_String (To_Code & "//TRANSLIT//IGNORE"); else Tocode := New_String (To_Code & "//TRANSLIT"); end if; else if Ignore then Tocode := New_String (To_Code & "//IGNORE"); else Tocode := New_String (To_Code); end if; end if; State.Emulate_Ignore := Ignore; Fromcode := New_String (From_Code); State.T := C_Iconv_Open (Tocode, Fromcode); Free (Fromcode); Free (Tocode); if State.T = Null_Address then raise Unsupported_Conversion with "Unsupported conversion from '" & From_Code & "' to '" & To_Code & "'"; end if; return State; end Iconv_Open; ----------- -- Iconv -- ----------- procedure Iconv (State : Iconv_T; Inbuf : Byte_Sequence; Input_Index : in out Positive; Outbuf : in out Byte_Sequence; Output_Index : in out Positive; Result : out Iconv_Result) is Inptr : aliased chars_ptr := Conv (Inbuf (Input_Index)'Address); Inleft : aliased size_t := size_t (Inbuf'Last - Input_Index + 1); Outptr : aliased chars_ptr := Conv (Outbuf (Output_Index)'Address); Outleft : aliased size_t := size_t (Outbuf'Last - Output_Index + 1); Res : size_t; begin Res := C_Iconv (State.T, Inptr'Access, Inleft'Access, Outptr'Access, Outleft'Access); Input_Index := Inbuf'Last - Integer (Inleft) + 1; Output_Index := Outbuf'Last - Integer (Outleft) + 1; if Res = -1 then if Errno = C_EILSEQ then if State.Emulate_Ignore then Result := Full_Buffer; Input_Index := Input_Index + 1; else Result := Invalid_Multibyte_Sequence; end if; elsif Errno = C_E2BIG then Result := Full_Buffer; else -- C_EINVAL Result := Incomplete_Multibyte_Sequence; end if; else Result := Success; end if; end Iconv; ----------- -- Reset -- ----------- procedure Reset (State : Iconv_T) is Res : size_t; pragma Unreferenced (Res); begin Res := C_Iconv (State.T, null, null, null, null); end Reset; ----------- -- Reset -- ----------- procedure Reset (State : Iconv_T; Outbuf : in out Byte_Sequence; Output_Index : in out Positive; Result : out Iconv_Result) is Outptr : aliased chars_ptr := Conv (Outbuf (Output_Index)'Address); Outleft : aliased size_t := size_t (Outbuf'Last - Output_Index + 1); Res : size_t; begin Res := C_Iconv (State.T, null, null, Outptr'Access, Outleft'Access); Output_Index := Outbuf'Last - Integer (Outleft) + 1; if Res = -1 then Result := Full_Buffer; else Result := Success; end if; end Reset; ----------------- -- Iconv_Close -- ----------------- procedure Iconv_Close (State : Iconv_T) is use type System.Address; begin if State.T /= System.Null_Address then C_Iconv_Close (State.T); end if; end Iconv_Close; ----------- -- Iconv -- ----------- function Iconv (State : Iconv_T; Input : Byte_Sequence; Ignore_Errors : Boolean := False) return Byte_Sequence is Output : String_Access := new Byte_Sequence (1 .. Input'Length); Tmp : String_Access; Input_Index : Positive := Input'First; Output_Index : Positive := Output'First; Res : Iconv_Result; Increment : Integer; begin while Input_Index <= Input'Last loop Iconv (State, Input, Input_Index, Output.all, Output_Index, Res); case Res is when Success => return R : constant String := Output (Output'First .. Output_Index - 1) do Free (Output); end return; when Incomplete_Multibyte_Sequence => if Ignore_Errors then Trace (Me, "Incomplete sequence"); return R : constant String := Output (Output'First .. Output_Index - 1) do Free (Output); end return; else raise Incomplete_Sequence_Error with "Incomplete sequence in '" & Input & "'"; end if; when Invalid_Multibyte_Sequence => Free (Output); if Ignore_Errors then Trace (Me, "Invalid sequence"); return R : constant String := Output (Output'First .. Output_Index - 1) do Free (Output); end return; else raise Invalid_Sequence_Error with "Invalid sequence in '" & Input & "'"; end if; when Full_Buffer => -- We might receive this because an invalid sequence was seen -- and the libiconv does not support //IGNORE. So we do not -- want to grow the string too much every time. In UTF-8, a -- character can take up to 6 bytes. if Output_Index >= Output'Last - 6 then Increment := Integer'Max (1, Input'Last - Input_Index + 1); Tmp := new String (Output'First .. Output'Last + Increment * 2); Tmp (Output'Range) := Output.all; Free (Output); Output := Tmp; end if; end case; end loop; return R : constant String := Output (Output'First .. Output_Index - 1) do Free (Output); end return; end Iconv; ----------- -- Iconv -- ----------- function Iconv (Input : Byte_Sequence; To_Code : String := UTF8; From_Code : String := Locale; Ignore_Errors : Boolean := False; Transliteration : Boolean := False; Ignore : Boolean := False) return Byte_Sequence is State : Iconv_T; begin State := Iconv_Open (To_Code => To_Code, From_Code => From_Code, Transliteration => Transliteration, Ignore => Ignore); return R : constant String := Iconv (State, Input, Ignore_Errors => Ignore_Errors) do Iconv_Close (State); end return; exception when others => Iconv_Close (State); raise; end Iconv; --------------- -- Has_Iconv -- --------------- function Has_Iconv return Boolean is begin return True; end Has_Iconv; end GNATCOLL.Iconv; gnatcoll-bindings-25.0.0/iconv/gnatcoll-iconv.ads000066400000000000000000000262571464374334300217510ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2013-2017, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ -- An interface to libiconv. -- There are multiple variants of libiconv: on some Unix systems it is part -- of the C library, whereas other systems have installed the GNU libiconv -- separately. Those variants work slightly differently. -- -- For historical reasons, international text is often encoded using a -- language or country dependent character encoding. With the advent of the -- internet and the frequent exchange of text across countries - even the -- viewing of a web page from a foreign country is a "text exchange" in this -- context -, conversions between these encodings have become important. They -- have also become a problem, because many characters which are present in -- one encoding are absent in many other encodings. To solve this mess, the -- Unicode encoding has been created. It is a super-encoding of all others and -- is therefore the default encoding for new text formats like XML. -- -- Still, many computers still operate in locale with a traditional (limited) -- character encoding. Some programs, like mailers and web browsers, must be -- able to convert between a given text encoding and the user's encoding. -- Other programs internally store strings in Unicode, to facilitate internal -- processing, and need to convert between internal string representation -- (Unicode) and external string representation (a traditional encoding) when -- they are doing I/O. Libiconv is a conversion library for both kinds of -- applications. with System; package GNATCOLL.Iconv is subtype Byte_Sequence is String; -- A sequence of bytes, as opposed to a sequence of characters. A character -- could be encoded as several bytes, depending on the charset, so -- you should use the appropriate iterators to retrieve the characters -- themselves. type Iconv_T is private; -- A conversion descriptor between two encodings. -- A conversion description cannot be used in multiple threads -- simultaneously. function Has_Iconv return Boolean; -- Whether support for iconv was compiled into GNATCOLL. -- If it returns False, all the subprograms will return their input -- unchanged. procedure Set_Locale; -- Sets the C library's notion of natural language formatting style for -- particular sets of routines. Each such style is called a `locale` and -- is invoked using an appropriate name passed as a C string. -- This procedure sets the locale argument to return hte current locale -- (the default is the "C" locale). -- This call is needed to get a working charset detection in Iconv_Open. ASCII : constant String := "ASCII"; ISO_8859_1 : constant String := "ISO-8859-1"; ISO_8859_2 : constant String := "ISO-8859-2"; ISO_8859_3 : constant String := "ISO-8859-3"; ISO_8859_4 : constant String := "ISO-8859-4"; ISO_8859_5 : constant String := "ISO-8859-5"; ISO_8859_7 : constant String := "ISO-8859-7"; ISO_8859_9 : constant String := "ISO-8859-9"; ISO_8859_10 : constant String := "ISO-8859-10"; ISO_8859_13 : constant String := "ISO-8859-13"; ISO_8859_14 : constant String := "ISO-8859-14"; ISO_8859_15 : constant String := "ISO-8859-15"; ISO_8859_16 : constant String := "ISO-8859-16"; KOI8_R : constant String := "KOI8-R"; -- Some charsets seemingly supported by most implementations of iconv, -- for European languages. SHIFT_JIS : constant String := "SHIFT-JIS"; -- Some charsets seemingly supported by most implementations of iconv, for -- Japanese characters. UTF8 : constant String := "UTF-8"; UTF16 : constant String := "UTF-16"; UTF16BE : constant String := "UTF-16BE"; UTF16LE : constant String := "UTF-16LE"; UTF32 : constant String := "UTF-32"; UTF32BE : constant String := "UTF-32BE"; UTF32LE : constant String := "UTF-32LE"; -- Some charsets seemingly supported by most implementations of iconv, -- for Unicode. Locale : constant String := ""; -- The locale charset function Iconv_Open (To_Code : String := UTF8; From_Code : String := Locale; Transliteration : Boolean := False; Ignore : Boolean := False) return Iconv_T; -- Allocate a conversion descriptor suitable for converting byte sequences -- from character encoding From_Code to character encoding To_Code. -- The values permitted for From_Code and To_Code and the supported -- combination are system dependent. -- The empty encoding name "" is equivalent to the locale dependent -- character encoding. -- -- If you are using the GNU version of libiconv and Transliteration is -- True, a character that cannot be represented in the target set might be -- approximated through one or several characters that look similar to the -- original character. For other variants of libiconv this flag has no -- effect (and an error will be raised unless Ignore is True). -- -- If Ignore is True, characters that cannot be represented in the target -- character set will be silently discarded. Support for this feature is -- built in for the GNU libiconv. In other cases, GNATCOLL will emulate it -- by having Iconv return Full_Buffer when an invalid character is found. -- -- This subprogram might raise Unsupported_Conversion. Unsupported_Conversion : exception; -- Raised when the conversion from From_Code to To_Code is not supported -- by the implementation. type Iconv_Result is (Invalid_Multibyte_Sequence, Success, Incomplete_Multibyte_Sequence, Full_Buffer); procedure Iconv (State : Iconv_T; Inbuf : Byte_Sequence; Input_Index : in out Positive; Outbuf : in out Byte_Sequence; Output_Index : in out Positive; Result : out Iconv_Result); -- Converts the multibyte sequence starting at Inbuf(Input_Index) into a -- multibyte sequence starting at Outbuf(Output_Index). This procedure -- will not try to write past the end of Outbuf. -- -- This function converts of multibyte character at a time, and for each -- character conversion it increments the indexes as needed. It also -- updates the conversion state in State (for those cases where the -- conversion is stateful, this procedure might read a number of input -- characters without producing output bytes -- such input is called a -- shift sequence). -- -- On exit, Result is set to one of: -- * Invalid_Multibyte_Sequence: Input_Index is left pointing to the -- beginning of the invalid sequence. This error is not returned if -- State was opened with the Ignore flag set to True. -- * Success: the input sequence has been entirely converted. -- * Incomplete_Multibyte_Sequence: an incomplete sequence is -- encountered and the input terminates after it. Input_Index is left -- pointing to the beginning of the incomplete sequence. -- * Full_Buffer: the output buffer has no more room for the next -- converted character. -- -- The part that has been converted is available in -- Outbuf (Outbuf'First .. Output_Index - 1) procedure Reset (State : Iconv_T); -- Resets the conversion state to the initial state procedure Reset (State : Iconv_T; Outbuf : in out Byte_Sequence; Output_Index : in out Positive; Result : out Iconv_Result); -- Attempts to reset the conversion state to the initial state, and store -- a corresponding shift sequence in Outbuf(Output_Index..). -- The result might be one of Success or Full_Buffer. procedure Iconv_Close (State : Iconv_T); -- Close the context and free the memory function Iconv (State : Iconv_T; Input : Byte_Sequence; Ignore_Errors : Boolean := False) return Byte_Sequence; -- Converts Input. -- This function is a convenience for the Iconv procedure, but gives less -- control, and for big strings will require more memory. As opposed to -- the procedure, it raises exceptions in case of error (either -- Invalid_Sequence_Error or Incomplete_Sequence_Error). -- If Ignore_Errors is true, no exception will be raised, and the part of -- the input string that could be converted will be returned. Invalid_Sequence_Error : exception; Incomplete_Sequence_Error : exception; function Iconv (Input : Byte_Sequence; To_Code : String := UTF8; From_Code : String := Locale; Ignore_Errors : Boolean := False; Transliteration : Boolean := False; Ignore : Boolean := False) return Byte_Sequence; -- A convenience function that wraps all the above (open, iconv, close) -- Might raise Unsupported_Conversion, Invalid_Sequence_Error or -- Incomplete_Sequence_Error. -- Ignore means that characters that do not exist in To_Code are simply -- discarded. -- If Ignore_Errors is true, no exception will be raised, and the part of -- the input string that could be converted will be returned. private type Iconv_T is record T : System.Address := System.Null_Address; -- Underlying C iconv_t value. Null_Address denotes an uninitialized -- state. Emulate_Ignore : Boolean := False; -- Whether we should emulate the IGNORE flag of the GNU libiconv. This -- means that Iconv will never return Invalid_Multibyte_Sequence. end record; pragma Import (C, Set_Locale, "gnatcoll_iconv_set_locale"); end GNATCOLL.Iconv; gnatcoll-bindings-25.0.0/iconv/gnatcoll_iconv.gpr000066400000000000000000000100651464374334300220420ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2015-2020, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with "gnatcoll_core"; library project GnatColl_Iconv is Version := External ("GNATCOLL_VERSION", "0.0"); Name := "gnatcoll_iconv"; type Build_Type is ("DEBUG", "PROD"); Build : Build_Type := External ("GNATCOLL_BUILD_MODE", External ("BUILD", "PROD")); type Library_Type_Type is ("relocatable", "static", "static-pic"); Library_Type : Library_Type_Type := External ("LIBRARY_TYPE", "static"); for Source_Dirs use ("."); for Library_Kind use Library_Type; for Object_Dir use "obj/" & Project'Library_Kind; for Library_Dir use "lib/" & Project'Library_Kind; for Library_Name use Name; for Languages use ("Ada", "C"); Iconv_Opt := External ("GNATCOLL_ICONV_OPT", "-liconv"); case Library_Type is when "relocatable" => for Leading_Library_Options use External_As_List ("LDFLAGS", " "); for Library_Options use (Iconv_Opt); for Library_Version use "lib" & Name & Gnatcoll_Core.So_Ext & "." & Version; when others => null; end case; package Compiler is case Build is when "DEBUG" => for Switches ("Ada") use ("-g", "-O0", "-gnata", "-gnatVa", "-gnatQ", "-gnaty", "-gnateE", "-gnatwaCJe", "-fstack-check"); for Switches ("C") use ("-g", "-Wunreachable-code"); when "PROD" => -- Do not use -gnatwe for production mode for Switches ("Ada") use ("-O2", "-gnatn", "-gnatwaCJ"); for Switches ("C") use ("-O2", "-Wunreachable-code"); end case; for Switches ("Ada") use Compiler'Switches ("Ada") & External_As_List ("ADAFLAGS", " "); for Switches ("C") use Compiler'Switches ("C") & External_As_List ("CFLAGS", " ") & External_As_List ("CPPFLAGS", " "); end Compiler; package Binder is case Build is when "DEBUG" => for Switches ("Ada") use ("-E"); when "PROD" => null; end case; end Binder; package Builder is case Build is when "DEBUG" => for Global_Configuration_Pragmas use "../gnat_debug.adc"; when "PROD" => null; end case; end Builder; package Ide is for VCS_Kind use "Git"; end Ide; package Linker is for Linker_Options use (Iconv_Opt); end Linker; end GnatColl_Iconv; gnatcoll-bindings-25.0.0/iconv/iconv_support.c000066400000000000000000000016601464374334300214060ustar00rootroot00000000000000/* * Iconv binding support * Copyright (C) 2012-2017, AdaCore */ #include #include #include const int gnatcoll_errno_einval = EINVAL; const int gnatcoll_errno_e2big = E2BIG; const int gnatcoll_errno_eilseq = EILSEQ; void gnatcoll_iconv_set_locale(){ setlocale (LC_ALL, ""); } void *gnatcoll_iconv_open(char *tocode, char *fromcode){ iconv_t res = iconv_open(tocode, fromcode); return (res == (iconv_t) -1) ? NULL : res; } int gnatcoll_iconv_close(iconv_t cd) { // iconv_close might be a macro return iconv_close (cd); } #if _LIBICONV_VERSION >= 0x010D size_t gnatcoll_iconv (iconv_t cd, char** inbuf, size_t *inbytesleft, char** outbuf, size_t *outbytesleft) #else size_t gnatcoll_iconv (iconv_t cd, char** inbuf, size_t *inbytesleft, char** outbuf, size_t *outbytesleft) #endif { // iconv might be a macro return iconv(cd, inbuf, inbytesleft, outbuf, outbytesleft); } gnatcoll-bindings-25.0.0/iconv/setup.py000077500000000000000000000053161464374334300200470ustar00rootroot00000000000000#!/usr/bin/env python import logging import os import sys sys.path.append(os.path.dirname(os.path.dirname(os.path.abspath(__file__)))) from setup_support import SetupApp class GNATCollIconv(SetupApp): name = 'gnatcoll_iconv' project = 'gnatcoll_iconv.gpr' description = 'GNATColl Iconv bindings' def create(self): super(GNATCollIconv, self).create() self.build_cmd.add_argument( '--debug', help='build project in debug mode', action="store_true", default=False) self.build_cmd.add_argument( '--force-libiconv', help='if set force use of libiconv. By default on linux system ' 'we rely on libc rather than libiconv', action="store_true", default=False) def update_config(self, config, args): logging.info('%-26s %s', 'Libraries kind', ", ".join(config.data['library_types'])) # Set library version with open(os.path.join(config.source_dir, '..', 'version_information'), 'r') as fd: version = fd.read().strip() config.set_data('GNATCOLL_VERSION', version, sub='gprbuild') # Set build mode config.set_data('BUILD', 'DEBUG' if args.debug else 'PROD', sub='gprbuild') logging.info('%-26s %s', 'Build mode', config.data['gprbuild']['BUILD']) # Set GNATCOLL_OS if 'darwin' in config.data['canonical_target']: gnatcoll_os = 'osx' elif 'windows' in config.data['canonical_target']: gnatcoll_os = 'windows' else: # Assume this is an Unix system gnatcoll_os = 'unix' config.set_data('GNATCOLL_OS', gnatcoll_os, sub='gprbuild') # Set GNATCOLL_ICONV_OPT if 'linux' in config.data['canonical_target'] and \ not args.force_libiconv: config.set_data('GNATCOLL_ICONV_OPT', '', sub='gprbuild') else: config.set_data('GNATCOLL_ICONV_OPT', '-liconv', sub='gprbuild') def variants(self, config, cmd): result = [] for library_type in config.data['library_types']: gpr_vars = {'LIBRARY_TYPE': library_type, 'XMLADA_BUILD': library_type, 'GPR_BUILD': library_type} if cmd == 'install': result.append((['--build-name=%s' % library_type, '--build-var=LIBRARY_TYPE'], gpr_vars)) else: result.append(([], gpr_vars)) return result if __name__ == '__main__': app = GNATCollIconv() sys.exit(app.run()) gnatcoll-bindings-25.0.0/lzma/000077500000000000000000000000001464374334300161525ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/lzma/gnatcoll-coders-lzma-thin.ads000066400000000000000000000727671464374334300236470ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2019, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package provides thin binding to LZMA compression/decompression with Interfaces.C; use Interfaces; with System; package GNATCOLL.Coders.LZMA.Thin is type lzma_allocator is record alloc : access function (opaque : System.Address; nmemb : C.size_t; size : C.size_t) return System.Address; free : access procedure (opaque : System.Address; ptr : System.Address); opaque : System.Address; end record with Convention => C; -- alloc is a pointer to a custom memory allocation function -- -- If you don't want a custom allocator, but still want -- custom free(), set this to NULL and liblzma will use -- the standard malloc(). -- -- \param opaque lzma_allocator.opaque (see below) -- \param nmemb Number of elements like in calloc(). liblzma -- will always set nmemb to 1, so it is safe to -- ignore nmemb in a custom allocator if you like. -- The nmemb argument exists only for -- compatibility with zlib and libbzip2. -- \param size Size of an element in bytes. -- liblzma never sets this to zero. -- -- \return Pointer to the beginning of a memory block of -- `size' bytes, or NULL if allocation fails -- for some reason. When allocation fails, functions -- of liblzma return LZMA_MEM_ERROR. -- -- The allocator should not waste time zeroing the allocated buffers. -- This is not only about speed, but also memory usage, since the -- operating system kernel doesn't necessarily allocate the requested -- memory in physical memory until it is actually used. With small -- input files, liblzma may actually need only a fraction of the -- memory that it requested for allocation. -- -- \note LZMA_MEM_ERROR is also used when the size of the -- allocation would be greater than SIZE_MAX. Thus, -- don't assume that the custom allocator must have -- returned NULL if some function from liblzma -- returns LZMA_MEM_ERROR. type lzma_stream is record next_in : access Stream_Element := null; avail_in : aliased C.size_t := 0; total_in : aliased Unsigned_64 := 0; next_out : access Stream_Element := null; avail_out : aliased C.size_t := 0; total_out : aliased Unsigned_64 := 0; allocator : access constant lzma_allocator := null; internal : System.Address := System.Null_Address; reserved_ptr1 : System.Address := System.Null_Address; reserved_ptr2 : System.Address := System.Null_Address; reserved_ptr3 : System.Address := System.Null_Address; reserved_ptr4 : System.Address := System.Null_Address; reserved_int1 : aliased Unsigned_64 := 0; reserved_int2 : aliased Unsigned_64 := 0; reserved_int3 : aliased C.size_t := 0; reserved_int4 : aliased C.size_t := 0; reserved_enum1 : aliased C.int := 0; reserved_enum2 : aliased C.int := 0; end record with Convention => C; -- Passing data to and from liblzma -- -- The lzma_stream structure is used for -- - passing pointers to input and output buffers to liblzma; -- - defining custom memory hander functions; and -- - holding a pointer to coder-specific internal data structures. -- -- Typical usage: -- -- - After allocating lzma_stream (on stack or with malloc()), it must be -- initialized to LZMA_STREAM_INIT (see LZMA_STREAM_INIT for details). -- -- - Initialize a coder to the lzma_stream, for example by using -- lzma_easy_encoder() or lzma_auto_decoder(). Some notes: -- - In contrast to zlib, strm->next_in and strm->next_out are -- ignored by all initialization functions, thus it is safe -- to not initialize them yet. -- - The initialization functions always set strm->total_in and -- strm->total_out to zero. -- - If the initialization function fails, no memory is left allocated -- that would require freeing with lzma_end() even if some memory was -- associated with the lzma_stream structure when the initialization -- function was called. -- -- - Use lzma_code() to do the actual work. -- -- - Once the coding has been finished, the existing lzma_stream can be -- reused. It is OK to reuse lzma_stream with different initialization -- function without calling lzma_end() first. Old allocations are -- automatically freed. -- -- - Finally, use lzma_end() to free the allocated memory. lzma_end() -- never frees the lzma_stream structure itself. -- -- Application may modify the values of total_in and total_out as it wants. -- They are updated by liblzma to match the amount of data read and -- written but aren't used for anything else except as a possible return -- values from lzma_get_progress(). subtype lzma_check is C.unsigned; -- Type of the integrity check (Check ID) -- -- The .xz format supports multiple types of checks that are calculated -- from the uncompressed data. They vary in both speed and ability to -- detect errors. LZMA_CHECK_NONE : constant lzma_check := 0; -- No Check is calculated. -- Size of the Check field: 0 bytes LZMA_CHECK_CRC32 : constant lzma_check := 1; -- CRC32 using the polynomial from the IEEE 802.3 standard -- Size of the Check field: 4 bytes LZMA_CHECK_CRC64 : constant lzma_check := 4; -- CRC64 using the polynomial from the ECMA-182 standard -- Size of the Check field: 8 bytes LZMA_CHECK_SHA256 : constant lzma_check := 10; -- SHA-256 -- Size of the Check field: 32 bytes type lzma_ret is (LZMA_OK, -- Operation completed successfully -- LZMA_STREAM_END, -- End of stream was reached -- -- In encoder, LZMA_SYNC_FLUSH, LZMA_FULL_FLUSH, or -- LZMA_FINISH was finished. In decoder, this indicates -- that all the data was successfully decoded. -- -- In all cases, when LZMA_STREAM_END is returned, the last -- output bytes should be picked from strm->next_out. -- LZMA_NO_CHECK, -- Input stream has no integrity check -- -- This return value can be returned only if the -- LZMA_TELL_NO_CHECK flag was used when initializing -- the decoder. LZMA_NO_CHECK is just a warning, and -- the decoding can be continued normally. -- -- It is possible to call lzma_get_check() immediately after -- lzma_code has returned LZMA_NO_CHECK. The result will -- naturally be LZMA_CHECK_NONE, but the possibility to call -- lzma_get_check() may be convenient in some applications. -- LZMA_UNSUPPORTED_CHECK, -- Cannot calculate the integrity check -- -- The usage of this return value is different in encoders -- and decoders. -- -- Encoders can return this value only from the initialization -- function. If initialization fails with this value, the -- encoding cannot be done, because there's no way to produce -- output with the correct integrity check. -- -- Decoders can return this value only from lzma_code() and -- only if the LZMA_TELL_UNSUPPORTED_CHECK flag was used when -- initializing the decoder. The decoding can still be -- continued normally even if the check type is unsupported, -- but naturally the check will not be validated, and possible -- errors may go undetected. -- -- With decoder, it is possible to call lzma_get_check() -- immediately after lzma_code() has returned -- LZMA_UNSUPPORTED_CHECK. This way it is possible to find -- out what the unsupported Check ID was. LZMA_GET_CHECK, -- Integrity check type is now available -- -- This value can be returned only by the lzma_code() function -- and only if the decoder was initialized with the -- LZMA_TELL_ANY_CHECK flag. LZMA_GET_CHECK tells the -- application that it may now call lzma_get_check() to find -- out the Check ID. This can be used, for example, to -- implement a decoder that accepts only files that have -- strong enough integrity check. LZMA_MEM_ERROR, -- Cannot allocate memory -- -- Memory allocation failed, or the size of the allocation -- would be greater than SIZE_MAX. -- -- Due to internal implementation reasons, the coding cannot -- be continued even if more memory were made available after -- LZMA_MEM_ERROR. LZMA_MEMLIMIT_ERROR, -- Memory usage limit was reached -- -- Decoder would need more memory than allowed by the -- specified memory usage limit. To continue decoding, -- the memory usage limit has to be increased with -- lzma_memlimit_set(). LZMA_FORMAT_ERROR, -- File format not recognized -- -- The decoder did not recognize the input as supported file -- format. This error can occur, for example, when trying to -- decode .lzma format file with lzma_stream_decoder, -- because lzma_stream_decoder accepts only the .xz format. LZMA_OPTIONS_ERROR, -- Invalid or unsupported options -- -- Invalid or unsupported options, for example -- - unsupported filter(s) or filter options; or -- - reserved bits set in headers (decoder only). -- -- Rebuilding liblzma with more features enabled, or -- upgrading to a newer version of liblzma may help. LZMA_DATA_ERROR, -- Data is corrupt -- -- The usage of this return value is different in encoders -- and decoders. In both encoder and decoder, the coding -- cannot continue after this error. -- -- Encoders return this if size limits of the target file -- format would be exceeded. These limits are huge, thus -- getting this error from an encoder is mostly theoretical. -- For example, the maximum compressed and uncompressed -- size of a .xz Stream is roughly 8 EiB (2^63 bytes). -- -- Decoders return this error if the input data is corrupt. -- This can mean, for example, invalid CRC32 in headers -- or invalid check of uncompressed data. LZMA_BUF_ERROR, -- No progress is possible -- -- This error code is returned when the coder cannot consume -- any new input and produce any new output. The most common -- reason for this error is that the input stream being -- decoded is truncated or corrupt. -- -- This error is not fatal. Coding can be continued normally -- by providing more input and/or more output space, if -- possible. -- -- Typically the first call to lzma_code() that can do no -- progress returns LZMA_OK instead of LZMA_BUF_ERROR. Only -- the second consecutive call doing no progress will return -- LZMA_BUF_ERROR. This is intentional. -- -- With zlib, Z_BUF_ERROR may be returned even if the -- application is doing nothing wrong, so apps will need -- to handle Z_BUF_ERROR specially. The above hack -- guarantees that liblzma never returns LZMA_BUF_ERROR -- to properly written applications unless the input file -- is truncated or corrupt. This should simplify the -- applications a little. LZMA_PROG_ERROR -- Programming error -- -- This indicates that the arguments given to the function are -- invalid or the internal state of the decoder is corrupt. -- - Function arguments are invalid or the structures -- pointed by the argument pointers are invalid -- e.g. if strm->next_out has been set to NULL and -- strm->avail_out > 0 when calling lzma_code(). -- - lzma_* functions have been called in wrong order -- e.g. lzma_code() was called right after lzma_end(). -- - If errors occur randomly, the reason might be flaky -- hardware. -- -- If you think that your code is correct, this error code -- can be a sign of a bug in liblzma. See the documentation -- how to report bugs. ) with Convention => C; -- Return values used by several functions in liblzma -- -- Check the descriptions of specific functions to find out which return -- values they can return. With some functions the return values may have -- more specific meanings than described here; those differences are -- described per-function basis. LZMA_PRESET_EXTREME : constant := 2 ** 31; -- Extreme compression preset -- -- This flag modifies the preset to make the encoding significantly slower -- while improving the compression ratio only marginally. This is useful -- when you don't mind wasting time to get as small result as possible. -- -- This flag doesn't affect the memory usage requirements of the decoder -- (at least not significantly). The memory usage of the encoder may be -- increased a little but only at the lowest preset levels (0-3). function lzma_easy_encoder (strm : access lzma_stream; preset : Unsigned_32; check : lzma_check) return lzma_ret with Import, Convention => C, External_Name => "lzma_easy_encoder"; -- Initialize .xz Stream encoder using a preset number -- -- This function is intended for those who just want to use the basic -- features if liblzma (that is, most developers out there). -- -- \param strm Pointer to lzma_stream that is at least initialized -- with LZMA_STREAM_INIT. -- \param preset Compression preset to use. A preset consist of level -- number and zero or more flags. Usually flags aren't -- used, so preset is simply a number [0, 9] which match -- the options -0 ... -9 of the xz command line tool. -- Additional flags can be be set using bitwise-or with -- the preset level number, e.g. 6 | LZMA_PRESET_EXTREME. -- \param check Integrity check type to use. See check.h for available -- checks. The xz command line tool defaults to -- LZMA_CHECK_CRC64, which is a good choice if you are -- unsure. LZMA_CHECK_CRC32 is good too as long as the -- uncompressed file is not many gigabytes. -- -- \return - LZMA_OK: Initialization succeeded. Use lzma_code() to -- encode your data. -- - LZMA_MEM_ERROR: Memory allocation failed. -- - LZMA_OPTIONS_ERROR: The given compression preset is not -- supported by this build of liblzma. -- - LZMA_UNSUPPORTED_CHECK: The given check type is not -- supported by this liblzma build. -- - LZMA_PROG_ERROR: One or more of the parameters have values -- that will never be valid. For example, strm == NULL. -- -- If initialization fails (return value is not LZMA_OK), all the memory -- allocated for *strm by liblzma is always freed. Thus, there is no need -- to call lzma_end() after failed initialization. -- -- If initialization succeeds, use lzma_code() to do the actual encoding. -- Valid values for `action' (the second argument of lzma_code()) are -- LZMA_RUN, LZMA_SYNC_FLUSH, LZMA_FULL_FLUSH, and LZMA_FINISH. In future, -- there may be compression levels or flags that don't support -- LZMA_SYNC_FLUSH. type lzma_filter is null record; -- Not supported in this bind version ---------------------------- -- Multithreading options -- ---------------------------- type lzma_mt is record flags : Unsigned_32 := 0; -- No flags are currently supported. threads : Unsigned_32 := 0; -- Number of worker threads to use block_size : Unsigned_64 := 0; -- Maximum uncompressed size of a Block. -- The encoder will start a new .xz Block every block_size bytes. -- Using LZMA_FULL_FLUSH or LZMA_FULL_BARRIER with lzma_code() -- the caller may tell liblzma to start a new Block earlier. -- With LZMA2, a recommended block size is 2-4 times the LZMA2 -- dictionary size. With very small dictionaries, it is recommended -- to use at least 1 MiB block size for good compression ratio, even -- if this is more than four times the dictionary size. Note that -- these are only recommendations for typical use cases; feel free -- to use other values. Just keep in mind that using a block size -- less than the LZMA2 dictionary size is waste of RAM. -- Set this to 0 to let liblzma choose the block size depending -- on the compression options. For LZMA2 it will be 3*dict_size -- or 1 MiB, whichever is more. -- For each thread, about 3 * block_size bytes of memory will be -- allocated. This may change in later liblzma versions. If so, -- the memory usage will probably be reduced, not increased. timeout : Unsigned_32 := 0; -- Timeout to allow lzma_code() to return early -- Multithreading can make liblzma to consume input and produce -- output in a very bursty way: it may first read a lot of input -- to fill internal buffers, then no input or output occurs for -- a while. -- In single-threaded mode, lzma_code() won't return until it has -- either consumed all the input or filled the output buffer. If -- this is done in multithreaded mode, it may cause a call -- lzma_code() to take even tens of seconds, which isn't acceptable -- in all applications. -- To avoid very long blocking times in lzma_code(), a timeout -- (in milliseconds) may be set here. If lzma_code() would block -- longer than this number of milliseconds, it will return with -- LZMA_OK. Reasonable values are 100 ms or more. The xz command -- line tool uses 300 ms. -- If long blocking times are fine for you, set timeout to a special -- value of 0, which will disable the timeout mechanism and will make -- lzma_code() block until all the input is consumed or the output -- buffer has been filled. -- Even with a timeout, lzma_code() might sometimes take -- somewhat long time to return. No timing guarantees -- are made. preset : Unsigned_32 := 0; -- Compression preset (level and possible flags) -- The preset is set just like with lzma_easy_encoder(). -- The preset is ignored if filters below is non-NULL. filters : access constant lzma_filter; -- Filter chain (alternative to a preset) -- If this is NULL, the preset above is used. Otherwise the preset -- is ignored and the filter chain specified here is used. check : lzma_check := 0; -- Integrity check type -- See check.h for available checks. The xz command line tool -- defaults to LZMA_CHECK_CRC64, which is a good choice if you -- are unsure. reserved_enum1 : C.int := 0; reserved_enum2 : C.int := 0; reserved_enum3 : C.int := 0; reserved_int1 : Unsigned_32 := 0; reserved_int2 : Unsigned_32 := 0; reserved_int3 : Unsigned_32 := 0; reserved_int4 : Unsigned_32 := 0; reserved_int5 : Unsigned_64 := 0; reserved_int6 : Unsigned_64 := 0; reserved_int7 : Unsigned_64 := 0; reserved_int8 : Unsigned_64 := 0; reserved_ptr1 : System.Address := System.Null_Address; reserved_ptr2 : System.Address := System.Null_Address; reserved_ptr3 : System.Address := System.Null_Address; reserved_ptr4 : System.Address := System.Null_Address; -- Reserved space to allow possible future extensions without -- breaking the ABI. You should not touch these, because the names -- of these variables may change. These are and will never be used -- with the currently supported options, so it is safe to leave these -- uninitialized. end record with Convention => C; function lzma_stream_encoder_mt (strm : access lzma_stream; options : access constant lzma_mt) return lzma_ret with Import, Convention => C, External_Name => "lzma_stream_encoder_mt"; -- Initialize multithreaded .xz Stream encoder -- -- This provides the functionality of lzma_easy_encoder() and -- lzma_stream_encoder() as a single function for multithreaded use. -- -- The supported actions for lzma_code() are LZMA_RUN, LZMA_FULL_FLUSH, -- LZMA_FULL_BARRIER, and LZMA_FINISH. Support for LZMA_SYNC_FLUSH might be -- added in the future. -- -- strm Pointer to properly prepared lzma_stream -- options Pointer to multithreaded compression options -- -- Returns - LZMA_OK -- - LZMA_MEM_ERROR -- - LZMA_UNSUPPORTED_CHECK -- - LZMA_OPTIONS_ERROR -- - LZMA_PROG_ERROR function lzma_auto_decoder (strm : access lzma_stream; memlimit : Unsigned_64; flags : Unsigned_32) return lzma_ret with Import, Convention => C, External_Name => "lzma_auto_decoder"; -- Decode .xz Streams and .lzma files with autodetection -- -- This decoder autodetects between the .xz and .lzma file formats, and -- calls lzma_stream_decoder() or lzma_alone_decoder() once the type -- of the input file has been detected. -- -- \param strm Pointer to properly prepared lzma_stream -- \param memlimit Memory usage limit as bytes. Use UINT64_MAX -- to effectively disable the limiter. -- \param flags Bitwise-or of flags, or zero for no flags. -- -- \return - LZMA_OK: Initialization was successful. -- - LZMA_MEM_ERROR: Cannot allocate memory. -- - LZMA_OPTIONS_ERROR: Unsupported flags -- - LZMA_PROG_ERROR subtype lzma_action is C.unsigned; -- The `action' argument for lzma_code() -- -- After the first use of LZMA_SYNC_FLUSH, LZMA_FULL_FLUSH, -- LZMA_FULL_BARRIER, or LZMA_FINISH, the same `action' must is used until -- lzma_code() returns LZMA_STREAM_END. Also, the amount of input (that is, -- strm->avail_in) must not be modified by the application until -- lzma_code() returns LZMA_STREAM_END. Changing the `action' or modifying -- the amount of input will make lzma_code() return LZMA_PROG_ERROR. LZMA_RUN : constant lzma_action := 0; -- Continue coding -- -- Encoder: Encode as much input as possible. Some internal -- buffering will probably be done (depends on the filter -- chain in use), which causes latency: the input used won't -- usually be decodeable from the output of the same -- lzma_code() call. -- -- Decoder: Decode as much input as possible and produce as -- much output as possible. LZMA_SYNC_FLUSH : constant lzma_action := 1; -- Make all the input available at output -- -- Normally the encoder introduces some latency. -- LZMA_SYNC_FLUSH forces all the buffered data to be -- available at output without resetting the internal -- state of the encoder. This way it is possible to use -- compressed stream for example for communication over -- network. -- -- Only some filters support LZMA_SYNC_FLUSH. Trying to use -- LZMA_SYNC_FLUSH with filters that don't support it will -- make lzma_code() return LZMA_OPTIONS_ERROR. For example, -- LZMA1 doesn't support LZMA_SYNC_FLUSH but LZMA2 does. -- -- Using LZMA_SYNC_FLUSH very often can dramatically reduce -- the compression ratio. With some filters (for example, -- LZMA2), fine-tuning the compression options may help -- mitigate this problem significantly (for example, -- match finder with LZMA2). -- -- Decoders don't support LZMA_SYNC_FLUSH. LZMA_FULL_FLUSH : constant lzma_action := 2; -- Finish encoding of the current Block -- -- All the input data going to the current Block must have -- been given to the encoder (the last bytes can still be -- pending in *next_in). Call lzma_code() with LZMA_FULL_FLUSH -- until it returns LZMA_STREAM_END. Then continue normally -- with LZMA_RUN or finish the Stream with LZMA_FINISH. -- -- This action is currently supported only by Stream encoder -- and easy encoder (which uses Stream encoder). If there is -- no unfinished Block, no empty Block is created. LZMA_FULL_BARRIER : constant lzma_action := 4; -- Finish encoding of the current Block -- -- This is like LZMA_FULL_FLUSH except that this doesn't -- necessarily wait until all the input has been made -- available via the output buffer. That is, lzma_code() -- might return LZMA_STREAM_END as soon as all the input -- has been consumed (avail_in == 0). -- -- LZMA_FULL_BARRIER is useful with a threaded encoder if -- one wants to split the .xz Stream into Blocks at specific -- offsets but doesn't care if the output isn't flushed -- immediately. Using LZMA_FULL_BARRIER allows keeping -- the threads busy while LZMA_FULL_FLUSH would make -- lzma_code() wait until all the threads have finished -- until more data could be passed to the encoder. -- -- With a lzma_stream initialized with the single-threaded -- lzma_stream_encoder() or lzma_easy_encoder(), -- LZMA_FULL_BARRIER is an alias for LZMA_FULL_FLUSH. LZMA_FINISH : constant lzma_action := 3; -- /usr/include/lzma/base.h:345 -- Finish the coding operation -- -- All the input data must have been given to the encoder -- (the last bytes can still be pending in next_in). -- Call lzma_code() with LZMA_FINISH until it returns -- LZMA_STREAM_END. Once LZMA_FINISH has been used, -- the amount of input must no longer be changed by -- the application. -- -- When decoding, using LZMA_FINISH is optional unless the -- LZMA_CONCATENATED flag was used when the decoder was -- initialized. When LZMA_CONCATENATED was not used, the only -- effect of LZMA_FINISH is that the amount of input must not -- be changed just like in the encoder. function lzma_code (strm : access lzma_stream; action : lzma_action) return lzma_ret with Import, Convention => C, External_Name => "lzma_code"; -- Encode or decode data -- -- Once the lzma_stream has been successfully initialized (e.g. with -- lzma_stream_encoder()), the actual encoding or decoding is done -- using this function. The application has to update strm->next_in, -- strm->avail_in, strm->next_out, and strm->avail_out to pass input -- to and get output from liblzma. -- -- See the description of the coder-specific initialization function to find -- out what `action' values are supported by the coder. procedure lzma_end (strm : access lzma_stream) with Import, Convention => C, External_Name => "lzma_end"; -- Free memory allocated for the coder data structures -- -- \param strm Pointer to lzma_stream that is at least initialized -- with LZMA_STREAM_INIT. -- -- After lzma_end(strm), strm->internal is guaranteed to be NULL. No other -- members of the lzma_stream structure are touched. -- -- \note zlib indicates an error if application end()s unfinished -- stream structure. liblzma doesn't do this, and assumes that -- application knows what it is doing. end GNATCOLL.Coders.LZMA.Thin; gnatcoll-bindings-25.0.0/lzma/gnatcoll-coders-lzma.adb000066400000000000000000000160601464374334300226460ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2019, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with Interfaces; use Interfaces; with GNATCOLL.Coders.LZMA.Thin; use GNATCOLL.Coders.LZMA.Thin; package body GNATCOLL.Coders.LZMA is Zero_LZMA_Stream : constant Thin.lzma_stream := (others => <>); -- All zero fields to cleanup durty others. No need to set zeroes here -- because record declared with zero defaults already. Check_To_C : constant array (Check_Type) of lzma_check := (Check_None => LZMA_CHECK_NONE, Check_CRC32 => LZMA_CHECK_CRC32, Check_CRC64 => LZMA_CHECK_CRC64, Check_SHA256 => LZMA_CHECK_SHA256); Flush_To_C : constant array (Flush_Mode) of lzma_action := (No_Flush => LZMA_RUN, Sync_Flush => LZMA_SYNC_FLUSH, Full_Flush => LZMA_FULL_FLUSH, Finish => LZMA_FINISH); procedure Check_Error (Code : lzma_ret); -- Check return code and raise exception on error procedure Cleanup (Coder : in out Coder_Type); -- Cleanup internal coding structures to use it with new data processing ----------------- -- Check_Error -- ----------------- procedure Check_Error (Code : lzma_ret) is begin if Code /= LZMA_OK then raise LZMA_Error with lzma_ret'Image (Code); end if; end Check_Error; ------------- -- Cleanup -- ------------- procedure Cleanup (Coder : in out Coder_Type) is begin Coder.Finished := False; if Coder.Stream = null then Coder.Stream := new lzma_stream; else lzma_end (Coder.Stream); Coder.Stream.all := Zero_LZMA_Stream; end if; end Cleanup; ------------------ -- Easy_Encoder -- ------------------ procedure Encoder (Coder : in out Coder_Type; Preset : Preset_Type := 6; Extreme : Boolean := False; Threads : Positive := 1; Timeout : Duration := 0.0; Check : Check_Type := Check_CRC64) is MT_Opts : aliased lzma_mt; begin Coder.Cleanup; MT_Opts.check := Check_To_C (Check); MT_Opts.preset := Unsigned_32 (Preset) or (if Extreme then LZMA_PRESET_EXTREME else 0); if Threads = 1 then Check_Error (lzma_easy_encoder (Coder.Stream, MT_Opts.preset, MT_Opts.check)); else MT_Opts.threads := Unsigned_32 (Threads); MT_Opts.timeout := Unsigned_32 (Timeout * 1000); if MT_Opts.timeout = 0 and then Timeout > 0.0 then -- Because 0 timeout mean no timeout limit MT_Opts.timeout := 1; end if; Check_Error (lzma_stream_encoder_mt (Coder.Stream, MT_Opts'Access)); end if; end Encoder; ------------------ -- Auto_Decoder -- ------------------ procedure Auto_Decoder (Coder : in out Coder_Type) is begin Coder.Cleanup; Check_Error (lzma_auto_decoder (Coder.Stream, Unsigned_64'Last, 0)); end Auto_Decoder; ------------- -- Is_Open -- ------------- overriding function Is_Open (Coder : Coder_Type) return Boolean is begin return Coder.Stream /= null; end Is_Open; --------------- -- Transcode -- --------------- procedure Transcode (Coder : in out Coder_Type; In_Data : Stream_Element_Array; In_Last : out Stream_Element_Offset; Out_Data : out Stream_Element_Array; Out_Last : out Stream_Element_Offset; Flush : Flush_Mode := No_Flush) is Code : lzma_ret; begin Coder.Stream.next_in := (if In_Data'Length = 0 then null else In_Data (In_Data'First)'Unrestricted_Access); Coder.Stream.next_out := (if Out_Data'Length = 0 then null else Out_Data (Out_Data'First)'Unrestricted_Access); Coder.Stream.avail_in := In_Data'Length; Coder.Stream.avail_out := Out_Data'Length; Code := lzma_code (Coder.Stream, Flush_To_C (Flush)); if Code = LZMA_STREAM_END then Coder.Finished := True; else Check_Error (Code); end if; In_Last := In_Data'Last - Stream_Element_Offset (Coder.Stream.avail_in); Out_Last := Out_Data'Last - Stream_Element_Offset (Coder.Stream.avail_out); end Transcode; -------------- -- Total_In -- -------------- overriding function Total_In (Coder : Coder_Type) return Stream_Element_Count is begin return Stream_Element_Count (Coder.Stream.total_in); end Total_In; --------------- -- Total_Out -- --------------- overriding function Total_Out (Coder : Coder_Type) return Stream_Element_Count is begin return Stream_Element_Count (Coder.Stream.total_out); end Total_Out; -------------- -- Finished -- -------------- function Finished (Coder : Coder_Type) return Boolean is begin return Coder.Finished; end Finished; ----------- -- Close -- ----------- overriding procedure Close (Coder : in out Coder_Type) is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Thin.lzma_stream, LZMA_Stream_Access); begin if Coder.Stream /= null then Thin.lzma_end (Coder.Stream); Unchecked_Free (Coder.Stream); end if; end Close; -------------- -- Finalize -- -------------- overriding procedure Finalize (Coder : in out Coder_Type) is begin Close (Coder); end Finalize; end GNATCOLL.Coders.LZMA; gnatcoll-bindings-25.0.0/lzma/gnatcoll-coders-lzma.ads000066400000000000000000000151401464374334300226650ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2019, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package provides binding to LZMA compression/decompression with Ada.Finalization; limited with GNATCOLL.Coders.LZMA.Thin; package GNATCOLL.Coders.LZMA is type Coder_Type is new Ada.Finalization.Limited_Controlled and Coder_Interface with private; type Preset_Type is new Integer range 0 .. 9; type Check_Type is (Check_None, -- No Check is calculated. -- Size of the Check field: 0 bytes Check_CRC32, -- CRC32 using the polynomial from the IEEE 802.3 standard -- Size of the Check field: 4 bytes Check_CRC64, -- CRC64 using the polynomial from the ECMA-182 standard -- Size of the Check field: 8 bytes Check_SHA256 -- SHA-256 -- Size of the Check field: 32 bytes ); -- Type of the integrity check (Check ID) -- -- The .xz format supports multiple types of checks that are calculated -- from the uncompressed data. They vary in both speed and ability to -- detect errors. procedure Encoder (Coder : in out Coder_Type; Preset : Preset_Type := 6; Extreme : Boolean := False; Threads : Positive := 1; Timeout : Duration := 0.0; Check : Check_Type := Check_CRC64); -- Initializes compression coder. -- Preset is compression level from 0 to 9 roughly defining compression -- quality and level of memory usage. Bigger number means better -- compression but consumes more time and memory. -- Extreme - Modify the compression preset (0 .. 9) to achieve a -- slightly better compression ratio without increasing memory usage -- of the compressor or decompressor. The downside is that the compression -- time will increase dramatically (it can easily double). -- Threads is number of threads to use in compression. Faster compression -- can be reached with more CPU and memory usage. If computer has only one -- CPU then this option provides no gain. -- Timeout has meaning only when Threads parameter is more than 1. It is -- to allow Transcode to return early. Multithreading can make liblzma to -- consume input and produce output in a very bursty way: it may first read -- a lot of input to fill internal buffers, then no input or output occurs -- for a while. To avoid very long blocking times in Transcode, a timeout -- may be set here. If Transcode would block longer than this time, it will -- return with not taken data from In_Data and no results in Out_Data. -- If long blocking times are fine for you, set timeout to a special -- value of 0, which will disable the timeout mechanism and will make -- Transcode block until all the input is consumed or the output buffer has -- been filled. Even with a timeout, Transcode might sometimes take -- somewhat long time to return. No timing guarantees are made. -- Check is integrity check type to use. procedure Auto_Decoder (Coder : in out Coder_Type); overriding function Is_Open (Coder : Coder_Type) return Boolean; -- Indicates that coder is ready to transcode data, i.e either Easy_Encoder -- or Auto_Decoder called. overriding procedure Transcode (Coder : in out Coder_Type; In_Data : Stream_Element_Array; In_Last : out Stream_Element_Offset; Out_Data : out Stream_Element_Array; Out_Last : out Stream_Element_Offset; Flush : Flush_Mode := No_Flush); -- Transcodes data from In_Data to Out_Data. -- In_Last is the index of last element from In_Data accepted by -- the Coder. -- Out_Last is the index of the last element written to Out_Data. -- To tell the Coder that incoming data is complete pass Finish as the -- Flush parameter and call Transcoder with empty In_Data until Stream_End -- routine indicates end of stream. overriding function Total_In (Coder : Coder_Type) return Stream_Element_Count; -- Returns the total amount of input data sent into the coder overriding function Total_Out (Coder : Coder_Type) return Stream_Element_Count; -- Returns the total amount of output data taken from the coder overriding function Finished (Coder : Coder_Type) return Boolean; -- Indicates that incoming data stream is complete and all internally -- processed data is out of coder. overriding procedure Close (Coder : in out Coder_Type); -- Frees internal coder memory allocations. Note that coder is derived from -- Limited_Controlled and will free all memory automatically on -- finalization. LZMA_Error : exception; private type LZMA_Stream_Access is access all Thin.lzma_stream; type Coder_Type is new Ada.Finalization.Limited_Controlled and Coder_Interface with record Stream : LZMA_Stream_Access; Finished : Boolean := False; end record; overriding procedure Finalize (Coder : in out Coder_Type); end GNATCOLL.Coders.LZMA; gnatcoll-bindings-25.0.0/lzma/gnatcoll_lzma.gpr000066400000000000000000000073671464374334300215270ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2019-2020, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with "gnatcoll_core"; library project GnatColl_LZMA is Version := External ("GNATCOLL_VERSION", "0.0"); Name := "gnatcoll_lzma"; type Build_Type is ("DEBUG", "PROD"); Build : Build_Type := External ("GNATCOLL_BUILD_MODE", External ("BUILD", "PROD")); type Library_Type_Type is ("relocatable", "static", "static-pic"); Library_Type : Library_Type_Type := External ("LIBRARY_TYPE", "static"); for Source_Dirs use ("."); for Library_Kind use Library_Type; for Object_Dir use "obj/" & Project'Library_Kind; for Library_Dir use "lib/" & Project'Library_Kind; for Library_Name use Name; Link_Opt := "-llzma"; case Library_Type is when "relocatable" => for Library_Version use "lib" & Name & Gnatcoll_Core.So_Ext & "." & Version; for Leading_Library_Options use External_As_List ("LDFLAGS", " "); for Library_Options use (Link_Opt); when others => null; end case; for Languages use ("Ada"); package Compiler is case Build is when "DEBUG" => for Switches ("Ada") use ("-g", "-O0", "-gnata", "-gnatVa", "-gnatQ", "-gnaty", "-gnateE", "-gnatwaCJe", "-fstack-check"); when "PROD" => -- Do not use -gnatwe for production mode for Switches ("Ada") use ("-O2", "-gnatn", "-gnatwaCJ"); end case; for Switches ("Ada") use Compiler'Switches ("Ada") & External_As_List ("ADAFLAGS", " "); end Compiler; package Binder is case Build is when "DEBUG" => for Switches ("Ada") use ("-E"); when "PROD" => null; end case; end Binder; package Builder is case Build is when "DEBUG" => for Global_Configuration_Pragmas use "../gnat_debug.adc"; when "PROD" => null; end case; end Builder; package Linker is for Linker_Options use (Link_Opt); end Linker; package Ide is for VCS_Kind use "Git"; end Ide; end GnatColl_LZMA; gnatcoll-bindings-25.0.0/lzma/setup.py000077500000000000000000000033671464374334300177000ustar00rootroot00000000000000#!/usr/bin/env python import logging import os import sys sys.path.append(os.path.dirname(os.path.dirname(os.path.abspath(__file__)))) from setup_support import SetupApp class GNATCollLZMA(SetupApp): name = 'gnatcoll_lzma' project = 'gnatcoll_lzma.gpr' description = 'GNATColl LZMA bindings' def create(self): super(GNATCollLZMA, self).create() self.build_cmd.add_argument( '--debug', help='build project in debug mode', action="store_true", default=False) def update_config(self, config, args): logging.info('%-26s %s', 'Libraries kind', ", ".join(config.data['library_types'])) # Set library version with open(os.path.join(config.source_dir, '..', 'version_information'), 'r') as fd: version = fd.read().strip() config.set_data('GNATCOLL_VERSION', version, sub='gprbuild') # Set build mode config.set_data('BUILD', 'DEBUG' if args.debug else 'PROD', sub='gprbuild') logging.info('%-26s %s', 'Build mode', config.data['gprbuild']['BUILD']) def variants(self, config, cmd): result = [] for library_type in config.data['library_types']: gpr_vars = {'LIBRARY_TYPE': library_type, 'GPR_BUILD': library_type} if cmd == 'install': result.append((['--build-name=%s' % library_type, '--build-var=LIBRARY_TYPE'], gpr_vars)) else: result.append(([], gpr_vars)) return result if __name__ == '__main__': app = GNATCollLZMA() sys.exit(app.run()) gnatcoll-bindings-25.0.0/omp/000077500000000000000000000000001464374334300160025ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/omp/README.md000066400000000000000000000006601464374334300172630ustar00rootroot00000000000000The GNAT Components Collection (GNATCOLL) - OMP =============================================== This is the OpenMP component of the GNAT Components Collection. It provides parallel implementations of Ada APIs (e.g. sorting) using the OpenMP library. Dependencies ------------ This component requires the following external components, that should be available on your system: - gprbuild - gnatcoll-core - libgomp (part of GCC) gnatcoll-bindings-25.0.0/omp/a-cvgpso.adb000066400000000000000000000074141464374334300201770ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2019, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with GNATCOLL.OMP.Generic_Array_Sort; package body Ada.Containers.Vectors.Generic_Parallel_Sorting is -- Reuse Ada.Containers.Vectors.Generic_Sorting for Is_Sorted and Merge package Linear_Sorting is new Ada.Containers.Vectors.Generic_Sorting; --------------- -- Is_Sorted -- --------------- function Is_Sorted (Container : Vector) return Boolean renames Linear_Sorting.Is_Sorted; ----------- -- Merge -- ----------- procedure Merge (Target, Source : in out Vector) renames Linear_Sorting.Merge; ---------- -- Sort -- ---------- procedure Sort (Container : in out Vector) is procedure Sort is new GNATCOLL.OMP.Generic_Array_Sort (Index_Type => Index_Type, Element_Type => Element_Type, Array_Type => Elements_Array, "<" => "<"); begin if Container.Last <= Index_Type'First then return; end if; -- The exception behavior for the vector container must match that -- for the list container, so we check for cursor tampering here -- (which will catch more things) instead of for element tampering -- (which will catch fewer things). It's true that the elements of -- this vector container could be safely moved around while (say) an -- iteration is taking place (iteration only increments the busy -- counter), and so technically all we would need here is a test for -- element tampering (indicated by the lock counter), that's simply -- an artifact of our array-based implementation. Logically Sort -- requires a check for cursor tampering. TC_Check (Container.TC); -- Per AI05-0022, the container implementation is required to detect -- element tampering by a generic actual subprogram. declare Lock : With_Lock (Container.TC'Unchecked_Access); pragma Unreferenced (Lock); begin Sort (Container.Elements.EA (Index_Type'First .. Container.Last)); end; end Sort; end Ada.Containers.Vectors.Generic_Parallel_Sorting; gnatcoll-bindings-25.0.0/omp/a-cvgpso.ads000066400000000000000000000074701464374334300202220ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2019, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ -- This is a replacement for package Generic_Sorting in Ada.Containers.Vectors -- using OpenMP to implement the Sort procedure in parallel. generic with function "<" (Left, Right : Element_Type) return Boolean is <>; -- The actual function for the generic formal function "<" of -- Generic_Sorting is expected to return the same value each time it is -- called with a particular pair of element values. It should define a -- strict ordering relationship, that is, be irreflexive, asymmetric, -- and transitive; it should not modify Container. If the actual for "<" -- behaves in some other manner, the behavior of the subprograms of -- Generic_Sorting are unspecified. How many times the subprograms of -- Generic_Sorting call "<" is unspecified. package Ada.Containers.Vectors.Generic_Parallel_Sorting is function Is_Sorted (Container : Vector) return Boolean; -- Returns True if the elements are sorted smallest first as determined -- by the generic formal "<" operator; otherwise, Is_Sorted returns -- False. Any exception raised during evaluation of "<" is propagated. -- This subprogram is not using OpenMP. procedure Sort (Container : in out Vector); -- Reorders the elements of Container such that the elements are sorted -- smallest first as determined by the generic formal "<" operator -- provided. Any exception raised during evaluation of "<" is -- propagated. -- This subprogram is using OpenMP. procedure Merge (Target : in out Vector; Source : in out Vector); -- Merge removes elements from Source and inserts them into Target; -- afterwards, Target contains the union of the elements that were -- initially in Source and Target; Source is left empty. If Target and -- Source are initially sorted smallest first, then Target is ordered -- smallest first as determined by the generic formal "<" operator; -- otherwise, the order of elements in Target is unspecified. Any -- exception raised during evaluation of "<" is propagated. -- This subprogram is not using OpenMP. end Ada.Containers.Vectors.Generic_Parallel_Sorting; gnatcoll-bindings-25.0.0/omp/gnatcoll-omp-generic_array_sort.adb000066400000000000000000000043611464374334300247310ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2019, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with GNATCOLL.OMP.Generic_Constrained_Array_Sort; procedure GNATCOLL.OMP.Generic_Array_Sort (Container : in out Array_Type) is subtype Index_Subtype is Index_Type range Container'First .. Container'Last; subtype Array_Subtype is Array_Type (Index_Subtype); procedure Sort is new GNATCOLL.OMP.Generic_Constrained_Array_Sort (Index_Type => Index_Subtype, Element_Type => Element_Type, Array_Type => Array_Subtype, "<" => "<"); begin Sort (Container); end GNATCOLL.OMP.Generic_Array_Sort; gnatcoll-bindings-25.0.0/omp/gnatcoll-omp-generic_array_sort.ads000066400000000000000000000041431464374334300247500ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2019, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ generic type Index_Type is (<>); type Element_Type is private; type Array_Type is array (Index_Type range <>) of Element_Type; with function "<" (Left, Right : Element_Type) return Boolean is <>; procedure GNATCOLL.OMP.Generic_Array_Sort (Container : in out Array_Type); pragma Preelaborate (GNATCOLL.OMP.Generic_Array_Sort); -- This is the OpenMP version of Ada.Containers.Generic_Array_Sort gnatcoll-bindings-25.0.0/omp/gnatcoll-omp-generic_constrained_array_sort.adb000066400000000000000000000130501464374334300273150ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2019, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with System; procedure GNATCOLL.OMP.Generic_Constrained_Array_Sort (Container : in out Array_Type) is type CB_Struct is record Merge, Insertion_Sort : System.Address; end record with Convention => C; procedure Merge_Sort (Container : in out Array_Type; Temp : in out Array_Type; Callbacks : System.Address; First : Long_Integer; Last : Long_Integer); pragma Import (C, Merge_Sort, "gnatcoll_omp_merge_sort"); -- The merge sort driver implemented in C, using OpenMP primitives procedure Merge (Container : in out Array_Type; Tmp : in out Array_Type; I1, J1, I2, J2 : Long_Integer) with Convention => C; -- The core merge algorithm used by merge sort. -- Used as a callback from Merge_Sort procedure Insertion_Sort (Container : in out Array_Type; First, Last : Long_Integer) with Convention => C; -- Insertion sort algorithm, used as a callback from Merge_Sort for small -- arrays. -------------------- -- Insertion_Sort -- -------------------- procedure Insertion_Sort (Container : in out Array_Type; First, Last : Long_Integer) is pragma Suppress (All_Checks); begin for J in Index_Type'Base'Val (First) .. Index_Type'Base'Val (Last) loop declare V : Element_Type renames Container (J); K : Index_Type'Base := Index_Type'Base'Pred (J); begin while K >= Index_Type'Base'Val (First) and then not (Container (K) < V) loop Container (Index_Type'Succ (K)) := Container (K); K := Index_Type'Base'Pred (K); end loop; Container (Index_Type'Succ (K)) := V; end; end loop; end Insertion_Sort; ----------- -- Merge -- ----------- procedure Merge (Container : in out Array_Type; Tmp : in out Array_Type; I1, J1, I2, J2 : Long_Integer) is pragma Suppress (All_Checks); I, J, K : Index_Type'Base; begin I := Index_Type'Base'Val (I1); -- beginning of the first list J := Index_Type'Base'Val (I2); -- beginning of the second list K := I; while I <= Index_Type'Base'Val (J1) and then J <= Index_Type'Base'Val (J2) loop -- While elements in both lists if Container (I) < Container (J) then Tmp (K) := Container (I); K := Index_Type'Base'Succ (K); I := Index_Type'Base'Succ (I); else Tmp (K) := Container (J); K := Index_Type'Base'Succ (K); J := Index_Type'Base'Succ (J); end if; end loop; -- Copy remaining elements of the first list while I <= Index_Type'Base'Val (J1) loop Tmp (K) := Container (I); K := Index_Type'Base'Succ (K); I := Index_Type'Base'Succ (I); end loop; -- Copy remaining elements of the second list while J <= Index_Type'Base'Val (J2) loop Tmp (K) := Container (J); K := Index_Type'Base'Succ (K); J := Index_Type'Base'Succ (J); end loop; -- Transfer elements from Tmp back to Container for Ind in Index_Type'Base'Val (I1) .. Index_Type'Base'Val (J2) loop Container (Ind) := Tmp (Ind); end loop; end Merge; type Array_Type_Access is access all Array_Type; procedure Free is new Ada.Unchecked_Deallocation (Array_Type, Array_Type_Access); Tmp : Array_Type_Access; Callbacks : aliased CB_Struct := (Merge'Address, Insertion_Sort'Address); begin Tmp := new Array_Type; Merge_Sort (Container, Tmp.all, Callbacks'Address, Index_Type'Pos (Container'First), Index_Type'Pos (Container'Last)); Free (Tmp); end GNATCOLL.OMP.Generic_Constrained_Array_Sort; gnatcoll-bindings-25.0.0/omp/gnatcoll-omp-generic_constrained_array_sort.ads000066400000000000000000000042001464374334300273330ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2019, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ generic type Index_Type is (<>); type Element_Type is private; type Array_Type is array (Index_Type) of Element_Type; with function "<" (Left, Right : Element_Type) return Boolean is <>; procedure GNATCOLL.OMP.Generic_Constrained_Array_Sort (Container : in out Array_Type); pragma Preelaborate (GNATCOLL.OMP.Generic_Constrained_Array_Sort); -- This is the OpenMP version of Ada.Containers.Generic_Constrained_Array_Sort gnatcoll-bindings-25.0.0/omp/gnatcoll-omp.ads000066400000000000000000000037341464374334300210760ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2019, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ package GNATCOLL.OMP is pragma Preelaborate; procedure Set_Num_Threads (Num_Threads : Positive); pragma Import (C, Set_Num_Threads, "omp_set_num_threads"); -- Specifies the default number of threads used in OpenMP parallel -- sections. end GNATCOLL.OMP; gnatcoll-bindings-25.0.0/omp/gnatcoll_omp.gpr000066400000000000000000000104111464374334300211670ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2015-2020, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with "gnatcoll_core"; library project GnatColl_OMP is Version := External ("GNATCOLL_VERSION", "0.0"); Name := "gnatcoll_omp"; type Build_Type is ("DEBUG", "PROD"); Build : Build_Type := External ("GNATCOLL_BUILD_MODE", External ("BUILD", "PROD")); type Library_Type_Type is ("relocatable", "static", "static-pic"); Library_Type : Library_Type_Type := External ("LIBRARY_TYPE", "static"); for Source_Dirs use ("."); for Library_Kind use Library_Type; for Object_Dir use "obj/" & Project'Library_Kind; for Library_Dir use "lib/" & Project'Library_Kind; for Library_Name use Name; Link_Opt := "-fopenmp"; for Languages use ("Ada", "C"); case Library_Type is when "relocatable" => for Library_Version use "lib" & Name & Gnatcoll_Core.So_Ext & "." & Version; for Leading_Library_Options use External_As_List ("LDFLAGS", " "); for Library_Options use (Link_Opt); when others => null; end case; package Compiler is case Build is when "DEBUG" => for Switches ("Ada") use ("-g", "-O0", "-gnata", "-gnatVa", "-gnatQ", "-gnaty", "-gnateE", "-gnatwae", "-fstack-check"); for Switches ("C") use ("-g", "-Wunreachable-code", "-fexceptions"); when "PROD" => -- Do not use -gnatwe for production mode for Switches ("a-cvgpso.adb") use ("-O3", "-gnatpgn", "-gnatwn"); for Switches ("Ada") use ("-O3", "-gnatpn", "-gnatwa"); for Switches ("C") use ("-O3", "-fopenmp", "-Wunreachable-code", "-fexceptions"); end case; Adaflags := External_As_List ("ADAFLAGS", " "); for Switches ("Ada") use Compiler'Switches ("Ada") & Adaflags; for Switches ("a-cvgpso.adb") use Compiler'Switches ("a-cvgpso.adb") & Adaflags; for Switches ("C") use Compiler'Switches ("C") & External_As_List ("CFLAGS", " ") & External_As_List ("CPPFLAGS", " "); end Compiler; package Binder is case Build is when "DEBUG" => for Switches ("Ada") use ("-E"); when "PROD" => null; end case; end Binder; package Builder is case Build is when "DEBUG" => for Global_Configuration_Pragmas use "../gnat_debug.adc"; when "PROD" => null; end case; end Builder; package Ide is for VCS_Kind use "Git"; end Ide; package Linker is for Linker_Options use (Link_Opt); end Linker; end GnatColl_OMP; gnatcoll-bindings-25.0.0/omp/setup.py000077500000000000000000000042331464374334300175210ustar00rootroot00000000000000#!/usr/bin/env python import logging import os import sys sys.path.append(os.path.dirname(os.path.dirname(os.path.abspath(__file__)))) from setup_support import SetupApp class GNATCollOMP(SetupApp): name = 'gnatcoll_omp' project = 'gnatcoll_omp.gpr' description = 'GNATColl OpenMP bindings' def create(self): super(GNATCollOMP, self).create() self.build_cmd.add_argument( '--debug', help='build project in debug mode', action="store_true", default=False) def update_config(self, config, args): logging.info('%-26s %s', 'Libraries kind', ", ".join(config.data['library_types'])) # Set library version with open(os.path.join(config.source_dir, '..', 'version_information'), 'r') as fd: version = fd.read().strip() config.set_data('GNATCOLL_VERSION', version, sub='gprbuild') # Set build mode config.set_data('BUILD', 'DEBUG' if args.debug else 'PROD', sub='gprbuild') logging.info('%-26s %s', 'Build mode', config.data['gprbuild']['BUILD']) # Set GNATCOLL_OS if 'darwin' in config.data['canonical_target']: gnatcoll_os = 'osx' elif 'windows' in config.data['canonical_target']: gnatcoll_os = 'windows' else: # Assume this is an Unix system gnatcoll_os = 'unix' config.set_data('GNATCOLL_OS', gnatcoll_os, sub='gprbuild') def variants(self, config, cmd): result = [] for library_type in config.data['library_types']: gpr_vars = {'LIBRARY_TYPE': library_type, 'XMLADA_BUILD': library_type, 'GPR_BUILD': library_type} if cmd == 'install': result.append((['--build-name=%s' % library_type, '--build-var=LIBRARY_TYPE'], gpr_vars)) else: result.append(([], gpr_vars)) return result if __name__ == '__main__': app = GNATCollOMP() sys.exit(app.run()) gnatcoll-bindings-25.0.0/omp/sort_omp.c000066400000000000000000000070641464374334300200170ustar00rootroot00000000000000/**************************************************************************** * G N A T C O L L * * * * Copyright (C) 2019, 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 * * . * * * ****************************************************************************/ /* Provide helper functions to implement GNATCOLL.OMP.Generic_Constrained_Array_Sort via a parallel merge sort using C OpenMP directives. */ const int insertion_threshold = 48; const int serial_threshold = 1024; typedef void (*merge_func)(void *, void *, long, long, long, long); typedef void (*insertion_sort_func)(void *, long, long); typedef struct { merge_func merge; insertion_sort_func insertion_sort; } cb_struct; static void mergesort_parallel_omp (void *a, void *temp, cb_struct *callbacks, long i, long j); static void mergesort_serial (void * a, void *temp, cb_struct *callbacks, long i, long j); void gnatcoll_omp_merge_sort (void *container, void *temp, cb_struct *callbacks, long i, long j); /* Driver for OpenMP version of merge sort */ void gnatcoll_omp_merge_sort (void *container, void *temp, cb_struct *callbacks, long i, long j) { #pragma omp parallel #pragma omp single mergesort_parallel_omp (container, temp, callbacks, i, j); } /* Non OpenMP version of merge sort */ static void mergesort_serial (void * a, void *temp, cb_struct *callbacks, long i, long j) { if (j - i <= insertion_threshold) { (*callbacks->insertion_sort) (a, i, j); return; } long mid = (i + j) / 2; mergesort_serial (a, temp, callbacks, i, mid); mergesort_serial (a, temp, callbacks, mid + 1, j); (*callbacks->merge) (a, temp, i, mid, mid + 1, j); } /* Parallel part of merge sort using OpenMP */ static void mergesort_parallel_omp (void *a, void *temp, cb_struct *callbacks, long i, long j) { if (j - i <= serial_threshold) { mergesort_serial (a, temp, callbacks, i, j); return; } long mid = (i + j) / 2; #pragma omp task mergesort_parallel_omp (a, temp, callbacks, i, mid); mergesort_parallel_omp (a, temp, callbacks, mid + 1, j); #pragma omp taskwait //merge the two sorted sub-arrays (*callbacks->merge) (a, temp, i, mid, mid + 1, j); } gnatcoll-bindings-25.0.0/python/000077500000000000000000000000001464374334300165305ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/python/README.md000066400000000000000000000015341464374334300200120ustar00rootroot00000000000000The GNAT Components Collection (GNATCOLL) - Python ================================================== This is the Python component of the GNAT Components Collection. Standard interface to the Python 2 interpreter. NOTE: This binding is not compatible with Python 3. Dependencies ------------ This component requires the following external components, that should be available on your system: - gprbuild - gnatcoll-core - Python 2, at least version 2.3, but the most recent available version of Python 2 from ww.python.org is recommended. NOTE for Windows users: if you are installing the official distrib, you should install it in "just for me" mode, otherwise the python DLL will be placed in C:\Windows\System32 folder and it will result in shared library's link failure. The workaround in this case is to copy it by hand back to python install dir. gnatcoll-bindings-25.0.0/python/docs/000077500000000000000000000000001464374334300174605ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/python/docs/Makefile000066400000000000000000000000431464374334300211150ustar00rootroot00000000000000include ../../docs-common/Makefile gnatcoll-bindings-25.0.0/python/docs/conf.py000066400000000000000000000016271464374334300207650ustar00rootroot00000000000000# -*- coding: utf-8 -*- # # GNATcoll Bindings - Python documentation build configuration file # Load the base setup exec(open('../../docs-common/common_conf.py').read()) # General information about the project. project = u'GNATcoll Bindings - Python' # Output file base name for HTML help builder. htmlhelp_basename = 'GNATcoll-Python' # Grouping the document tree into LaTeX files. List of tuples # (source start file, target name, title, author, documentclass # [howto/manual]). latex_documents = [ ('index', 'GNATcoll-Python.tex', u'GNATcoll Bindings - Python Documentation', u'AdaCore', 'manual'), ] # One entry per manual page. List of tuples # (source start file, name, description, authors, manual section). man_pages = [ ('index', 'gnatcoll-python', u'GNATcoll Bindings - Python Documentation', [u'AdaCore'], 1) ] # Bibliographic Dublin Core info. epub_title = u'GNATcoll Bindings - Python' gnatcoll-bindings-25.0.0/python/docs/index.rst000066400000000000000000000003331464374334300213200ustar00rootroot00000000000000GNATcoll Bindings - Python ========================== This component uses the ``GNATCOLL.Scripts`` API to provide interfacing with Python. Please refer to its documentation for an introduction to ``GNATCOLL.Scripts``. gnatcoll-bindings-25.0.0/python/gnatcoll-any_types-python.adb000066400000000000000000000075661464374334300243510ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2021, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with GNATCOLL.Python.State; use GNATCOLL.Python.State; package body GNATCOLL.Any_Types.Python is ------------------- -- From_PyObject -- ------------------- function From_PyObject (Object : PyObject) return Any_Type is Lock : Ada_GIL_Lock with Unreferenced; begin if Object = null or else Object = Py_None then return Empty_Any_Type; end if; if PyInt_Check (Object) then declare A : Any_Type (Integer_Type, 0); begin A.Int := PyInt_AsLong (Object); return A; end; elsif PyString_Check (Object) then declare S : constant String := PyString_AsString (Object); A : Any_Type (String_Type, S'Length); begin A.Str := S; return A; end; elsif PyUnicode_Check (Object) then declare S : constant String := Unicode_AsString (Object); A : Any_Type (String_Type, S'Length); begin A.Str := S; return A; end; elsif PyList_Check (Object) then declare Size : constant Integer := PyList_Size (Object); Arr : Any_Type_Array (1 .. Size); A : Any_Type (List_Type, Size); begin for J in 1 .. Size loop Arr (J) := new Any_Type' (From_PyObject (PyList_GetItem (Object, J - 1))); end loop; A.List := Arr; return A; end; elsif PyTuple_Check (Object) then declare Size : constant Integer := PyTuple_Size (Object); Arr : Any_Type_Array (1 .. Size); A : Any_Type (Tuple_Type, Size); begin for J in 1 .. Size loop Arr (J) := new Any_Type' (From_PyObject (PyTuple_GetItem (Object, J - 1))); end loop; A.Tuple := Arr; return A; end; else -- When adding support for new types, add the corresponding cases -- here. null; end if; return Empty_Any_Type; end From_PyObject; end GNATCOLL.Any_Types.Python; gnatcoll-bindings-25.0.0/python/gnatcoll-any_types-python.ads000066400000000000000000000045761464374334300243700ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2017, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package provides a utilities to manipulate Python objects. This is not -- meant to be very performance-efficient, but to provide an interface simpler -- than the direct manipulation of PyObjects. with GNATCOLL.Python; use GNATCOLL.Python; package GNATCOLL.Any_Types.Python is function From_PyObject (Object : PyObject) return Any_Type; -- Create an Any_Type from the contents of Object. This creates copies in -- of any data in Object. -- Empty_Any_Type is returned if the underlying Python type (or its -- children in case of container types) is not supported. -- The result must be freed by the caller, by calling Free. end GNATCOLL.Any_Types.Python; gnatcoll-bindings-25.0.0/python/gnatcoll-python-state.adb000066400000000000000000000042131464374334300234400ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2021, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ package body GNATCOLL.Python.State is ---------------- -- Initialize -- ---------------- overriding procedure Initialize (Self : in out Ada_GIL_Lock) is begin Self.State := PyGILState_Ensure; end Initialize; -------------- -- Finalize -- -------------- overriding procedure Finalize (Self : in out Ada_GIL_Lock) is begin PyGILState_Release (Self.State); end Finalize; end GNATCOLL.Python.State; gnatcoll-bindings-25.0.0/python/gnatcoll-python-state.ads000066400000000000000000000065421464374334300234700ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2021, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ -- Subprograms to manipulate GIL state and wrapper to simplify such -- operations in Ada code. with Ada.Finalization; package GNATCOLL.Python.State is type Ada_GIL_Lock is new Ada.Finalization.Limited_Controlled with private; -- This type is a wrapper around PyGILState_Ensure/Release, to avoid -- manual call to release, especially in the case of an exception. type PyGILState_STATE is private; PyGILState_LOCKED : constant PyGILState_STATE; PyGILState_UNLOCKED : constant PyGILState_STATE; function PyGILState_Ensure return PyGILState_STATE; pragma Import (C, PyGILState_Ensure, "ada_PyGILState_Ensure"); -- Ensure that the current thread is ready to call the Python C API -- regardless of the current state of Python, or of the global -- interpreter lock. This may be called as many times as desired by a -- thread as long as each call is matched with a call to -- PyGILState_Release(). procedure PyGILState_Release (State : PyGILState_STATE); pragma Import (C, PyGILState_Release, "ada_PyGILState_Release"); -- Release any resources previously acquired. After this call, Python's -- state will be the same as it was prior to the corresponding -- PyGILState_Ensure(). private overriding procedure Initialize (Self : in out Ada_GIL_Lock); overriding procedure Finalize (Self : in out Ada_GIL_Lock); type Ada_GIL_Lock is new Ada.Finalization.Limited_Controlled with record State : PyGILState_STATE; end record; type PyGILState_STATE is new Integer; PyGILState_LOCKED : constant PyGILState_STATE := 0; PyGILState_UNLOCKED : constant PyGILState_STATE := 1; end GNATCOLL.Python.State; gnatcoll-bindings-25.0.0/python/gnatcoll-python.adb000066400000000000000000001065061464374334300223320ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2003-2020, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with System; use System; with Interfaces.C.Strings; use Interfaces.C.Strings; with GNAT.OS_Lib; use GNAT.OS_Lib; package body GNATCOLL.Python is No_Method_Def : constant PyMethodDef := (Name => Null_Ptr, Func => null, Flags => METH_VARGS or METH_KEYWORDS, Doc => Null_Ptr); type Methods_Access is access PyMethodDef_Array; type MethodDef_Access is access PyMethodDef; pragma Convention (C, MethodDef_Access); function PyCFunction_New (MethodDef : MethodDef_Access; Self : PyObject; Module : PyObject := null) return PyObject; pragma Import (C, PyCFunction_New, "PyCFunction_NewEx"); -- Create a new callable object, which, when called from python, will call -- the Ada subprogram. -- Self is the first argument that will be passed to the Ada subprogram. -- Module is the value of the __module__ attribute for the new function. ------------------------ -- PyRun_SimpleString -- ------------------------ function PyRun_SimpleString (Cmd : String) return Boolean is function Internal (Cmd : String) return Integer; pragma Import (C, Internal, "PyRun_SimpleString"); begin return Internal (Cmd & ASCII.NUL) = 0; end PyRun_SimpleString; ------------------------ -- PyImport_AddModule -- ------------------------ function PyImport_AddModule (Module_Name : String) return PyObject is function Internal (Name : String) return PyObject; pragma Import (C, Internal, "PyImport_AddModule"); begin return Internal (Module_Name & ASCII.NUL); end PyImport_AddModule; --------------------------- -- PyImport_ImportModule -- --------------------------- function PyImport_ImportModule (Module_Name : String) return PyObject is function Internal (Name : String) return PyObject; pragma Import (C, Internal, "PyImport_ImportModule"); begin return Internal (Module_Name & ASCII.NUL); end PyImport_ImportModule; ------------------ -- PyRun_String -- ------------------ function PyRun_String (Str : String; Start : Interpreter_State; Globals : PyObject; Locals : PyObject) return PyObject is function Internal (Str : String; Start : Interpreter_State; Globals : PyObject; Locals : PyObject) return PyObject; pragma Import (C, Internal, "PyRun_String"); begin return Internal (Str & ASCII.LF, Start, Globals, Locals); end PyRun_String; ---------------------- -- PyArg_ParseTuple -- ---------------------- function PyArg_ParseTuple (Arg : PyObject; Format : String; Value1 : System.Address) return Boolean is function Internal (Arg : PyObject; Format : String; V1 : System.Address) return Integer; pragma Import (C, Internal, "ada_py_arg_parsetuple_ptr"); begin return Internal (Arg, Format & ASCII.NUL, Value1) = 1; end PyArg_ParseTuple; function PyArg_ParseTuple (Arg : PyObject; Format : String; Value1, Value2 : System.Address) return Boolean is function Internal (Arg : PyObject; Format : String; V1, V2 : System.Address) return Integer; pragma Import (C, Internal, "ada_py_arg_parsetuple_ptr2"); begin return Internal (Arg, Format & ASCII.NUL, Value1, Value2) = 1; end PyArg_ParseTuple; function PyArg_ParseTuple (Arg : PyObject; Format : String; Value1, Value2, Value3 : System.Address) return Boolean is function Internal (Arg : PyObject; Format : String; V1, V2, V3 : System.Address) return Integer; pragma Import (C, Internal, "ada_py_arg_parsetuple_ptr3"); begin return Internal (Arg, Format & ASCII.NUL, Value1, Value2, Value3) = 1; end PyArg_ParseTuple; function PyArg_ParseTuple (Arg : PyObject; Format : String; Value1, Value2, Value3, Value4 : System.Address) return Boolean is function Internal (Arg : PyObject; Format : String; V1, V2, V3, V4 : System.Address) return Integer; pragma Import (C, Internal, "ada_py_arg_parsetuple_ptr4"); begin return Internal (Arg, Format & ASCII.NUL, Value1, Value2, Value3, Value4) = 1; end PyArg_ParseTuple; function PyArg_ParseTuple (Arg : PyObject; Format : String; Value1, Value2, Value3, Value4, Value5 : System.Address) return Boolean is function Internal (Arg : PyObject; Format : String; V1, V2, V3, V4, V5 : System.Address) return Integer; pragma Import (C, Internal, "ada_py_arg_parsetuple_ptr5"); begin return Internal (Arg, Format & ASCII.NUL, Value1, Value2, Value3, Value4, Value5) = 1; end PyArg_ParseTuple; ---------------------- -- PyFunction_Check -- ---------------------- function PyFunction_Check (Func : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pyfunction_check"); begin return Internal (Func) = 1; end PyFunction_Check; ---------------------- -- PyCallable_Check -- ---------------------- function PyCallable_Check (Func : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "PyCallable_Check"); begin return Internal (Func) = 1; end PyCallable_Check; -------------------- -- PyString_Check -- -------------------- function PyString_Check (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pystring_check"); begin return Internal (Obj) = 1; end PyString_Check; --------------------- -- PyUnicode_Check -- --------------------- function PyUnicode_Check (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pyunicode_check"); begin return Internal (Obj) = 1; end PyUnicode_Check; ------------------------ -- PyBaseString_Check -- ------------------------ function PyBaseString_Check (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pybasestring_check"); begin return Internal (Obj) = 1; end PyBaseString_Check; ------------------ -- PyList_Check -- ------------------ function PyList_Check (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pylist_check"); begin return Internal (Obj) = 1; end PyList_Check; ------------------ -- PyIter_Check -- ------------------ function PyIter_Check (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pyiter_check"); begin return Internal (Obj) = 1; end PyIter_Check; ----------------- -- PyInt_Check -- ----------------- function PyInt_Check (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pyint_check"); begin return Internal (Obj) = 1; end PyInt_Check; ------------------- -- PyFloat_Check -- ------------------- function PyFloat_Check (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pyfloat_check"); begin return Internal (Obj) = 1; end PyFloat_Check; ------------------------ -- PyBool_FromBoolean -- ------------------------ function PyBool_FromBoolean (Value : Boolean) return PyObject is function PyTrue return PyObject; pragma Import (C, PyTrue, "ada_py_true"); function PyFalse return PyObject; pragma Import (C, PyFalse, "ada_py_false"); Result : PyObject; begin if Value then Result := PyTrue; else Result := PyFalse; end if; Py_INCREF (Result); return Result; end PyBool_FromBoolean; ------------------ -- PyBool_Check -- ------------------ function PyBool_Check (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pybool_check"); begin return Internal (Obj) = 1; end PyBool_Check; -------------------- -- PyBool_Is_True -- -------------------- function PyBool_Is_True (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pybool_is_true"); begin return Internal (Obj) = 1; end PyBool_Is_True; ------------------- -- PyTuple_Check -- ------------------- function PyTuple_Check (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pytuple_check"); begin return Internal (Obj) = 1; end PyTuple_Check; ---------------------- -- PyObject_GetItem -- ---------------------- function PyObject_GetItem (Obj : PyObject; Key : Integer) return PyObject is K : PyObject; Result : PyObject; begin K := PyInt_FromLong (Interfaces.C.long (Key)); Result := PyObject_GetItem (Obj, K); Py_DECREF (K); return Result; end PyObject_GetItem; ---------------------- -- PyObject_SetItem -- ---------------------- procedure PyObject_SetItem (Obj : PyObject; Key : Integer; Value : PyObject) is K : PyObject; Result : Integer; pragma Unreferenced (Result); begin K := PyInt_FromLong (Interfaces.C.long (Key)); Result := PyObject_SetItem (Obj, K, Value); Py_DECREF (K); end PyObject_SetItem; ----------------------- -- PyString_AsString -- ----------------------- function PyString_AsString (Str : PyObject) return String is function Low (Str : PyObject) return Interfaces.C.Strings.chars_ptr; pragma Import (C, Low, "ada_PyString_AsString"); -- Returns a NULL terminated representation of the contents of string. -- Result value must be freed. C : constant Interfaces.C.Strings.chars_ptr := Low (Str); begin if C = Null_Ptr then return ""; else declare R : constant String := Value (C); procedure C_Free (S : chars_ptr); pragma Import (C, C_Free, "free"); begin -- Since C was allocated by ada_PyString_AsString via strdup(), -- and not via System.Memory, we should not be using -- Interfaces.C.Strings.Free which goes through System.Memory. -- So we call free() directly instead. C_Free (C); return R; end; end if; end PyString_AsString; ------------------------- -- PyString_FromString -- ------------------------- function PyString_FromString (Str : String) return PyObject is function Internal (Str : String; Size : Integer) return PyObject; pragma Import (C, Internal, "PyString_FromStringAndSize"); begin return Internal (Str, Str'Length); end PyString_FromString; -------------------------- -- PyUnicode_FromString -- -------------------------- function PyUnicode_FromString (Str : String) return PyObject is function Internal (Str : String) return PyObject; pragma Import (C, Internal, "ada_PyUnicode_FromString"); begin return Internal (Str & ASCII.NUL); end PyUnicode_FromString; ------------------------------- -- PyUnicode_AsEncodedString -- ------------------------------- function PyUnicode_AsEncodedString (Unicode : PyObject; Encoding : String; Errors : Unicode_Error_Handling := Strict) return PyObject is function Internal (Unicode : PyObject; Encoding, Errors : String) return PyObject; pragma Import (C, Internal, "ada_PyUnicode_AsEncodedString"); begin case Errors is when Strict => return Internal (Unicode, Encoding & ASCII.NUL, "strict" & ASCII.NUL); when Ignore => return Internal (Unicode, Encoding & ASCII.NUL, "ignore" & ASCII.NUL); when Replace => return Internal (Unicode, Encoding & ASCII.NUL, "replace" & ASCII.NUL); end case; end PyUnicode_AsEncodedString; ---------------------- -- Unicode_AsString -- ---------------------- function Unicode_AsString (Str : PyObject; Encoding : String := "utf-8") return String is S : constant PyObject := PyUnicode_AsEncodedString (Unicode => Str, Encoding => Encoding, Errors => Replace); Result : constant String := PyString_AsString (S); begin Py_DECREF (S); return Result; end Unicode_AsString; --------------------- -- PySys_SetObject -- --------------------- procedure PySys_SetObject (Name : String; Object : PyObject) is procedure Internal (Name : String; Object : PyObject); pragma Import (C, Internal, "PySys_SetObject"); begin Internal (Name & ASCII.NUL, Object); end PySys_SetObject; --------------------- -- PySys_GetObject -- --------------------- function PySys_GetObject (Name : String) return PyObject is function Internal (Name : String) return PyObject; pragma Import (C, Internal, "PySys_GetObject"); begin return Internal (Name & ASCII.NUL); end PySys_GetObject; ------------------------- -- PyObject_CallMethod -- ------------------------- function PyObject_CallMethod (Object : PyObject; Name : String) return PyObject is function Internal (Object : PyObject; Name : String) return PyObject; pragma Import (C, Internal, "ada_py_object_callmethod"); begin return Internal (Object, Name & ASCII.NUL); end PyObject_CallMethod; function PyObject_CallMethod (Object : PyObject; Name : String; Arg1 : PyObject) return PyObject is function Internal (Object : PyObject; Name : String; Arg : PyObject) return PyObject; pragma Import (C, Internal, "ada_py_object_callmethod_obj"); begin return Internal (Object, Name & ASCII.NUL, Arg1); end PyObject_CallMethod; function PyObject_CallMethod (Object : PyObject; Name : String; Arg1 : Integer) return PyObject is function Internal (Object : PyObject; Name : String; Arg : Integer) return PyObject; pragma Import (C, Internal, "ada_py_object_callmethod_int"); begin return Internal (Object, Name & ASCII.NUL, Arg1); end PyObject_CallMethod; ----------------------- -- Py_SetProgramName -- ----------------------- procedure Py_SetProgramName (Name : String) is procedure Internal (Name : String); pragma Import (C, Internal, "Py_SetProgramName"); Program_Name : constant String_Access := new String'(Name & ASCII.NUL); -- As stated by the Python documentation the string passed to -- Py_SetProgramName should be in "static storage whose contents will -- not change for the duration of the program's execution" begin Internal (Program_Name.all); end Py_SetProgramName; ---------------------- -- Py_SetPythonHome -- ---------------------- procedure Py_SetPythonHome (Home : String) is procedure Internal (Name : String); pragma Import (C, Internal, "Py_SetPythonHome"); C_Home : constant String_Access := new String'(Home & ASCII.NUL); -- As stated by the Python documentation the string passed to -- Py_SetPythonHome should be in "static storage whose contents will -- not change for the duration of the program's execution" begin Internal (C_Home.all); end Py_SetPythonHome; ---------------------- -- Py_CompileString -- ---------------------- function Py_CompileString (Cmd : String; Name : String; State : Interpreter_State) return PyCodeObject is function Internal (Cmd, Name : String; State : Interpreter_State) return PyCodeObject; pragma Import (C, Internal, "Py_CompileString"); begin return Internal (Cmd & ASCII.NUL, Name & ASCII.NUL, State); end Py_CompileString; ------------------ -- PyDict_Check -- ------------------ function PyDict_Check (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pydict_check"); begin return Internal (Obj) /= 0; end PyDict_Check; -------------------- -- PyAnySet_Check -- -------------------- function PyAnySet_Check (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pyanyset_check"); begin return Internal (Obj) /= 0; end PyAnySet_Check; -------------------------- -- PyDict_SetItemString -- -------------------------- procedure PyDict_SetItemString (Dict : PyDictObject; Key : String; Obj : PyObject) is S : chars_ptr := New_String (Key); Result : constant Integer := PyDict_SetItemString (Dict, S, Obj); pragma Unreferenced (Result); begin Free (S); end PyDict_SetItemString; ------------------------ -- PyModule_AddObject -- ------------------------ function PyModule_AddObject (Module : PyObject; Name : String; Object : PyObject) return Integer is S : chars_ptr := New_String (Name); Result : Integer; begin Result := PyModule_AddObject (Module, S, Object); Free (S); return Result; end PyModule_AddObject; -------------------------- -- PyDict_GetItemString -- -------------------------- function PyDict_GetItemString (Dict : PyDictObject; Key : String) return PyObject is S : chars_ptr := New_String (Key); Result : constant PyObject := PyDict_GetItemString (Dict, S); begin Free (S); return Result; end PyDict_GetItemString; ------------------ -- Create_Tuple -- ------------------ function Create_Tuple (Objects : PyObject_Array) return PyObject is Tuple : constant PyObject := PyTuple_New (Objects'Length); begin for O in Objects'Range loop PyTuple_SetItem (Tuple, O - Objects'First, Objects (O)); end loop; return Tuple; end Create_Tuple; ------------------------ -- PyErr_NewException -- ------------------------ function PyErr_NewException (Name : String; Base : PyObject := null; Dict : PyObject := null) return PyObject is function Internal (Name : String; Base, Dict : PyObject) return PyObject; pragma Import (C, Internal, "PyErr_NewException"); begin return Internal (Name & ASCII.NUL, Base, Dict); end PyErr_NewException; --------------------- -- PyErr_SetString -- --------------------- procedure PyErr_SetString (Except : PyObject; Msg : String) is procedure Internal (Except : PyObject; Msg : String); pragma Import (C, Internal, "PyErr_SetString"); begin Internal (Except, Msg & ASCII.NUL); end PyErr_SetString; ---------------------------- -- PyObject_GetAttrString -- ---------------------------- function PyObject_GetAttrString (Object : PyObject; Name : String) return PyObject is S : chars_ptr := New_String (Name); Result : constant PyObject := PyObject_GetAttrString (Object, S); begin Free (S); return Result; end PyObject_GetAttrString; ---------------------------- -- PyObject_HasAttrString -- ---------------------------- function PyObject_HasAttrString (Obj : PyObject; Attr_Name : String) return Boolean is function Internal (Object : PyObject; S : String) return Integer; pragma Import (C, Internal, "PyObject_HasAttrString"); begin return Boolean'Val (Internal (Obj, Attr_Name & ASCII.NUL)); end PyObject_HasAttrString; ---------------------------- -- PyObject_SetAttrString -- ---------------------------- procedure PyObject_SetAttrString (Obj : PyObject; Attr_Name : String; Value : PyObject) is procedure Internal (Obj : PyObject; Name : String; Val : PyObject); pragma Import (C, Internal, "PyObject_SetAttrString"); begin Internal (Obj, Attr_Name & ASCII.NUL, Value); end PyObject_SetAttrString; ---------------------------- -- PyObject_SetAttrString -- ---------------------------- function PyObject_SetAttrString (Obj : PyObject; Attr_Name : String; Value : PyObject) return Integer is function Internal (Obj : PyObject; Name : String; Val : PyObject) return Integer; pragma Import (C, Internal, "PyObject_SetAttrString"); begin return Internal (Obj, Attr_Name & ASCII.NUL, Value); end PyObject_SetAttrString; ----------------------------------- -- PyObject_GenericSetAttrString -- ----------------------------------- function PyObject_GenericSetAttrString (Object : PyObject; Name : String; Attr : PyObject) return Integer is N : constant PyObject := PyString_FromString (Name); Result : Integer; begin Result := PyObject_GenericSetAttr (Object, N, Attr); Py_DECREF (N); return Result; end PyObject_GenericSetAttrString; --------------------- -- PyDict_Contains -- --------------------- function PyDict_Contains (Dict : PyDictObject; Key : PyObject) return Boolean is function Internal (Dict : PyObject; Key : PyObject) return Integer; pragma Import (C, Internal, "PyDict_Contains"); begin return Internal (Dict, Key) = 1; end PyDict_Contains; ----------------- -- PyDict_Next -- ----------------- procedure PyDict_Next (Dict : PyObject; Pos : in out Integer; Key : out PyObject; Value : out PyObject) is function Internal (Dict : PyObject; Pos, Key, Value : System.Address) return Integer; pragma Import (C, Internal, "PyDict_Next"); P : Interfaces.C.size_t := Interfaces.C.size_t (Pos); begin if Internal (Dict, P'Address, Key'Address, Value'Address) = 0 then Pos := -1; else Pos := Integer (P); end if; end PyDict_Next; -------------------- -- Print_Refcount -- -------------------- procedure Print_Refcount (Obj : PyObject; Msg : String) is procedure Internal (Obj : PyObject; Msg : String); pragma Import (C, Internal, "ada_py_print_refcount"); begin Internal (Obj, Msg & ASCII.NUL); end Print_Refcount; ------------------------ -- PyFile_WriteString -- ------------------------ function PyFile_WriteString (Text : String; File : PyObject) return Boolean is function Internal (Text : String; File : PyObject) return Integer; pragma Import (C, Internal, "PyFile_WriteString"); begin return Internal (Text & ASCII.NUL, File) /= 0; end PyFile_WriteString; ----------------------- -- PyFile_FromString -- ----------------------- function PyFile_FromString (File_Name, Mode : String) return PyObject is function Internal (N, M : String) return PyObject; pragma Import (C, Internal, "PyFile_FromString"); begin return Internal (File_Name & ASCII.NUL, Mode & ASCII.NUL); end PyFile_FromString; ------------------- -- Py_InitModule -- ------------------- function Py_InitModule (Module_Name : String; Methods : PyMethodDef_Array := No_MethodDef_Array; Doc : String := "") return PyObject is function Internal (N : String; Methods : System.Address; Doc : String; Self : PyObject := null) return PyObject; pragma Import (C, Internal, "ada_Py_InitModule4"); M : Methods_Access; begin if Methods /= No_MethodDef_Array then -- ??? Memory is never freed, but Python is not supposed to be killed -- before the end of the application M := new PyMethodDef_Array'(Methods & No_Method_Def); return Internal (Module_Name & ASCII.NUL, M.all'Address, Doc & ASCII.NUL); else return Internal (Module_Name & ASCII.NUL, System.Null_Address, Doc & ASCII.NUL); end if; end Py_InitModule; ---------- -- Free -- ---------- procedure Free (Method : in out PyMethodDef) is procedure C_Free (C : Interfaces.C.Strings.chars_ptr); pragma Import (C, C_Free, "free"); begin C_Free (Method.Name); C_Free (Method.Doc); Method.Name := Null_Ptr; Method.Doc := Null_Ptr; end Free; ---------- -- Free -- ---------- procedure Free (Methods : in out PyMethodDef_Array) is begin for M in Methods'Range loop Free (Methods (M)); end loop; end Free; ------------------ -- PyModule_New -- ------------------ function PyModule_New (Module_Name : String) return PyObject is function Internal (N : String) return PyObject; pragma Import (C, Internal, "PyModule_New"); begin return Internal (Module_Name & ASCII.NUL); end PyModule_New; ---------------------- -- PyModule_Getname -- ---------------------- function PyModule_Getname (Module : PyObject) return String is function Internal (M : PyObject) return Interfaces.C.Strings.chars_ptr; pragma Import (C, Internal, "PyModule_GetName"); begin return Value (Internal (Module)); end PyModule_Getname; ------------------ -- Add_Function -- ------------------ procedure Add_Function (Module : PyObject; Func : PyMethodDef; Self : PyObject := null) is C_Func : PyObject; Result : Integer; pragma Unreferenced (Result); begin if Self /= null then C_Func := PyCFunction_New (new PyMethodDef'(Func), Self, PyString_FromString (PyModule_Getname (Module))); else C_Func := PyCFunction_New (new PyMethodDef'(Func), Module, PyString_FromString (PyModule_Getname (Module))); end if; if C_Func /= null then Result := PyModule_AddObject (Module, Func.Name, C_Func); end if; end Add_Function; ---------------- -- Add_Method -- ---------------- procedure Add_Method (Class : PyObject; Func : PyMethodDef; Self : PyObject := null; Module : PyObject) is procedure Add_Method (Func : MethodDef_Access; Self : PyObject; Class : PyObject; Module : PyObject); pragma Import (C, Add_Method, "ada_py_add_method"); begin Add_Method (new PyMethodDef'(Func), Self, Class, Module); end Add_Method; ----------------------- -- Add_Static_Method -- ----------------------- procedure Add_Static_Method (Class : PyObject; Func : PyMethodDef; Self : PyObject := null; Module : PyObject) is function PyStaticMethod_New (Method : PyObject) return PyObject; pragma Import (C, PyStaticMethod_New, "PyStaticMethod_New"); Def : constant MethodDef_Access := new PyMethodDef'(Func); C_Func : PyObject; Static : PyObject; Result : Integer; pragma Unreferenced (Result); begin Def.Flags := Def.Flags or METH_STATIC; C_Func := PyCFunction_New (Def, Self, PyString_FromString (PyModule_Getname (Module))); if C_Func /= null then -- ??? Likely not needed for python3 Static := PyStaticMethod_New (C_Func); Result := PyObject_SetAttrString (Class, Func.Name, Static); Py_DECREF (Static); end if; end Add_Static_Method; ---------------------- -- Add_Class_Method -- ---------------------- procedure Add_Class_Method (Class : PyObject; Func : PyMethodDef; Module : PyObject) is function PyClassMethod_New (Method : PyObject) return PyObject; pragma Import (C, PyClassMethod_New, "PyClassMethod_New"); Def : constant MethodDef_Access := new PyMethodDef'(Func); C_Func : PyObject; Result : Integer; Meth : PyObject; pragma Unreferenced (Result); begin Def.Flags := Def.Flags or METH_CLASS; C_Func := PyCFunction_New (Def, null, PyString_FromString (PyModule_Getname (Module))); if C_Func /= null then Meth := PyClassMethod_New (C_Func); Result := PyObject_SetAttrString (Class, Func.Name, Meth); Py_DECREF (Meth); end if; end Add_Class_Method; ----------------------- -- PyDescr_NewGetSet -- ----------------------- function PyDescr_NewGetSet (Typ : PyObject; Name : String; Setter : C_Setter := null; Getter : C_Getter := null; Doc : String := ""; Closure : System.Address := System.Null_Address) return Boolean is function To_Callback is new Standard.Ada.Unchecked_Conversion (C_Getter, C_Callback); function To_Callback is new Standard.Ada.Unchecked_Conversion (C_Setter, C_Callback); function Internal (Typ : PyObject; Name : chars_ptr; Setter, Getter : C_Callback; Doc : chars_ptr; Closure : System.Address) return Integer; pragma Import (C, Internal, "ada_pydescr_newGetSet"); begin return Internal (Typ, New_String (Name), To_Callback (Setter), To_Callback (Getter), New_String (Doc), Closure) /= 0; end PyDescr_NewGetSet; ----------------------- -- Create_Method_Def -- ----------------------- function Create_Method_Def (Name : String; Func : C_Method_Vargs; Doc : String := "") return PyMethodDef is begin return (Name => New_String (Name), Func => To_Callback (Func), Flags => METH_VARGS, Doc => New_String (Doc)); end Create_Method_Def; ----------------------- -- Create_Method_Def -- ----------------------- function Create_Method_Def (Name : String; Func : C_Method_Keywords; Doc : String := "") return PyMethodDef is D : chars_ptr := Null_Ptr; begin if Doc /= "" then D := New_String (Doc); end if; return (Name => New_String (Name), Func => To_Callback (Func), Flags => METH_KEYWORDS or METH_VARGS, Doc => D); end Create_Method_Def; ------------------- -- Lookup_Object -- ------------------- function Lookup_Object (Module : String; Name : String) return PyObject is begin return Lookup_Object (PyImport_AddModule (Module), Name); end Lookup_Object; ------------------- -- Lookup_Object -- ------------------- function Lookup_Object (Module : PyObject; Name : String) return PyObject is Dict : PyObject; begin if Module /= null then Dict := PyModule_GetDict (Module); return PyDict_GetItemString (Dict, Name); end if; return null; end Lookup_Object; ------------- -- Py_Main -- ------------- function Py_Main return Integer is function Internal return Integer; pragma Import (C, Internal, "ada_py_main"); begin return Internal; end Py_Main; --------------------- -- PyCObject_Check -- --------------------- function PyCObject_Check (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pycobject_check"); begin return Internal (Obj) = 1; end PyCObject_Check; -------------------- -- PyMethod_Check -- -------------------- function PyMethod_Check (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pymethod_check"); begin return Internal (Obj) = 1; end PyMethod_Check; ------------------- -- Py_IsSubclass -- ------------------- function Py_IsSubclass (Class : PyObject; Base : PyObject) return Boolean is function Internal (Class, Base : PyObject) return Integer; pragma Import (C, Internal, "ada_is_subclass"); begin return Internal (Class, Base) /= 0; end Py_IsSubclass; -------------- -- Type_New -- -------------- function Type_New (Name : String; Bases : PyTuple; Dict : PyObject; Metatype : PyTypeObject := null) return PyObject is function Internal (Meta : PyTypeObject; Name : Interfaces.C.Strings.chars_ptr; Bases : PyObject; Dict : PyObject) return PyObject; pragma Import (C, Internal, "ada_type_new"); C : chars_ptr := New_String (Name); Result : PyObject; begin Result := Internal (Metatype, C, Bases, Dict); Free (C); return Result; end Type_New; --------- -- Name -- ---------- function Name (Obj : PyTypeObject) return String is function Internal (Obj : PyTypeObject) return chars_ptr; pragma Import (C, Internal, "ada_tp_name"); begin return Value (Internal (Obj)); end Name; ------------------------- -- PyObject_IsInstance -- ------------------------- function PyObject_IsInstance (Inst : PyObject; Cls : PyObject) return Boolean is function Internal (Inst, Cls : PyObject) return Integer; pragma Import (C, Internal, "PyObject_IsInstance"); begin return Internal (Inst, Cls) /= 0; end PyObject_IsInstance; --------------------- -- PyObject_IsTrue -- --------------------- function PyObject_IsTrue (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "PyObject_IsTrue"); Val : Integer; begin Val := Internal (Obj); if Val = -1 then return False; -- An error else return Val /= 0; end if; end PyObject_IsTrue; end GNATCOLL.Python; gnatcoll-bindings-25.0.0/python/gnatcoll-python.ads000066400000000000000000001464371464374334300223620ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2003-2020, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ -- Standard interface to the python interpreter. -- This requires at least python 2.3 to be installed on your system. with Ada.Unchecked_Conversion; with Interfaces.C.Strings; with System; package GNATCOLL.Python is procedure Py_Initialize; -- Initialize the python interpreter. You must call Py_SetProgramName first procedure Py_Finalize; -- Finalize the python interpreter procedure Py_SetProgramName (Name : String); -- Set the program name. This must be called before Py_Initialize -- Python also uses the argument to locate its standard library: -- 1- If PYTHONHOME environment variable is set then it points to the -- library location prefix, -- 2- Otherwise, set library prefix to a location relative to program -- called Name. -- 3- If the prefix cannot be found using the previous methods, use -- the value of prefix set by configure during Python build. -- Name should therefore point to the current executable so that if you -- provide your own python installation it gets detected by default. procedure Py_SetPythonHome (Home : String); -- Set the default "home" directory, that is, the location of the standard -- Python libraries. The libraries are searched in Home/lib/pythonversion. ------------- -- Objects -- ------------- type Dummy is limited private; type PyObject is access Dummy; pragma Convention (C, PyObject); type PyObject_Array is array (Natural range <>) of PyObject; function Py_None return PyObject; -- Return the python's variable Py_None, which should be returned by -- procedures. Generally, one need to call Py_INCREF before returning this -- value. type PyCodeObject is new PyObject; type PyFrameObject is new PyObject; procedure Py_INCREF (Obj : PyObject); procedure Py_DECREF (Obj : PyObject); -- Increment or decrement the reference count for Obj. Obj mustn't be null procedure Py_XINCREF (Obj : PyObject); procedure Py_XDECREF (Obj : PyObject); -- Same as above, but Obj can be null procedure Print_Refcount (Obj : PyObject; Msg : String); -- A debug procedure that prints the reference count of the object on -- stdout. function Get_Refcount (Obj : PyObject) return Integer; -- Return the current reference counter for Obj. Used for debug only function PyObject_Str (Obj : PyObject) return PyObject; -- Compute the string representation of Obj. Returns the string -- representation on success, NULL on failure. This is the equivalent of -- the Python expression "str(obj)". -- This is the equivalent of the python call str(obj), and is used by -- python in print statements. -- Returned value must be Py_DECREF function PyObject_Repr (Obj : PyObject) return PyObject; -- Similar to PyObject_Str, ie provides a displayable version of Obj. This -- is the equivalent of the python call repr(obj), and is used by python -- in backquotes. -- Returned value must be Py_DECREF function PyObject_CallMethod (Object : PyObject; Name : String) return PyObject; function PyObject_CallMethod (Object : PyObject; Name : String; Arg1 : PyObject) return PyObject; function PyObject_CallMethod (Object : PyObject; Name : String; Arg1 : Integer) return PyObject; -- A few examples of functions to call a method. -- In C, the profile of this method is: -- PyObject* PyObject_CallMethod -- (PyObject* object, char* name, char* format, ...); -- For instance, to call it with an object and a integer as a parameter, -- you would use: -- result = PyObject_CallMethod (object, "method", "(Oi)", other_obj, 1); -- except that due to ABI differences, you need to use a C wrapper, -- otherwise things will break on e.g. x86_64 -- -- format has the same form as in the calls to Py_BuildValue function PyObject_Call (Object : PyObject; Args : PyObject; Kw : PyObject) return PyObject; -- Call a callable Python object, Object, with -- arguments and keywords arguments. The 'args' argument can not be -- NULL, but the 'kw' argument can be NULL. -- The returned object must be DECREF function PyObject_CallObject (Object : PyObject; Args : PyObject) return PyObject; pragma Import (C, PyObject_CallObject, "PyObject_CallObject"); -- Call a callable Python object, callable_object, with -- arguments given by the tuple, args. If no arguments are -- needed, then args may be NULL. Returns the result of the -- call on success, or NULL on failure. This is the equivalent -- of the Python expression: apply(o,args). function PyObject_SetAttrString (Object : PyObject; Name : Interfaces.C.Strings.chars_ptr; Attr : PyObject) return Integer; pragma Import (C, PyObject_SetAttrString, "PyObject_SetAttrString"); -- Set the value of the attribute named Name, for Object, to the value -- Attr. Returns -1 on failure. This is the equivalent of the Python -- statement "Object.Name = Attr". function PyObject_SetAttrString (Obj : PyObject; Attr_Name : String; Value : PyObject) return Integer; procedure PyObject_SetAttrString (Obj : PyObject; Attr_Name : String; Value : PyObject); -- Same as above function PyObject_GenericSetAttr (Object : PyObject; Name : PyObject; Attr : PyObject) return Integer; pragma Import (C, PyObject_GenericSetAttr, "PyObject_GenericSetAttr"); -- Generic attribute setter that directly interface with the object's -- __dict__, not with its __setattr__ method. -- Name must be decref-ed by the caller. function PyObject_GenericSetAttrString (Object : PyObject; Name : String; Attr : PyObject) return Integer; -- Same as above, but accepts a string as parameter function PyObject_HasAttrString (Obj : PyObject; Attr_Name : String) return Boolean; -- Whether a specific attribute exists for the object function PyObject_GetAttrString (Object : PyObject; Name : Interfaces.C.Strings.chars_ptr) return PyObject; pragma Import (C, PyObject_GetAttrString, "PyObject_GetAttrString"); -- Lookup an attribute in the object's dictionnary. -- The returned object *must* be DECREF. function PyObject_GetAttrString (Object : PyObject; Name : String) return PyObject; -- Same as above. -- The returned object must be DECREF. function PyObject_Dir (Object : PyObject) return PyObject; -- A list of strings for all entries in Object's dictionary.. -- The returned object must be DECREF. function PyObject_IsTrue (Obj : PyObject) return Boolean; -- Returns True if the object, Obj, is considered to be true, False if Obj -- is considered to be false. This is equivalent to the Python expression: -- "not not obj" -------------- -- Integers -- -------------- -- Not bound: PyInt_FromString and PyInt_FromUnicode function PyInt_FromLong (Value : Interfaces.C.long) return PyObject; -- Create a new integer object from its value function PyInt_FromSize_t (Value : Interfaces.C.size_t) return PyObject; -- Create a new integer object from Value function PyInt_AsLong (Int : PyObject) return Interfaces.C.long; -- Return the value of Int. -- Return -1 and set PyErr_Occurred if Int is not an integer object. function PyInt_GetMax return Interfaces.C.long; -- Return the maximum value an integer can have function PyInt_Check (Obj : PyObject) return Boolean; -- Returns true if the Obj is an integer object ------------ -- Floats -- ------------ function PyFloat_AsDouble (Float : PyObject) return Interfaces.C.double; -- Return the value of Float function PyFloat_Check (Obj : PyObject) return Boolean; -- Returns true if the Obj is a float object function PyFloat_FromDouble (Value : Interfaces.C.double) return PyObject; pragma Import (C, PyFloat_FromDouble, "PyFloat_FromDouble"); -- Creates a new float object -------------- -- Booleans -- -------------- -- Support for the "bool" type. However, older versions of python do not -- support this type, so you should also always check for PyInt_Check at -- the same time function PyBool_Check (Obj : PyObject) return Boolean; -- Returns true if Obj is a boolean object function PyBool_Is_True (Obj : PyObject) return Boolean; -- Obj must return True for PyBool_Check. This function returns True if -- obj is True. function PyBool_FromBoolean (Value : Boolean) return PyObject; -- Create a new boolean object ------------ -- Tuples -- ------------ -- The following subprograms are in fact simple examples of importing the C -- function in your C code, depending on your exact requirement. In C, -- these are function with unknown number of parameters -- -- The C function is: -- int PyArg_ParseTuple(PyObject *arg, char *format, ...); function PyArg_ParseTuple (Arg : PyObject; Format : String; Value1 : System.Address) return Boolean; function PyArg_ParseTuple (Arg : PyObject; Format : String; Value1, Value2 : System.Address) return Boolean; function PyArg_ParseTuple (Arg : PyObject; Format : String; Value1, Value2, Value3 : System.Address) return Boolean; function PyArg_ParseTuple (Arg : PyObject; Format : String; Value1, Value2, Value3, Value4 : System.Address) return Boolean; function PyArg_ParseTuple (Arg : PyObject; Format : String; Value1, Value2, Value3, Value4, Value5 : System.Address) return Boolean; -- Parses Format, and stores each of the tuple element in each of the -- Values. The number of elements in Format must be the same as the number -- of Value parameter -- The exact description of the format should be found in the python -- documentation. -- Note: there is *no* type safety in these functions, but then neither is -- there in C. subtype PyTuple is PyObject; function PyTuple_New (Size : Integer) return PyObject; -- Create a new tuple that contains Size elements function PyTuple_GetItem (Tuple : PyTuple; Index : Integer) return PyObject; -- Get the item at a specific location in the tuple, starting at index 0. -- Do not decref returned value. -- See also PyObject_GetItem procedure PyTuple_SetItem (Tuple : PyTuple; Index : Integer; Value : PyObject); -- Set an item in the tuple. The reference counting of Value is not -- increased -- See also PyObject_SetItem function PyTuple_Size (Tuple : PyTuple) return Integer; pragma Obsolescent (PyTuple_Size, "See PyObject_Size instead"); -- Return the size of the tuple function Create_Tuple (Objects : PyObject_Array) return PyObject; -- Return a new tuple made of Objects function PyTuple_Check (Obj : PyObject) return Boolean; -- Whether Object is a tuple ----------- -- Lists -- ----------- function PyList_New (Size : Integer := 0) return PyObject; -- Create a new empty list, with an initialize size function PyList_Append (List : PyObject; Obj : PyObject) return Integer; -- Append Obj at the end of List, and return the index of the newly -- inserted item. -- Increased Obj's refcount function PyList_GetItem (List : PyObject; Index : Integer) return PyObject; pragma Obsolescent (PyList_GetItem, "See PyObject_GetItem instead"); -- Get the item at a specific location in the list, starting at index 0. -- Do not decref the returned value. -- See also PyObject_GetItem. function PyList_Size (List : PyObject) return Integer; pragma Obsolescent (PyList_Size, "See PyObject_Size instead"); -- Return the number of items in the list function PyList_Check (Obj : PyObject) return Boolean; -- True if Obj is a python list --------------- -- Iterators -- --------------- -- Iterators are an extension to list and tuples, and encapsulate both, in -- addition to user-defined types that have a __iter__ method. function PyIter_Check (Obj : PyObject) return Boolean; -- True if object is an iterator (as returned by PyObject_GetIter) function PyObject_GetIter (Obj : PyObject) return PyObject; pragma Import (C, PyObject_GetIter, "PyObject_GetIter"); -- This is equivalent to the Python expression iter(o). It returns a new -- iterator for the object argument, or the object itself if the object is -- already an iterator. Raises TypeError and returns NULL if the object -- cannot be iterated. function PyObject_Size (Obj : PyObject) return Integer; pragma Import (C, PyObject_Size, "PyObject_Size"); -- Return the length of object o. If the object o provides either the -- sequence and mapping protocols, the sequence length is returned. On -- error, -1 is returned. This is the equivalent to the Python expression -- len(o). function PyObject_GetItem (Obj, Key : PyObject) return PyObject; pragma Import (C, PyObject_GetItem, "PyObject_GetItem"); -- Returns a new reference -- Return element of o corresponding to the object key or NULL on failure. -- This is the equivalent of the Python expression o[key]. function PyObject_GetItem (Obj : PyObject; Key : Integer) return PyObject; -- A special case where the key is an integer function PyObject_SetItem (Obj, Key, Value : PyObject) return Integer; pragma Import (C, PyObject_SetItem, "PyObject_SetItem"); -- Map the object key to the value v. Returns -1 on failure. This is the -- equivalent of the Python statement o[key] = v. procedure PyObject_SetItem (Obj : PyObject; Key : Integer; Value : PyObject); -- A special case where the key is an integer function PyIter_Next (Obj : PyObject) return PyObject; pragma Import (C, PyIter_Next, "PyIter_Next"); -- Return the next value from the iteration o. If the object is an -- iterator, this retrieves the next value from the iteration, and returns -- NULL with no exception set if there are no remaining items. If the -- object is not an iterator, TypeError is raised, or if there is an error -- in retrieving the item, returns NULL and passes along the exception. -- -- To write a loop which iterates over an iterator, the code should look -- something like this: -- -- Iterator : PyObject := PyObject_GetIter (Obj); -- Item : PyObject; -- -- if Iterator = null then -- -- propagate error -- else -- loop -- Item := PyIter_Next (Iterator); -- exit when Item = null; -- -- Py_DECREF (Item); -- end loop; -- -- Py_DECREF (Iterator); -- end if; ------------- -- Strings -- ------------- function PyBaseString_Check (Obj : PyObject) return Boolean; -- Returns True if Obj is either a string or a unicode object function PyString_Check (Obj : PyObject) return Boolean; -- Returns true if the Obj is a string object function PyString_AsString (Str : PyObject) return String; -- Same as above, higher-level function PyString_FromString (Str : String) return PyObject; -- Return a python object representing Str function PyUnicode_Check (Obj : PyObject) return Boolean; function PyUnicode_FromString (Str : String) return PyObject; -- A Unicode string, from a latin-1 encoded Ada string function Unicode_AsString (Str : PyObject; Encoding : String := "utf-8") return String; -- Return an encoded version of Str. -- This is not a function from python, but a wrapper around -- PyUnicode_AsEncodedString and PyString_AsString. -- In case of encoding error, characters are replaced with '?' type Unicode_Error_Handling is (Strict, Ignore, Replace); -- How encoding errors are treated for unicode objects -- Strict: raise a ValueError -- Ignore: ignore the wrong characters, which are skipped -- Replace: replace illegal characters with '?' function PyUnicode_AsEncodedString (Unicode : PyObject; -- A unicode object Encoding : String; -- The encoding Errors : Unicode_Error_Handling := Strict) -- Error handling return PyObject; -- Encodes a Unicode object and returns the result as Python string object. -- You can use PyString_AsString to get the corresponding Ada string. ------------- -- Modules -- ------------- function PyImport_AddModule (Module_Name : String) return PyObject; -- Return the module object corresponding to a module name. The name -- argument may be of the form package.module. First check the modules -- dictionary if there's one there, and if not, create a new one and insert -- in in the modules dictionary. Because the former action is most common, -- this does not return a new reference, and you do not own the returned -- reference. -- -- Warning: this function does not load or import the module; if the module -- wasn't already loaded, you will get an empty module object. Use -- PyImport_ImportModule() or one of its variants to import a module. -- Return NULL with an exception set on failure. function PyImport_ImportModule (Module_Name : String) return PyObject; -- Import a new module in the interpreter function PyImport_Import (Name : PyObject) return PyObject; pragma Import (C, PyImport_Import, "PyImport_Import"); -- Higher-level import emulator which emulates the "import" statement -- more accurately -- it invokes the __import__() function from the -- builtins of the current globals. This means that the import is -- done using whatever import hooks are installed in the current -- environment, e.g. by "rexec". -- A dummy list ["__doc__"] is passed as the 4th argument so that -- e.g. PyImport_Import(PyString_FromString("win32com.client.gencache")) -- will return instead of . */ function PyModule_GetDict (Module : PyObject) return PyObject; -- Return the dictionary object that implements module's namespace; this -- object is the same as the __dict__ attribute of the module object. This -- function never fails. -- It is recommended that you use the other PyModule_* subprograms rather -- than manipulate this dictionnary directly. -- The returned dictionary is a borrow reference, so you shouldn't -- Py_DECREF it. function PyModule_New (Module_Name : String) return PyObject; -- Create a new module. -- Use the PyModule_GetDic function to add new objects to the module, or -- better use PyModule_AddObject. function PyModule_AddObject (Module : PyObject; Name : Interfaces.C.Strings.chars_ptr; Object : PyObject) return Integer; pragma Import (C, PyModule_AddObject, "PyModule_AddObject"); -- Add a new object to the module's directory. Object can be a subprogram, -- integer, ... Do not Py_DECREF Object afterward, this is only a borrowed -- reference. -- Return 0 in case of success, -1 in case of error. -- Name can be freed immediately by the caller function PyModule_AddObject (Module : PyObject; Name : String; Object : PyObject) return Integer; -- Same as above function PyModule_Getname (Module : PyObject) return String; -- Return the name of the module ---------------------------------- -- Creating modules and methods -- ---------------------------------- type Argument_Methods is mod 2 ** Integer'Size; METH_VARGS : constant Argument_Methods := 16#0001#; METH_KEYWORDS : constant Argument_Methods := 16#0002#; METH_NOARGS : constant Argument_Methods := 16#0004#; METH_CLASS : constant Argument_Methods := 16#0010#; METH_STATIC : constant Argument_Methods := 16#0020#; -- How arguments are passed to callbacks: -- - METH_VARGS: only positional arguments in the form of a tuple are -- accepted -- - "METH_VARGS or METH_KEYWORDS": a function accepting keyword -- arguments. -- - METH_CLASS and METH_STATIC can only be used for class methods, not -- for module methods. They both indicate that a method is a class-wide -- method. They are callable from the class or an instance, but the -- instance is ignored and not passed as a parameter. type C_Method_Vargs is access function (Self : PyObject; Args : PyObject) return PyObject; pragma Convention (C, C_Method_Vargs); -- A callback for a METH_VARGS method. -- The first argument is the object on which the method is applied, or null -- if this is a standard function. -- The second argument is a tuple of the parameters. They can be extracted -- through a call to PyArg_ParseTuple. type C_Method_Keywords is access function (Self : PyObject; Args : PyObject; Kwargs : PyObject) return PyObject; pragma Convention (C, C_Method_Keywords); -- A callback for a METH_KEYWORDS method. -- The first argument is the object on which the method is applied, or null -- if this is a standard function. -- The second argument is a tuple of the positional parameters. -- The third argument is a hash table of the named parameters. -- Parameters can be extracted through a call to -- PyArg_ParseTupleAndKeywords. type C_Callback_Record is private; type C_Callback is access C_Callback_Record; pragma Convention (C, C_Callback); -- The exact type doesn't matter, we only want to cover all possible cases -- of callbacks (C_Method_Vargs, C_Method_Keywords) function To_Callback is new Standard.Ada.Unchecked_Conversion (C_Method_Vargs, C_Callback); function To_Callback is new Standard.Ada.Unchecked_Conversion (C_Method_Keywords, C_Callback); type PyMethodDef is record Name : Interfaces.C.Strings.chars_ptr; Func : C_Callback; Flags : Argument_Methods; Doc : Interfaces.C.Strings.chars_ptr; end record; pragma Convention (C, PyMethodDef); -- Definition for one of the methods of an object. -- Name is the name used in the python interpreter to reference the method -- (one would use the syntax self.Name (...)) -- Func is the callback in the Ada code that should be called when the -- method is invoked. -- Flags indicates how the arguments should be passed. -- Doc is the optional documentation string for the method No_MethodDef : constant PyMethodDef; type PyMethodDef_Array is array (Natural range <>) of PyMethodDef; pragma Convention (C, PyMethodDef_Array); -- The full list of methods supported by a type. -- You do not need to terminate this array by a null element, as is done in -- C. This is automatically taken care of by Ada. No_MethodDef_Array : constant PyMethodDef_Array; procedure Free (Method : in out PyMethodDef); procedure Free (Methods : in out PyMethodDef_Array); -- Free the memory occupied by Method function Py_InitModule (Module_Name : String; Methods : PyMethodDef_Array := No_MethodDef_Array; Doc : String := "") return PyObject; -- Create and initialize a new module, with a set of predefined methods. -- Do not free Methods while the module is in use. -- The module is not visible in the interpreter until you have done a -- "import MODULE_NAME" in the interpreter. -- -- The first parameter to the methods declared in Methods will be null. procedure Add_Function (Module : PyObject; Func : PyMethodDef; Self : PyObject := null); -- Add a new function to Module. -- Do not free Func while this function is registered. -- The first parameter to Func will be Self (defaults to Module if Self is -- null). ------------------ -- Dictionaries -- ------------------ -- Dictionaries are hash tables, used internally by python to associate -- functions with modules or methods with objects. -- See PyModule_GetDict to see how to get the dictionary from a module. subtype PyDictObject is PyObject; function PyDict_Check (Obj : PyObject) return Boolean; -- Return True if Obj is a dict object or an instance of a subtype of the -- dict type. function PyDict_New return PyDictObject; -- Create a new empty dictionary function PyDict_Contains (Dict : PyDictObject; Key : PyObject) return Boolean; -- Determine if dictionary contains key function PyDict_SetItemString (Dict : PyDictObject; Key : Interfaces.C.Strings.chars_ptr; Obj : PyObject) return Integer; pragma Import (C, PyDict_SetItemString, "PyDict_SetItemString"); -- Store a new object in Dict. Obj should be Py_DECREF after the call. -- Return 0 if all went well, -1 otherwise -- Key should be deallocated. procedure PyDict_SetItemString (Dict : PyDictObject; Key : String; Obj : PyObject); -- Same as above. Refcounting for Obj is automatically increased, you do -- not need to do it yourself. function PyDict_SetItem (Dict : PyDictObject; Key : PyObject; Value : PyObject) return Integer; -- Add a new item to the dictionary. -- Key and Value should be Py_DECREF'ed after this call. -- Return 0 if all went well, -1 otherwise function PyDict_GetItemString (Dict : PyDictObject; Key : Interfaces.C.Strings.chars_ptr) return PyObject; pragma Import (C, PyDict_GetItemString, "PyDict_GetItemString"); -- Get an object from a dictionary. Do not decref the returned value function PyDict_GetItemString (Dict : PyDictObject; Key : String) return PyObject; -- Same as above function PyDict_GetItem (Dict : PyDictObject; Key : PyObject) return PyObject; -- Same as above procedure PyDict_Next (Dict : PyObject; Pos : in out Integer; Key : out PyObject; Value : out PyObject); -- Starting with Pos = 0, this traverses all items in Dict. -- When there are no more items, Pos is set to -1. -- It isn't safe to use this in a loop that modifies Dict. function PyDict_Size (Dict : PyObject) return Integer; -- Return the number of elements in Dict ---------- -- Sets -- ---------- -- A set object is an unordered collection of distinct hashable objects. -- Common uses include membership testing, removing duplicates from a -- sequence, and computing mathematical operations such as intersection, -- union, difference, and symmetric difference. function PyAnySet_Check (Obj : PyObject) return Boolean; -- Return true if p is a set object, a frozenset object, or an instance of -- a subtype. --------------- -- Functions -- --------------- function PyFunction_Check (Func : PyObject) return Boolean; -- Whether Func is a function object function PyFunction_Get_Code (Func : PyObject) return PyCodeObject; -- Return the code of the function (see PyEval_EvalCodeEx). -- Refcount for the code is not increased. function PyFunction_Get_Globals (Func : PyObject) return PyObject; -- Return the globals dictionary the function belongs to function PyFunction_Get_Defaults (Func : PyObject) return PyObject; -- Return a tuple of the default values for all the parameters of Func function PyFunction_Get_Closure (Func : PyObject) return PyObject; -- ??? function PyCallable_Check (Func : PyObject) return Boolean; -- Determine if the object o is callable. This function always succeeds ------------------ -- Object types -- ------------------ subtype PyTypeObject is PyObject; -- The internal structure that describes a Python type (and all the default -- primitive subprograms like __getattr__, __setattr__, ... function GetTypeObject (Obj : PyObject) return PyTypeObject; -- Return the type object that describes the class Obj belongs to function Name (Obj : PyTypeObject) return String; -- Name of type, useful for printing, in format "." function Type_New (Name : String; Bases : PyTuple; Dict : PyObject; Metatype : PyTypeObject := null) return PyObject; -- Creates a so called new-style class in python. -- Such classes have a metaclass (ie their type) that is "type" or one of -- its ancestors. Their provide a number of advantages over older classes: -- - it is possible to extend builtin types such as "list" or "tuple" -- - support for the "super" function, to provide collaborative multiple -- inheritance -- - support for properties (ie fields manipulated through setters and -- getters) -- - better Method Resolution Order, more compatible with multiple -- inheritance. -- See the original paper at -- http://www.python.org/download/releases/2.2.3/descrintro -- -- This replaces the older PyClass_New. -- This isn't a standard python function, but is specific to Ada. If the -- Metatype is not specified, it will default to "type", although depending -- on the list of base classes you provide, python might decide to use -- another metaclass. -- This function is similar to calling the "type()" function from within -- python: -- A = type ("Name", (list,), {}); -- which creates a new class Name deriving from "list". -- -- Dict can contain any number of things (including for instance the list -- of methods for the class, although you can add some later), just as if -- you were defining the class in Python: -- - "__slots__" -- - "__module__" (although that is set automatically otherwise) -- - "__doc__" function PyObject_IsInstance (Inst : PyObject; Cls : PyObject) return Boolean; -- Return if the metaclass of Inst is Cls (ie Inst was created with -- something like "Inst = Cls (...)" ---------------- -- Exceptions -- ---------------- procedure PyErr_Print; -- Print the current exception and its traceback to sys.stderr. -- This also clears the error indicator. -- Call this procedure only if the error indicator is set procedure PyErr_SetInterrupt; -- Interrupt the current command in the interpreter. This is the equivalent -- of Control-C in a terminal executing python. procedure PyErr_Fetch (EType : out PyObject; Occurrence : out PyObject; Traceback : out PyObject); -- Get the current exception information. -- Occurrence is a tuple, made of the following information: -- (msg, ('input_stream_name', line, column, input_text)) -- where msg is the exception's message, and the second tuple is the -- location where the exception occurred. -- EType is the type of the exception, like "exceptions.SyntaxError". -- -- This calls clears the current exception. If you want to call PyErr_Print -- later on, you will need to call PyErr_Restore with the same parameters -- to restore the current exception. procedure PyErr_NormalizeException (EType : in out PyObject; Occurrence : in out PyObject; Traceback : in out PyObject); -- Normalize a raised exception. This generally needs to be called after -- PyErr_Fetch. -- This ensure that if EType is an class, Occurrence is an instance. procedure PyErr_Restore (EType : PyObject; Occurrence : PyObject; Traceback : PyObject); -- Set the current exception procedure PyErr_Clear; -- Clear the current exception. This must be called at the end of your -- exception handlers, although it is called automatically by PyErr_Print procedure PyErr_BadArgument; -- Set the current exception as a "bad argument" exception. The function -- should also return null to its caller. function PyErr_Occurred return PyObject; -- Return the current exception, or null if no exception was raised function PyErr_NewException (Name : String; Base : PyObject := null; Dict : PyObject := null) return PyObject; -- Create a new exception, which can then be raised by: -- - calling PyErr_SetString (Except, "message"); -- - returning null from your subprogram -- Name must be of the form "module.name" procedure PyErr_SetString (Except : PyObject; Msg : String); -- Raise Except, and associate it with a specific message --------- -- Sys -- --------- procedure PySys_SetObject (Name : String; Object : PyObject); -- Set one of the predefined objects in the python interpreter. See the -- module "sys". -- Among these objects are: -- - "stdin", "stdout", "stderr": standard file objects -- - "_stdin", _stdout", "_stderr": initial values for standard files -- - "modules": dictionary of modules -- - "path": module search path -- - "ps1", "ps2": prompts -- - "displayhook": ??? -- - "excepthook": ??? function PySys_GetObject (Name : String) return PyObject; -- Return an object from the sys module, -- Returned object must not be Py_DECREF by the caller. ----------- -- Files -- ----------- function PyFile_WriteString (Text : String; File : PyObject) return Boolean; -- Write a string to an instance of file. You can for instance get such an -- instance by using -- PySys_GetObject ("stdout") -- Return False if the string couldn't be written function PyFile_FromString (File_Name, Mode : String) return PyObject; -- Create an instance of file. ----------------- -- Class types -- ----------------- function Lookup_Object (Module : String; Name : String) return PyObject; function Lookup_Object (Module : PyObject; Name : String) return PyObject; -- Lookup an object in the module. -- Typical use is -- Obj := Lookup_Class_Object ("__builtin__", "file"); -- null is returned if the class is not found. -- The second version is slightly faster and should be used when you -- already have a handle to the module procedure Add_Method (Class : PyObject; Func : PyMethodDef; Self : PyObject := null; Module : PyObject); -- Add a new method to the class. -- The method is an instance method. -- When the method is called from the python interpreter, its Self argument -- is set to the value of Self. -- Its first argument will always be the instance itself. Therefore the -- first character in the argument to PyArg_ParseTuple should be "O". procedure Add_Static_Method (Class : PyObject; Func : PyMethodDef; Self : PyObject := null; Module : PyObject); -- Return a static version of Method. This method doesn't receive an -- instance or the class as its first parameter. This is similar to C++ or -- Java's static methods. -- If no documentation is set for the method, it will be set to the fully -- qualified name of the method, since otherwise there is no way from the -- GPS shell to get access to the class to which the method belongs. procedure Add_Class_Method (Class : PyObject; Func : PyMethodDef; Module : PyObject); -- Return a class version of Method. -- This is a method that receives the class as implicit first argument, -- just like an instance method receives the instance. -- It can be called either on the class or an instance. If a class method -- is called for a derived class, the derived class object is passed as the -- implied first argument. -- If no documentation is set for the method, it will be set to the fully -- qualified name of the method, since otherwise there is no way from the -- GPS shell to get access to the class to which the method belongs. function Py_IsSubclass (Class : PyObject; Base : PyObject) return Boolean; -- True if Class is a subclass of Base (or Base itself) function PyMethod_Check (Obj : PyObject) return Boolean; -- Whether Obj is a method of a class function PyMethod_Self (Obj : PyObject) return PyObject; -- Return the instance with which the method is bound. This might be null -- if we have an unbound class method (Class.method), or non-null if we -- have a bound class method (the result of self.method) -- Returns a borrowed reference, no need to Py_DECREF function PyMethod_Function (Obj : PyObject) return PyObject; -- Return the function object associated with the method. That is the code -- that is actually executed when the method is called ----------------- -- Descriptors -- ----------------- -- Descriptors are an advanced feature of python, used as the underlying -- capability for bounded methods, properties,... -- Basically, when a field in an instance is a descriptor, its value is -- read from a Getter, instead of directly. Likewise it is set through a -- Setter. type C_Getter is access function (Obj : PyObject; Closure : System.Address) return PyObject; pragma Convention (C, C_Getter); type C_Setter is access function (Obj : PyObject; Prop : PyObject; Closure : System.Address) return Integer; pragma Convention (C, C_Setter); -- Closure is some custom data you have specified in the call to -- Create_GetSetDef function PyDescr_NewGetSet (Typ : PyObject; Name : String; Setter : C_Setter := null; Getter : C_Getter := null; Doc : String := ""; Closure : System.Address := System.Null_Address) return Boolean; -- Register a new property (accessed through setters and getters) in the -- specified Typ. The property is immediately added to the dictionary. -- False is returned if the property could not be added. -- The Closure will be passed as is to Setter and Getter. ------------------------------------ -- Creating and declaring methods -- ------------------------------------ function Create_Method_Def (Name : String; Func : C_Method_Vargs; Doc : String := "") return PyMethodDef; -- Convenience function to create method definitions. -- See the description of the parameters in the declaration of PyMethodDef -- The flags are automatically set to METH_VARGS, which is the appropriate -- type for callbacks of this form. -- The returned value must be freed by the caller. function Create_Method_Def (Name : String; Func : C_Method_Keywords; Doc : String := "") return PyMethodDef; -- Same as above, for methods accepting keywords. -- The returned value must be freed by the caller ------------------------ -- Executing commands -- ------------------------ function PyRun_SimpleString (Cmd : String) return Boolean; -- Executes Cmd in the __main__ module. -- Return True on success, False if an exception occurred (it is your -- responsibility to check the current exception) type Interpreter_State is private; Py_Single_Input : constant Interpreter_State; Py_File_Input : constant Interpreter_State; Py_Eval_Input : constant Interpreter_State; -- The state of the interpreter when evaluating a string. -- - Single_Input: evaluate any command in the interpreter. This will -- print the result (but return None) -- - Eval_Input: evaluate an expression. Evaluates an expression. -- Equivalent to 'eval'. -- - File_Input: evaluate a whole file, and return None. -- Equivalent to 'exec'. function PyRun_String (Str : String; Start : Interpreter_State; Globals : PyObject; Locals : PyObject) return PyObject; -- Execute Python source code from str in the context specified by the -- dictionaries globals and locals. The parameter start specifies the -- start token that should be used to parse the source code. -- -- Returns NULL if an exception occurred, None otherwise. function Py_CompileString (Cmd : String; Name : String; State : Interpreter_State) return PyCodeObject; -- Compile Cmd into a code object. Null is returned if Cmd couldn't be -- compiled, either because of a syntax error or because Cmd is incomplete function PyEval_GetGlobals return PyObject; pragma Import (C, PyEval_GetGlobals, "PyEval_GetGlobals"); -- Return the dictionary for global variables function PyEval_EvalCode (Code : PyCodeObject; Globals : PyObject; Locals : PyObject) return PyObject; -- Evaluate a precompiled code object function PyEval_EvalCodeEx (Code : PyCodeObject; Globals : PyObject; Locals : PyObject; Args : PyTuple := null; Kwds : PyDictObject := null; Defaults : PyTuple := null; Closure : PyObject := null) return PyObject; -- Evaluate a precompiled code object. This is mostly used to execute a -- function (get its code with PyFunction_Get_Code), specifying some of -- the parameters function Py_Main return Integer; -- Run the python interpreter main program -------------------------------------- -- Evaluating and Tracing execution -- -------------------------------------- -- Python will periodically call two functions that you can register: a -- profile function, called every time a subprogram is called or returns, -- and a trace function called for every instruction. -- These can be used to trace the execution of your program, but also to -- interrupt a parser embedded in your application: -- - register a trace function, and every n calls, check for gtk events -- and call PyErr_SetInterrupt if necessary -- - a profile function would not be called for an infinite loop that -- never calls another subprogram, so is not appropriate for for such -- usage. -- There is still a catch: you will not be able to interrupt a long sleep() -- operation with this method, since the interpret itself is paused. The -- best solution to handle this is to have your own Control-C handler, -- although the user would have to type this in the terminal used to start -- your application. type Why_Trace_Func is private; PyTrace_Call : constant Why_Trace_Func; PyTrace_Exception : constant Why_Trace_Func; PyTrace_Line : constant Why_Trace_Func; PyTrace_Return : constant Why_Trace_Func; PyTrace_C_Call : constant Why_Trace_Func; PyTrace_C_Exception : constant Why_Trace_Func; PyTrace_C_Return : constant Why_Trace_Func; type Py_Trace_Func is access function (User_Arg : PyObject; Frame : PyFrameObject; Why : Why_Trace_Func; Object : PyObject) return Integer; -- Return 0 in case of success, or -1 if an exception is raised. -- Objects's value depends on the type of callback. For PyTrace_Return, -- this is the returned value. For PyTrace_Exception, this is the -- exception. PyTrace_Line is called for all instructions, but only for -- the trace function, not the profile function. procedure PyEval_SetProfile (Proc : Py_Trace_Func; User_Arg : PyObject); -- Register a new profiling function procedure PyEval_SetTrace (Proc : Py_Trace_Func; User_Arg : PyObject); -- Register a new tracing function function PyFrame_GetLineNumber (Frame : PyFrameObject) return Integer; -- Return the line number that frame is currently executing. function PyFrame_Get_Code (Frame : PyFrameObject) return PyCodeObject; -- Return code object associated with the frame. -- Returns a borrowed reference, no need to Py_DECREF function PyCode_Get_Filename (Code : PyCodeObject) return PyObject; -- Return file name of the code object. -- Returns a borrowed reference, no need to Py_DECREF function PyCode_Get_Name (Code : PyCodeObject) return PyObject; -- Return function name of the code object. -- Returns a borrowed reference, no need to Py_DECREF function PyFrame_Get_Back (Frame : PyFrameObject) return PyFrameObject; -- Return previous frame in stack. -- Returns a borrowed reference, no need to Py_DECREF ------------------------------------- -- Embedding Ada objects in python -- ------------------------------------- subtype PyCObject is PyObject; -- This type represents an opaque value that contains any kind of data, -- transparent for python. function PyCObject_Check (Obj : PyObject) return Boolean; -- Return True if Obj is a Py_CObject type PyCObject_Destructor is access procedure (Obj : System.Address); pragma Convention (C, PyCObject_Destructor); type PyCObject_Destructor2 is access procedure (Obj : System.Address; Desc : System.Address); pragma Convention (C, PyCObject_Destructor2); function PyCObject_FromVoidPtr (Obj : System.Address; Destr : PyCObject_Destructor := null) return PyObject; -- Create a new PyCObject that encapsulate Obj. Destr is called when the -- object is reclaimed, unless it is null. -- Returns a newly referenced object. function PyCObject_FromVoidPtrAndDesc (Obj : System.Address; Desc : System.Address; Destr : PyCObject_Destructor2 := null) return PyObject; -- Same as above, except Desc is also passed to Destr function PyCObject_AsVoidPtr (Self : PyObject) return System.Address; -- Return the Ada object embedded in Self function PyCObject_GetDesc (Self : PyObject) return System.Address; -- Return the Desc object that Self was created with, or null private type Dummy is null record; type Interpreter_State is new Integer; Py_Single_Input : constant Interpreter_State := 256; Py_File_Input : constant Interpreter_State := 257; Py_Eval_Input : constant Interpreter_State := 258; -- Values are copied from Python.h, and must be synchronized. They will -- probably never change, though, so this should be safe. type Why_Trace_Func is new Integer; PyTrace_Call : constant Why_Trace_Func := 0; PyTrace_Exception : constant Why_Trace_Func := 1; PyTrace_Line : constant Why_Trace_Func := 2; PyTrace_Return : constant Why_Trace_Func := 3; PyTrace_C_Call : constant Why_Trace_Func := 4; PyTrace_C_Exception : constant Why_Trace_Func := 5; PyTrace_C_Return : constant Why_Trace_Func := 6; type C_Callback_Record is new Integer; -- whatever No_MethodDef : constant PyMethodDef := (Interfaces.C.Strings.Null_Ptr, null, 0, Interfaces.C.Strings.Null_Ptr); No_MethodDef_Array : constant PyMethodDef_Array := (1 .. 0 => No_MethodDef); pragma Convention (C, Py_Trace_Func); pragma Import (C, PyDict_New, "PyDict_New"); pragma Import (C, PyEval_SetProfile, "PyEval_SetProfile"); pragma Import (C, PyEval_SetTrace, "PyEval_SetTrace"); pragma Inline (PyImport_AddModule); pragma Inline (PyRun_SimpleString); pragma Inline (PyArg_ParseTuple); pragma Inline (PyString_Check); pragma Inline (PyUnicode_Check); pragma Inline (PyInt_Check); pragma Inline (PyFloat_Check); pragma Import (C, Py_Initialize, "Py_Initialize"); pragma Import (C, Py_Finalize, "Py_Finalize"); pragma Import (C, PyModule_GetDict, "PyModule_GetDict"); pragma Import (C, Py_INCREF, "ada_py_incref"); pragma Import (C, Py_DECREF, "ada_py_decref"); pragma Import (C, Py_XINCREF, "ada_py_xincref"); pragma Import (C, Py_XDECREF, "ada_py_xdecref"); pragma Import (C, PyErr_Print, "PyErr_Print"); pragma Import (C, PyObject_Str, "PyObject_Str"); pragma Import (C, PyObject_Call, "PyObject_Call"); pragma Import (C, PyEval_EvalCode, "PyEval_EvalCode"); pragma Import (C, PyEval_EvalCodeEx, "ada_PyEval_EvalCodeEx"); pragma Import (C, PyErr_SetInterrupt, "PyErr_SetInterrupt"); pragma Import (C, PyTuple_New, "PyTuple_New"); pragma Import (C, PyTuple_GetItem, "PyTuple_GetItem"); pragma Import (C, PyTuple_SetItem, "PyTuple_SetItem"); pragma Import (C, Py_None, "ada_py_none"); pragma Import (C, PyErr_Clear, "PyErr_Clear"); pragma Import (C, PyErr_Fetch, "PyErr_Fetch"); pragma Import (C, PyTuple_Size, "PyTuple_Size"); pragma Import (C, PyInt_FromLong, "PyInt_FromLong"); pragma Import (C, PyInt_FromSize_t, "PyInt_FromSize_t"); pragma Import (C, PyInt_AsLong, "PyInt_AsLong"); pragma Import (C, PyFloat_AsDouble, "PyFloat_AsDouble"); pragma Import (C, PyInt_GetMax, "PyInt_GetMax"); pragma Import (C, PyErr_Occurred, "PyErr_Occurred"); pragma Import (C, PyList_New, "PyList_New"); pragma Import (C, PyList_Append, "PyList_Append"); pragma Import (C, PyErr_BadArgument, "PyErr_BadArgument"); pragma Import (C, PyErr_NormalizeException, "PyErr_NormalizeException"); pragma Import (C, PyObject_Dir, "PyObject_Dir"); pragma Import (C, PyObject_Repr, "PyObject_Repr"); pragma Import (C, PyErr_Restore, "PyErr_Restore"); pragma Import (C, PyDict_Size, "PyDict_Size"); pragma Import (C, PyList_GetItem, "PyList_GetItem"); pragma Import (C, PyList_Size, "PyList_Size"); pragma Import (C, PyDict_SetItem, "PyDict_SetItem"); pragma Import (C, PyDict_GetItem, "PyDict_GetItem"); pragma Import (C, Get_Refcount, "ada_pyget_refcount"); pragma Import (C, PyFunction_Get_Code, "ada_pyfunction_get_code"); pragma Import (C, PyFunction_Get_Globals, "ada_pyfunction_get_globals"); pragma Import (C, PyFunction_Get_Closure, "ada_pyfunction_get_closure"); pragma Import (C, PyFunction_Get_Defaults, "ada_pyfunction_get_defaults"); pragma Import (C, GetTypeObject, "ada_gettypeobject"); pragma Inline (PyCObject_Check); pragma Import (C, PyCObject_FromVoidPtr, "PyCObject_FromVoidPtr"); pragma Import (C, PyCObject_FromVoidPtrAndDesc, "PyCObject_FromVoidPtrAndDesc"); pragma Import (C, PyCObject_AsVoidPtr, "PyCObject_AsVoidPtr"); pragma Import (C, PyCObject_GetDesc, "PyCObject_GetDesc"); pragma Import (C, PyMethod_Function, "PyMethod_Function"); pragma Import (C, PyMethod_Self, "PyMethod_Self"); pragma Import (C, PyFrame_GetLineNumber, "PyFrame_GetLineNumber"); pragma Import (C, PyFrame_Get_Code, "ada_pyframe_get_code"); pragma Import (C, PyFrame_Get_Back, "ada_pyframe_get_back"); pragma Import (C, PyCode_Get_Filename, "ada_pycode_get_filename"); pragma Import (C, PyCode_Get_Name, "ada_pycode_get_name"); end GNATCOLL.Python; gnatcoll-bindings-25.0.0/python/gnatcoll-scripts-python.adb000066400000000000000000004325211464374334300240160ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2003-2021, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Exceptions; use Ada.Exceptions; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with Ada.Unchecked_Conversion; with Ada.Unchecked_Deallocation; with Interfaces.C.Strings; use Interfaces.C, Interfaces.C.Strings; with GNAT.IO; use GNAT.IO; with GNAT.Strings; use GNAT.Strings; with GNATCOLL.Any_Types.Python; with GNATCOLL.Python.State; use GNATCOLL.Python.State; with GNATCOLL.Scripts.Impl; use GNATCOLL.Scripts, GNATCOLL.Scripts.Impl; with GNATCOLL.Traces; use GNATCOLL.Traces; with System; use System; with System.Storage_Elements; use System.Storage_Elements; package body GNATCOLL.Scripts.Python is Me : constant Trace_Handle := Create ("PYTHON"); Me_Error : constant Trace_Handle := Create ("PYTHON.ERROR", On); Me_Stack : constant Trace_Handle := Create ("PYTHON.TB", Off); Me_Log : constant Trace_Handle := Create ("SCRIPTS.LOG", Off); Me_Crash : constant Trace_Handle := Create ("PYTHON.TRACECRASH", On); Finalized : Boolean := True; -- Whether Python has been finalized (or never initialized). function Ada_Py_Builtin return Interfaces.C.Strings.chars_ptr; pragma Import (C, Ada_Py_Builtin, "ada_py_builtin"); function Ada_Py_Builtins return Interfaces.C.Strings.chars_ptr; pragma Import (C, Ada_Py_Builtins, "ada_py_builtins"); function Ada_Is_Python3 return Integer; pragma Import (C, Ada_Is_Python3, "ada_is_python3"); Is_Python3 : constant Boolean := Ada_Is_Python3 = 1; Builtin_Name : constant String := Value (Ada_Py_Builtin); Builtins_Name : constant String := Value (Ada_Py_Builtins); procedure Set_Item (Args : PyObject; T : Integer; Item : PyObject); -- Change the T-th item in Args. -- This increases the refcount of Item procedure Name_Parameters (Data : in out Python_Callback_Data; Params : Param_Array); -- Internal version of Name_Parameters type Property_User_Data_Record is record Script : Python_Scripting; Prop : Property_Descr_Access; end record; type Property_User_Data is access all Property_User_Data_Record; function Convert is new Ada.Unchecked_Conversion (System.Address, Property_User_Data); function Convert is new Ada.Unchecked_Conversion (Property_User_Data, System.Address); -- Subprograms needed to support the user data passed to the Property -- setters and getters procedure Run_Callback (Script : Python_Scripting; Cmd : Module_Command_Function; Command : String; Data : in out Python_Callback_Data'Class; Result : out PyObject); -- Return Cmd and pass (Data, Command) parameters to it. -- This properly handles returned value, exceptions and python errors. -- This also freed the memory used by Data ------------------------ -- Python_Subprograms -- ------------------------ type Python_Subprogram_Record is new Subprogram_Record with record Script : Python_Scripting; Subprogram : PyObject; end record; overriding function Execute (Subprogram : access Python_Subprogram_Record; Args : Callback_Data'Class; Error : not null access Boolean) return Boolean; overriding function Execute (Subprogram : access Python_Subprogram_Record; Args : Callback_Data'Class; Error : not null access Boolean) return String; overriding function Execute (Subprogram : access Python_Subprogram_Record; Args : Callback_Data'Class; Error : not null access Boolean) return Any_Type; overriding function Execute (Subprogram : access Python_Subprogram_Record; Args : Callback_Data'Class; Error : not null access Boolean) return Class_Instance; overriding function Execute (Subprogram : access Python_Subprogram_Record; Args : Callback_Data'Class; Error : not null access Boolean) return GNAT.Strings.String_List; overriding function Execute (Subprogram : access Python_Subprogram_Record; Args : Callback_Data'Class; Error : not null access Boolean) return List_Instance'Class; overriding procedure Free (Subprogram : in out Python_Subprogram_Record); overriding function Get_Name (Subprogram : access Python_Subprogram_Record) return String; overriding function Get_Script (Subprogram : Python_Subprogram_Record) return Scripting_Language; -- See doc from inherited subprograms -------------------------- -- Python_Callback_Data -- -------------------------- procedure Prepare_Value_Key (Data : in out Python_Callback_Data'Class; Key : PyObject; Append : Boolean); -- Internal version of Set_Return_Value_Key --------------------------- -- Python_Class_Instance -- --------------------------- type Python_Class_Instance_Record is new Class_Instance_Record with record Data : PyObject; end record; type Python_Class_Instance is access all Python_Class_Instance_Record'Class; overriding procedure Free (Self : in out Python_Class_Instance_Record); overriding function Get_User_Data (Inst : not null access Python_Class_Instance_Record) return access User_Data_List; overriding function Print_Refcount (Instance : access Python_Class_Instance_Record) return String; overriding function Is_Subclass (Instance : access Python_Class_Instance_Record; Base : String) return Boolean; overriding procedure Set_Property (Instance : access Python_Class_Instance_Record; Name : String; Value : Integer); overriding procedure Set_Property (Instance : access Python_Class_Instance_Record; Name : String; Value : Boolean); overriding procedure Set_Property (Instance : access Python_Class_Instance_Record; Name : String; Value : Float); overriding procedure Set_Property (Instance : access Python_Class_Instance_Record; Name : String; Value : String); overriding function Get_Method (Instance : access Python_Class_Instance_Record; Name : String) return Subprogram_Type; -- See doc from inherited subprogram function Get_CI (Script : Python_Scripting; Object : PyObject) return Class_Instance; -- Wraps the python object into a Class_Instance. -- The refcount of the object is increased by one, owned by Class_Instance. ------------------ -- Handler_Data -- ------------------ type Handler_Data is record Script : Python_Scripting; Cmd : Command_Descr_Access; end record; type Handler_Data_Access is access Handler_Data; -- Information stored with each python function to call the right Ada -- subprogram. function Command_Name (Data : Handler_Data) return String; -- Return the qualified name of the command "command" or "class.command" function Convert is new Ada.Unchecked_Conversion (System.Address, Handler_Data_Access); procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Handler_Data, Handler_Data_Access); procedure Destroy_Handler_Data (Handler : System.Address); pragma Convention (C, Destroy_Handler_Data); -- Called when the python object associated with Handler is destroyed ------------------------------- -- Class_Instance properties -- ------------------------------- type PyObject_Data_Record is record Props : aliased User_Data_List; end record; type PyObject_Data is access all PyObject_Data_Record; -- Data stored in each PyObject representing a class instance, as a -- __gps_data property. function Convert is new Ada.Unchecked_Conversion (System.Address, PyObject_Data); procedure Unchecked_Free is new Ada.Unchecked_Deallocation (PyObject_Data_Record, PyObject_Data); procedure On_PyObject_Data_Destroy (Data : System.Address); pragma Convention (C, On_PyObject_Data_Destroy); -- Called when the __gps_data property is destroyed. ---------------------- -- Interpreter_View -- ---------------------- function First_Level (Self, Args, Kw : PyObject) return PyObject; pragma Convention (C, First_Level); -- First level handler for all functions exported to python. This function -- is in charge of dispatching to the actual Ada subprogram. procedure Setup_Return_Value (Data : in out Python_Callback_Data'Class); -- Mark Data as containing a return value, and free the previous value if -- there is any function First_Level_Getter (Obj : PyObject; Closure : System.Address) return PyObject; pragma Convention (C, First_Level_Getter); -- Handles getters for descriptor objects function First_Level_Setter (Obj, Value : PyObject; Closure : System.Address) return Integer; pragma Convention (C, First_Level_Setter); -- Handles setters for descriptor objects procedure Trace_Dump (Name : String; Obj : PyObject); pragma Unreferenced (Trace_Dump); -- Print debug info for Obj function Refcount_Msg (Obj : PyObject) return Interfaces.C.Strings.chars_ptr; pragma Import (C, Refcount_Msg, "ada_py_refcount_msg"); -- Print a debug message to trace the refcounting on Obj function Run_Command (Script : access Python_Scripting_Record'Class; Command : String; Console : Virtual_Console := null; Show_Command : Boolean := False; Hide_Output : Boolean := False; Hide_Exceptions : Boolean := False; Errors : access Boolean) return String; -- Same as above, but also return the output of the command procedure Python_Global_Command_Handler (Data : in out Callback_Data'Class; Command : String); -- Handles all commands pre-defined in this module procedure Log_Python_Exception; -- Log the current exception to a trace_handle ------------------------ -- Internals Nth_Arg -- ------------------------ function Nth_Arg (Data : Python_Callback_Data; N : Positive; Success : access Boolean) return String; function Nth_Arg (Data : Python_Callback_Data; N : Positive; Success : access Boolean) return Unbounded_String; function Nth_Arg (Data : Python_Callback_Data; N : Positive; Success : access Boolean) return Integer; function Nth_Arg (Data : Python_Callback_Data; N : Positive; Success : access Boolean) return Float; function Nth_Arg (Data : Python_Callback_Data; N : Positive; Success : access Boolean) return Boolean; function Nth_Arg (Data : Python_Callback_Data; N : Positive; Success : access Boolean) return Subprogram_Type; function Nth_Arg (Data : Python_Callback_Data; N : Positive; Class : Class_Type; Allow_Null : Boolean; Success : access Boolean) return Class_Instance; -- These functions are called by the overridden Nth_Arg functions. They try -- to return the parameter at the location N. If no parameter is found, -- Success is false, true otherwise. It's the responsibility of the -- enclosing Nth_Arg to either raise a No_Such_Parameter exception or to -- return a default value. ------------- -- Modules -- ------------- function Lookup_Module (Self : not null access Python_Scripting_Record'Class; Name : String) return PyObject; -- Return the module object. function Lookup_Object (Self : not null access Python_Scripting_Record'Class; Qualified_Name : String) return PyObject; -- Lookup an object from its fully qualified name (module.module.name). -- If there is no module specified, the object is looked for in the default -- module, or the builtins. ------------------ -- Dictionaries -- ------------------ type Python_Dictionary_Instance is new Dictionary_Instance with record Script : Python_Scripting; Dict : PyObject; end record; function Iterator (Self : Python_Dictionary_Instance) return Dictionary_Iterator'Class; -- Returns iterator for given dictionary function Has_Key (Self : Python_Dictionary_Instance; Key : String) return Boolean; function Has_Key (Self : Python_Dictionary_Instance; Key : Integer) return Boolean; function Has_Key (Self : Python_Dictionary_Instance; Key : Float) return Boolean; function Has_Key (Self : Python_Dictionary_Instance; Key : Boolean) return Boolean; -- Returns True when dictionary has value for given key function Value (Self : Python_Dictionary_Instance; Key : String) return String; function Value (Self : Python_Dictionary_Instance; Key : Integer) return String; function Value (Self : Python_Dictionary_Instance; Key : Float) return String; function Value (Self : Python_Dictionary_Instance; Key : Boolean) return String; function Value (Self : Python_Dictionary_Instance; Key : String) return Integer; function Value (Self : Python_Dictionary_Instance; Key : Integer) return Integer; function Value (Self : Python_Dictionary_Instance; Key : Float) return Integer; function Value (Self : Python_Dictionary_Instance; Key : Boolean) return Integer; function Value (Self : Python_Dictionary_Instance; Key : String) return Float; function Value (Self : Python_Dictionary_Instance; Key : Integer) return Float; function Value (Self : Python_Dictionary_Instance; Key : Float) return Float; function Value (Self : Python_Dictionary_Instance; Key : Boolean) return Float; function Value (Self : Python_Dictionary_Instance; Key : String) return Boolean; function Value (Self : Python_Dictionary_Instance; Key : Integer) return Boolean; function Value (Self : Python_Dictionary_Instance; Key : Float) return Boolean; function Value (Self : Python_Dictionary_Instance; Key : Boolean) return Boolean; -- Returns value of given key type Python_Dictionary_Iterator is new Dictionary_Iterator with record Script : Python_Scripting; Dict : PyObject; Position : Integer := 0; Key : PyObject; Value : PyObject; end record; function Next (Self : not null access Python_Dictionary_Iterator) return Boolean; -- Moves iterator to next pair in dictionary. Returns False when where is -- no more pairs available. function Key (Self : Python_Dictionary_Iterator) return String; function Key (Self : Python_Dictionary_Iterator) return Integer; function Key (Self : Python_Dictionary_Iterator) return Float; function Key (Self : Python_Dictionary_Iterator) return Boolean; -- Returns value of current pair in dictionary function Value (Self : Python_Dictionary_Iterator) return String; function Value (Self : Python_Dictionary_Iterator) return Integer; function Value (Self : Python_Dictionary_Iterator) return Float; function Value (Self : Python_Dictionary_Iterator) return Boolean; -- Returns value of current pair in dictionary function Conditional_To (Condition : Boolean; Object : PyObject; Name : String) return String; function Conditional_To (Condition : Boolean; Object : PyObject; Name : String) return Integer; function Conditional_To (Condition : Boolean; Object : PyObject; Name : String) return Float; function Conditional_To (Condition : Boolean; Script : Scripting_Language; Object : PyObject) return Boolean; -- Converts Python's value when Condition is true function Internal_To (Object : PyObject; Name : String) return String; function Internal_To (Object : PyObject; Name : String) return Integer; function Internal_To (Object : PyObject; Name : String) return Float; function Internal_To (Script : Scripting_Language; Object : PyObject) return Boolean; -- Converts Python's value ---------------- -- Tracebacks -- ---------------- function Trace_Python_Code (User_Arg : GNATCOLL.Python.PyObject; Frame : GNATCOLL.Python.PyFrameObject; Why : GNATCOLL.Python.Why_Trace_Func; Object : GNATCOLL.Python.PyObject) return Integer with Convention => C; -- Trace callback routine Last_Call_Frame : PyFrameObject := null; -- Global variable to save frame object of the last call function Error_Message_With_Stack return String; -- Returns error message with Python stack when available -------------------- -- Block_Commands -- -------------------- procedure Block_Commands (Script : access Python_Scripting_Record; Block : Boolean) is begin Script.Blocked := Block; end Block_Commands; ---------------- -- Trace_Dump -- ---------------- procedure Trace_Dump (Name : String; Obj : PyObject) is S : PyObject; begin if Obj = null then Put_Line (Name & "="); else -- Special handling here, since for a string PyObject_Str returns -- the string itself, thus impacting the refcounting S := PyObject_Str (Obj); if S = Obj then Py_DECREF (Obj); -- Preserve original refcount end if; Put_Line (Name & "=""" & PyString_AsString (S) & '"' & ASCII.LF & " refcount=" & Value (Refcount_Msg (Obj))); if S /= Obj then Py_DECREF (S); end if; -- Other possible debug info: -- repr = PyString_AsString (PyObject_Repr (Obj)) -- methods = PyString_AsString (PyObject_Str (PyObject_Dir (Obj))) end if; end Trace_Dump; ------------------ -- Command_Name -- ------------------ function Command_Name (Data : Handler_Data) return String is begin if Data.Cmd.Class = No_Class then return Data.Cmd.Command; else return Get_Name (Data.Cmd.Class) & "." & Data.Cmd.Command; end if; end Command_Name; ------------- -- Destroy -- ------------- procedure Destroy (Script : access Python_Scripting_Record) is begin if not Finalized then Trace (Me, "Finalizing python"); Finalized := True; Set_Default_Console (Script, null); Free (Script.Buffer); Py_Finalize; end if; end Destroy; ---------------------------- -- Command_Line_Treatment -- ---------------------------- overriding function Command_Line_Treatment (Script : access Python_Scripting_Record) return Command_Line_Mode is pragma Unreferenced (Script); begin return Raw_String; end Command_Line_Treatment; ------------------------------- -- Register_Python_Scripting -- ------------------------------- procedure Register_Python_Scripting (Repo : access Scripts.Scripts_Repository_Record'Class; Module : String; Program_Name : String := "python"; Python_Home : String := "") is Script : Python_Scripting; Ignored : Integer; pragma Unreferenced (Ignored); function Initialize_Py_And_Module (Program, Module : String) return PyObject; pragma Import (C, Initialize_Py_And_Module, "ada_py_initialize_and_module"); Main_Module : PyObject; begin Script := new Python_Scripting_Record; Script.Repo := Scripts_Repository (Repo); Register_Scripting_Language (Repo, Script); -- Set the program name and python home if Python_Home /= "" then Py_SetPythonHome (Python_Home); end if; Script.Module := Initialize_Py_And_Module (Program_Name & ASCII.NUL, Module & ASCII.NUL); if Script.Module = null then raise Program_Error with "Could not import module " & Module; end if; Finalized := False; declare Lock : Ada_GIL_Lock with Unreferenced; begin if Active (Me_Stack) and then not PyRun_SimpleString ("import traceback") then raise Program_Error with "Could not import traceback.py"; end if; Main_Module := PyImport_AddModule ("__main__"); if Main_Module = null then raise Program_Error with "Could not import module __main__"; end if; Script.Globals := PyModule_GetDict (Main_Module); Script.Buffer := new String'(""); Script.Builtin := PyImport_ImportModule (Builtin_Name); Script.Exception_Unexpected := PyErr_NewException (Module & ".Unexpected_Exception", null, null); Ignored := PyModule_AddObject (Script.Module, "Unexpected_Exception" & ASCII.NUL, Script.Exception_Unexpected); Script.Exception_Misc := PyErr_NewException (Module & ".Exception", null, null); Ignored := PyModule_AddObject (Script.Module, "Exception" & ASCII.NUL, Script.Exception_Misc); Script.Exception_Missing_Args := PyErr_NewException (Module & ".Missing_Arguments", null, null); Ignored := PyModule_AddObject (Script.Module, "Missing_Arguments" & ASCII.NUL, Script.Exception_Missing_Args); Script.Exception_Invalid_Arg := PyErr_NewException (Module & ".Invalid_Argument", null, null); Ignored := PyModule_AddObject (Script.Module, "Invalid_Argument" & ASCII.NUL, Script.Exception_Invalid_Arg); -- PyGTK prints its error messages using sys.argv, which doesn't -- exist in non-interactive mode. We therefore define it here if not PyRun_SimpleString ("sys.argv=['" & Module & "']") then Trace (Me_Error, "Could not initialize sys.argv"); end if; -- This function is required for support of the Python menu -- (F120-025), so that we can execute python commands in the context -- of the global interpreter instead of the current context (for the -- menu, that would be python_support.py, and thus would have no -- impact on the interpreter itself) Register_Command (Repo, Command => "exec_in_console", Handler => Python_Global_Command_Handler'Access, Minimum_Args => 1, Maximum_Args => 1, Language => Python_Name); if Active (Me_Crash) then PyEval_SetTrace (Trace_Python_Code'Access, null); end if; end; end Register_Python_Scripting; ----------------------------------- -- Python_Global_Command_Handler -- ----------------------------------- procedure Python_Global_Command_Handler (Data : in out Callback_Data'Class; Command : String) is Result : PyObject; Errors : aliased Boolean; begin if Command = "exec_in_console" then Result := Run_Command (Python_Scripting (Get_Script (Data)), Command => Nth_Arg (Data, 1), Need_Output => False, Show_Command => True, Errors => Errors'Unchecked_Access); Py_XDECREF (Result); end if; end Python_Global_Command_Handler; -------------------------- -- Destroy_Handler_Data -- -------------------------- procedure Destroy_Handler_Data (Handler : System.Address) is H : Handler_Data_Access := Convert (Handler); begin Unchecked_Free (H); end Destroy_Handler_Data; ---------- -- Free -- ---------- procedure Free (Data : in out Python_Callback_Data) is Lock : Ada_GIL_Lock with Unreferenced; begin if Data.Args /= null then Py_DECREF (Data.Args); end if; if Data.Kw /= null then Py_DECREF (Data.Kw); end if; if Data.Return_Value /= null then Py_DECREF (Data.Return_Value); Data.Return_Value := null; end if; if Data.Return_Dict /= null then Py_DECREF (Data.Return_Dict); Data.Return_Dict := null; end if; end Free; -------------- -- Set_Item -- -------------- procedure Set_Item (Args : PyObject; T : Integer; Item : PyObject) is N : Integer; pragma Unreferenced (N); begin -- Special case tuples, since they are immutable through -- PyObject_SetItem if PyTuple_Check (Args) then PyTuple_SetItem (Args, T, Item); -- Doesn't modify refcount Py_INCREF (Item); -- Also special case lists, since we want to append if the index is -- too big elsif PyList_Check (Args) then if T < PyList_Size (Args) then PyObject_SetItem (Args, T, Item); else N := PyList_Append (Args, Item); end if; else PyObject_SetItem (Args, T, Item); end if; end Set_Item; ----------- -- Clone -- ----------- function Clone (Data : Python_Callback_Data) return Callback_Data'Class is Lock : Ada_GIL_Lock with Unreferenced; D : Python_Callback_Data := Data; Item : PyObject; Size : Integer; begin if D.Args /= null then Size := PyObject_Size (D.Args); D.Args := PyTuple_New (Size); for T in 0 .. Size - 1 loop Item := PyObject_GetItem (Data.Args, T); Set_Item (D.Args, T, Item); Py_DECREF (Item); end loop; end if; if D.Kw /= null then Py_INCREF (D.Kw); end if; D.Return_Value := null; D.Return_Dict := null; return D; end Clone; ------------ -- Create -- ------------ function Create (Script : access Python_Scripting_Record; Arguments_Count : Natural) return Callback_Data'Class is Lock : Ada_GIL_Lock with Unreferenced; Callback : constant Python_Callback_Data := (Callback_Data with Script => Python_Scripting (Script), Args => PyTuple_New (Arguments_Count), Kw => null, Return_Value => null, Return_Dict => null, Has_Return_Value => False, Return_As_List => False, First_Arg_Is_Self => False); begin return Callback; end Create; ----------------- -- Set_Nth_Arg -- ----------------- procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : PyObject) is Lock : Ada_GIL_Lock with Unreferenced; begin Set_Item (Data.Args, N - 1, Value); Py_DECREF (Value); end Set_Nth_Arg; ----------------- -- Set_Nth_Arg -- ----------------- procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : Subprogram_Type) is Lock : Ada_GIL_Lock with Unreferenced; Subp : constant PyObject := Python_Subprogram_Record (Value.all).Subprogram; begin Set_Item (Data.Args, N - 1, Subp); Py_DECREF (Subp); end Set_Nth_Arg; ----------------- -- Set_Nth_Arg -- ----------------- procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : String) is Lock : Ada_GIL_Lock with Unreferenced; Item : constant PyObject := PyString_FromString (Value); begin Set_Item (Data.Args, N - 1, Item); Py_DECREF (Item); end Set_Nth_Arg; ----------------- -- Set_Nth_Arg -- ----------------- procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : Integer) is Lock : Ada_GIL_Lock with Unreferenced; Item : constant PyObject := PyInt_FromLong (Interfaces.C.long (Value)); begin Set_Item (Data.Args, N - 1, Item); Py_DECREF (Item); end Set_Nth_Arg; ----------------- -- Set_Nth_Arg -- ----------------- procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : Float) is Lock : Ada_GIL_Lock with Unreferenced; Item : constant PyObject := PyFloat_FromDouble (Interfaces.C.double (Value)); begin Set_Item (Data.Args, N - 1, Item); Py_DECREF (Item); end Set_Nth_Arg; ----------------- -- Set_Nth_Arg -- ----------------- procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : Boolean) is Lock : Ada_GIL_Lock with Unreferenced; Item : constant PyObject := PyInt_FromLong (Boolean'Pos (Value)); begin Set_Item (Data.Args, N - 1, Item); Py_DECREF (Item); end Set_Nth_Arg; ----------------- -- Set_Nth_Arg -- ----------------- procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : Class_Instance) is Lock : Ada_GIL_Lock with Unreferenced; Inst : PyObject; begin if Value = No_Class_Instance then Set_Item (Data.Args, N - 1, Py_None); -- Increments refcount else Inst := Python_Class_Instance (Get_CIR (Value)).Data; Set_Item (Data.Args, N - 1, Inst); -- Increments refcount end if; end Set_Nth_Arg; ----------------- -- Set_Nth_Arg -- ----------------- procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : List_Instance) is Lock : Ada_GIL_Lock with Unreferenced; V : constant PyObject := Python_Callback_Data (Value).Args; begin Set_Item (Data.Args, N - 1, V); -- Increments refcount end Set_Nth_Arg; ----------------- -- First_Level -- ----------------- function First_Level (Self, Args, Kw : PyObject) return PyObject is -- Args and Kw could both be null, as called from PyCFunction_Call Handler : Handler_Data_Access; Size : Integer := 0; Callback : Python_Callback_Data; First_Arg_Is_Self : Boolean; Result : PyObject; begin Handler := Convert (PyCObject_AsVoidPtr (Self)); if Finalized and then Handler.Cmd.Command /= Destructor_Method then PyErr_SetString (Handler.Script.Exception_Unexpected, "Application was already finalized"); return null; end if; if Active (Me_Log) then Trace (Me_Log, "First_Level: " & Handler.Cmd.Command); end if; if Active (Me_Stack) then declare Module : constant PyObject := PyImport_ImportModule ("traceback"); Newline, List, Join : PyObject; begin if Module /= null then List := PyObject_CallMethod (Module, "format_stack"); if List /= null then Newline := PyString_FromString (""); Join := PyObject_CallMethod (Newline, "join", List); Trace (Me_Stack, "Exec " & Command_Name (Handler.all) & ASCII.LF & PyString_AsString (Join)); Py_DECREF (Newline); Py_DECREF (List); Py_DECREF (Join); end if; end if; exception when E : others => Trace (Me_Stack, E); end; end if; if Args /= null then Size := PyObject_Size (Args); end if; if Kw /= null then declare S : constant Integer := PyDict_Size (Kw); begin if S < 0 then raise Program_Error with "Incorrect dictionary when calling function " & Handler.Cmd.Command; end if; Size := S + Size; end; end if; First_Arg_Is_Self := Handler.Cmd.Class /= No_Class and then not Handler.Cmd.Static_Method; if First_Arg_Is_Self then Size := Size - 1; -- First param is always the instance end if; -- Special case for constructors: -- when we were using old-style classes, New_Instance was not calling -- __init__. With new-style classes, however, __init__ is already called -- when we call the metatype(). In particular, this means that the -- profile of New_Instance should allow passing custom parameters, -- otherwise the call to __init__ fails. -- So for now we simply allow a call to the constructor with no -- parameter, which does nothing. -- This is not very elegant, since from python's point of view, this -- relies on the user calling New_Instance and immediately initializing -- the Class_Instance as done in the Constructor_Method handler. if Handler.Script.Ignore_Constructor and then Handler.Cmd.Command = Constructor_Method then Py_INCREF (Py_None); return Py_None; end if; -- Check number of arguments if Handler.Cmd.Minimum_Args > Size or else Size > Handler.Cmd.Maximum_Args then if Handler.Cmd.Minimum_Args > Size then PyErr_SetString (Handler.Script.Exception_Missing_Args, "Wrong number of parameters for " & Handler.Cmd.Command & ", expecting at least" & Handler.Cmd.Minimum_Args'Img & ", received" & Size'Img); else PyErr_SetString (Handler.Script.Exception_Missing_Args, "Wrong number of parameters for " & Handler.Cmd.Command & ", expecting at most" & Handler.Cmd.Maximum_Args'Img & ", received" & Size'Img); end if; return null; end if; Callback.Args := Args; Py_XINCREF (Callback.Args); Callback.Kw := Kw; Py_XINCREF (Callback.Kw); Callback.Return_Value := null; Callback.Return_Dict := null; Callback.Script := Handler.Script; Callback.First_Arg_Is_Self := First_Arg_Is_Self; if Handler.Cmd.Params /= null then Name_Parameters (Callback, Handler.Cmd.Params.all); end if; Run_Callback (Handler.Script, Handler.Cmd.Handler, Handler.Cmd.Command, Callback, Result); return Result; end First_Level; ------------------ -- Run_Callback -- ------------------ procedure Run_Callback (Script : Python_Scripting; Cmd : Module_Command_Function; Command : String; Data : in out Python_Callback_Data'Class; Result : out PyObject) is begin -- Return_Value will be set to null in case of error Data.Return_Value := Py_None; Py_INCREF (Py_None); Cmd.all (Data, Command); if Data.Return_Dict /= null then Result := Data.Return_Dict; else Result := Data.Return_Value; -- might be null for an exception end if; Py_XINCREF (Result); Free (Data); exception when E : Invalid_Parameter => if not Data.Has_Return_Value or else Data.Return_Value /= null then PyErr_SetString (Script.Exception_Invalid_Arg, Exception_Message (E)); end if; Free (Data); Result := null; when E : others => if not Data.Has_Return_Value or else Data.Return_Value /= null then PyErr_SetString (Script.Exception_Unexpected, "unexpected internal exception " & Exception_Information (E)); end if; Free (Data); Result := null; end Run_Callback; ------------------------ -- First_Level_Getter -- ------------------------ function First_Level_Getter (Obj : PyObject; Closure : System.Address) return PyObject is Prop : constant Property_User_Data := Convert (Closure); Callback : Python_Callback_Data; Args : PyObject; Result : PyObject; begin if Active (Me_Log) then Trace (Me_Log, "First_Level_Getter " & Prop.Prop.Name); end if; Args := PyTuple_New (1); Py_INCREF (Obj); PyTuple_SetItem (Args, 0, Obj); -- don't increase refcount of Obj Callback := (Script => Prop.Script, Args => Args, -- Now owned by Callback Kw => null, Return_Value => null, Return_Dict => null, Has_Return_Value => False, Return_As_List => False, First_Arg_Is_Self => False); Run_Callback (Prop.Script, Prop.Prop.Getter, Prop.Prop.Name, Callback, Result); -- Run_Callback frees Callback, which decref Args return Result; end First_Level_Getter; ------------------------ -- First_Level_Setter -- ------------------------ function First_Level_Setter (Obj, Value : PyObject; Closure : System.Address) return Integer is Prop : constant Property_User_Data := Convert (Closure); Callback : Python_Callback_Data; Args : PyObject; Result : PyObject; begin if Active (Me_Log) then Trace (Me_Log, "First_Level_Setter " & Prop.Prop.Name); end if; Args := PyTuple_New (2); Py_INCREF (Obj); PyTuple_SetItem (Args, 0, Obj); -- don't increase refcount of Obj Py_INCREF (Value); PyTuple_SetItem (Args, 1, Value); -- don't increase refcount of Value Callback := (Script => Prop.Script, Args => Args, -- Now owned by Callback Kw => null, Return_Value => null, Return_Dict => null, Has_Return_Value => False, Return_As_List => False, First_Arg_Is_Self => False); Run_Callback (Prop.Script, Prop.Prop.Setter, Prop.Prop.Name, Callback, Result); -- Run_Callback frees Callback, which decref Args if Result = null then return -1; else Py_DECREF (Result); return 0; end if; end First_Level_Setter; ----------------------- -- Register_Property -- ----------------------- overriding procedure Register_Property (Script : access Python_Scripting_Record; Prop : Property_Descr_Access) is Lock : Ada_GIL_Lock with Unreferenced; Klass : PyObject; Ignored : Boolean; pragma Unreferenced (Ignored); Setter : C_Setter := First_Level_Setter'Access; Getter : C_Getter := First_Level_Getter'Access; H : constant Property_User_Data := new Property_User_Data_Record' (Script => Python_Scripting (Script), Prop => Prop); -- ??? Memory leak. We do not know when H is no longer needed begin if Prop.Setter = null then Setter := null; end if; if Prop.Getter = null then Getter := null; end if; Klass := Lookup_Object (Script, Prop.Class.Qualified_Name.all); Ignored := PyDescr_NewGetSet (Typ => Klass, Name => Prop.Name, Setter => Setter, Getter => Getter, Closure => Convert (H)); end Register_Property; ---------------------- -- Register_Command -- ---------------------- overriding procedure Register_Command (Script : access Python_Scripting_Record; Cmd : Command_Descr_Access) is Lock : Ada_GIL_Lock with Unreferenced; H : constant Handler_Data_Access := new Handler_Data' (Cmd => Cmd, Script => Python_Scripting (Script)); User_Data : constant PyObject := PyCObject_FromVoidPtr (H.all'Address, Destroy_Handler_Data'Access); Klass : PyObject; Def : PyMethodDef; begin if Cmd.Class = No_Class then Add_Function (Module => Script.Module, Func => Create_Method_Def (Cmd.Command, First_Level'Access), Self => User_Data); else if Cmd.Command = Constructor_Method then Def := Create_Method_Def ("__init__", First_Level'Access); elsif Cmd.Command = Addition_Method then Def := Create_Method_Def ("__add__", First_Level'Access); elsif Cmd.Command = Substraction_Method then Def := Create_Method_Def ("__sub__", First_Level'Access); elsif Cmd.Command = Comparison_Method then Def := Create_Method_Def ("__cmp__", First_Level'Access); elsif Cmd.Command = Equal_Method then Def := Create_Method_Def ("__eq__", First_Level'Access); elsif Cmd.Command = Destructor_Method then Def := Create_Method_Def ("__del__", First_Level'Access); else Def := Create_Method_Def (Cmd.Command, First_Level'Access); end if; Klass := Lookup_Object (Script, Cmd.Class.Qualified_Name.all); if Klass = null then Trace (Me_Error, "Class not found " & Cmd.Class.Qualified_Name.all); elsif Cmd.Static_Method then Add_Static_Method (Class => Klass, Func => Def, Self => User_Data, Module => Script.Module); else Add_Method (Class => Klass, Func => Def, Self => User_Data, Module => Script.Module); end if; end if; end Register_Command; ------------------- -- Lookup_Module -- ------------------- function Lookup_Module (Self : not null access Python_Scripting_Record'Class; Name : String) return PyObject is M, Tmp : PyObject := null; First : Natural; begin if Name = "@" then return Self.Module; end if; First := Name'First; for N in Name'First .. Name'Last + 1 loop if N > Name'Last or else Name (N) = '.' then if Name (First .. N - 1) = "@" then M := Self.Module; else if Name (Name'First .. Name'First + 1) = "@." then Tmp := PyImport_AddModule (PyModule_Getname (Self.Module) & '.' & Name (Name'First + 2 .. N - 1)); else Tmp := PyImport_AddModule (Name (Name'First .. N - 1)); end if; if M /= null then PyDict_SetItemString (PyModule_GetDict (Tmp), "__module__", PyObject_GetAttrString (M, "__name__")); Py_INCREF (Tmp); if PyModule_AddObject (M, Name (First .. N - 1), Tmp) /= 0 then Trace (Me_Error, "Could not register submodule " & Name (Name'First .. N - 1)); return null; end if; end if; M := Tmp; end if; First := N + 1; end if; end loop; return M; end Lookup_Module; ------------------- -- Lookup_Object -- ------------------- function Lookup_Object (Self : not null access Python_Scripting_Record'Class; Qualified_Name : String) return PyObject is M : PyObject; begin for N in reverse Qualified_Name'Range loop if Qualified_Name (N) = '.' then M := Lookup_Module (Self, Qualified_Name (Qualified_Name'First .. N - 1)); return Lookup_Object (M, Qualified_Name (N + 1 .. Qualified_Name'Last)); end if; end loop; M := Lookup_Object (Self.Module, Qualified_Name); if M = null then M := Lookup_Object (Self.Builtin, Qualified_Name); end if; return M; end Lookup_Object; -------------------- -- Register_Class -- -------------------- overriding procedure Register_Class (Script : access Python_Scripting_Record; Name : String; Base : Class_Type := No_Class; Module : Module_Type := Default_Module) is Lock : Ada_GIL_Lock with Unreferenced; Dict : constant PyDictObject := PyDict_New; Class : PyObject; Ignored : Integer; Bases : PyObject := null; S : Interfaces.C.Strings.chars_ptr; pragma Unreferenced (Ignored); M : constant PyObject := Lookup_Module (Script, To_String (Module.Name)); begin PyDict_SetItemString (Dict, "__module__", PyObject_GetAttrString (M, "__name__")); if Base /= No_Class then Bases := Create_Tuple ((1 => Lookup_Object (Script, Base.Qualified_Name.all))); end if; Class := Type_New (Name => Name, Bases => Bases, Dict => Dict); if Class = null then PyErr_Print; raise Program_Error with "Could not register class " & Name; end if; S := New_String (Name); Ignored := PyModule_AddObject (M, S, Class); Free (S); end Register_Class; --------------- -- Interrupt -- --------------- function Interrupt (Script : access Python_Scripting_Record) return Boolean is Lock : Ada_GIL_Lock with Unreferenced; begin if Script.In_Process then PyErr_SetInterrupt; return True; else return False; end if; end Interrupt; -------------- -- Complete -- -------------- procedure Complete (Script : access Python_Scripting_Record; Input : String; Completions : out String_Lists.List) is Lock : Ada_GIL_Lock with Unreferenced; Start : Natural := Input'First - 1; Last : Natural := Input'Last + 1; Obj, Item : PyObject; Errors : aliased Boolean; begin Completions := String_Lists.Empty_List; for N in reverse Input'Range loop if Input (N) = ' ' or else Input (N) = ASCII.HT then Start := N; exit; elsif Input (N) = '.' and then Last > Input'Last then Last := N; end if; end loop; if Start < Input'Last then Obj := Run_Command (Script, Builtins_Name & ".dir(" & Input (Start + 1 .. Last - 1) & ")", Need_Output => True, Hide_Output => True, Hide_Exceptions => True, Errors => Errors'Unchecked_Access); if Obj /= null then for Index in 0 .. PyList_Size (Obj) - 1 loop Item := PyList_GetItem (Obj, Index); declare S : constant String := PyString_AsString (Item); begin if S'First + Input'Last - Last - 1 <= S'Last and then (Last >= Input'Last or else Input (Last + 1 .. Input'Last) = S (S'First .. S'First + Input'Last - Last - 1)) then String_Lists.Append (Completions, Input (Input'First .. Last - 1) & '.' & S); end if; end; end loop; Py_DECREF (Obj); end if; end if; end Complete; ---------------- -- Get_Prompt -- ---------------- overriding function Get_Prompt (Script : access Python_Scripting_Record) return String is Lock : Ada_GIL_Lock with Unreferenced; Ps : PyObject; begin if Script.Use_Secondary_Prompt then Ps := PySys_GetObject ("ps2"); if Ps = null then return "... "; end if; else Ps := PySys_GetObject ("ps1"); if Ps = null then return ">>> "; end if; end if; return PyString_AsString (Ps); end Get_Prompt; -------------------- -- Display_Prompt -- -------------------- procedure Display_Prompt (Script : access Python_Scripting_Record; Console : Virtual_Console := null) is Lock : Ada_GIL_Lock with Unreferenced; begin Insert_Prompt (Script, Console, Get_Prompt (Scripting_Language (Script))); end Display_Prompt; ----------------- -- Run_Command -- ----------------- function Run_Command (Script : access Python_Scripting_Record'Class; Command : String; Console : Virtual_Console := null; Show_Command : Boolean := False; Hide_Output : Boolean := False; Hide_Exceptions : Boolean := False; Errors : access Boolean) return String is Result : PyObject; Str : PyObject; begin Result := Run_Command (Script, Command, Console => Console, Need_Output => True, Show_Command => Show_Command, Hide_Output => Hide_Output, Hide_Exceptions => Hide_Exceptions, Errors => Errors); if Result /= null and then not Errors.all then Str := PyObject_Str (Result); if Str = null then Py_DECREF (Result); return "Error calling __repr__ on the result of the script"; end if; declare S : constant String := PyString_AsString (Str); begin Py_DECREF (Result); Py_DECREF (Str); if Active (Me_Log) then Trace (Me_Log, "output is: " & S); end if; return S; end; else Py_XDECREF (Result); return ""; end if; end Run_Command; -------------------------- -- Log_Python_Exception -- -------------------------- procedure Log_Python_Exception is Typ, Occurrence, Traceback, S : PyObject; begin if Active (Me_Error) then PyErr_Fetch (Typ, Occurrence, Traceback); PyErr_NormalizeException (Typ, Occurrence, Traceback); S := PyObject_Repr (Occurrence); if S /= null then Trace (Me_Error, "Exception " & PyString_AsString (S)); Py_DECREF (S); end if; PyErr_Restore (Typ, Occurrence, Traceback); end if; end Log_Python_Exception; ----------------- -- Run_Command -- ----------------- function Run_Command (Script : access Python_Scripting_Record'Class; Command : String; Need_Output : Boolean; Console : Virtual_Console := null; Show_Command : Boolean := False; Hide_Output : Boolean := False; Hide_Exceptions : Boolean := False; Errors : access Boolean) return PyObject is Lock : Ada_GIL_Lock with Unreferenced; Result : PyObject := null; Code : PyCodeObject; Indented_Input : constant Boolean := Command'Length > 0 and then (Command (Command'First) = ASCII.HT or else Command (Command'First) = ' '); Cmd : constant String := Script.Buffer.all & Command & ASCII.LF; Typ, Occurrence, Traceback, S : PyObject; Default_Console_Refed : Boolean := False; Default_Console : constant Virtual_Console := Get_Default_Console (Script); State : Interpreter_State; begin if Active (Me_Log) then Trace (Me_Log, "command: " & Script.Buffer.all & Command); end if; Errors.all := False; if Finalized or else Cmd = "" & ASCII.LF then if not Hide_Output then Display_Prompt (Script); end if; return null; end if; if Show_Command and not Hide_Output then Insert_Text (Script, Console, Command & ASCII.LF); end if; -- The following code will not work correctly in multitasking mode if -- each thread is redirecting to a different console. One might argue -- this is up to the user to fix. if Console /= null then if Default_Console /= null then Default_Console_Refed := True; Ref (Default_Console); end if; Set_Default_Console (Script, Console); end if; -- If we want to have sys.displayhook called, we should use -- as the filename, otherwise will ensure this is not -- an interactive session. -- For interactive code, python generates addition opcode PRINT_EXPR -- which will call displayhook. -- -- We cannot use Py_Eval_Input, although it would properly return the -- result of evaluating the expression, but it would not support multi -- line input, in particular function defintion. -- So we need to use Py_Single_Input, but then the result of evaluating -- the code is always None. if Need_Output then State := Py_Eval_Input; else State := Py_Single_Input; end if; if Hide_Output then Code := Py_CompileString (Cmd, "", State); else Code := Py_CompileString (Cmd, "", State); end if; -- If code compiled just fine if Code /= null and then not Indented_Input then Script.Use_Secondary_Prompt := False; Free (Script.Buffer); Script.Buffer := new String'(""); if Get_Default_Console (Script) /= null then Grab_Events (Get_Default_Console (Script), True); -- No exception handler needed because PyEval_EvalCode cannot -- raise an exception. Result := PyEval_EvalCode (Code, Script.Globals, Script.Globals); Grab_Events (Get_Default_Console (Script), False); else Result := PyEval_EvalCode (Code, Script.Globals, Script.Globals); end if; Py_XDECREF (PyObject (Code)); if Result = null then if Active (Me_Error) then PyErr_Fetch (Typ, Occurrence, Traceback); PyErr_NormalizeException (Typ, Occurrence, Traceback); S := PyObject_Repr (Occurrence); if S /= null then Trace (Me_Error, "Exception " & PyString_AsString (S)); Py_DECREF (S); else Trace (Me_Error, "Python raised an exception with no __repr__"); end if; -- Do not DECREF Typ, Occurrence or Traceback after this PyErr_Restore (Typ, Occurrence, Traceback); end if; if not Hide_Exceptions then PyErr_Print; else PyErr_Clear; end if; Errors.all := True; end if; -- Do we have compilation error because input was incomplete ? elsif not Hide_Output then Script.Use_Secondary_Prompt := Indented_Input; if not Script.Use_Secondary_Prompt then if PyErr_Occurred /= null then PyErr_Fetch (Typ, Occurrence, Traceback); PyErr_NormalizeException (Typ, Occurrence, Traceback); if PyTuple_Check (Occurrence) then -- Old style exceptions S := PyTuple_GetItem (Occurrence, 0); else -- New style: occurrence is an instance -- S is null if the exception is not a syntax_error S := PyObject_GetAttrString (Occurrence, "msg"); end if; PyErr_Restore (Typ, Occurrence, Traceback); if S = null then Script.Use_Secondary_Prompt := False; else declare Msg : constant String := PyString_AsString (S); begin Py_DECREF (S); -- Second message appears when typing: -- >>> if 1: -- ... pass -- ... else: if Msg = "unexpected EOF while parsing" then Script.Use_Secondary_Prompt := Command'Length > 0 and then Command (Command'Last) = ':'; elsif Msg = "expected an indented block" then Script.Use_Secondary_Prompt := Command'Length /= 0 and then Command (Command'Last) /= ASCII.LF; else Log_Python_Exception; end if; end; end if; if not Script.Use_Secondary_Prompt then PyErr_Print; Errors.all := True; else PyErr_Clear; end if; end if; else PyErr_Clear; end if; Free (Script.Buffer); if Script.Use_Secondary_Prompt then Script.Buffer := new String'(Cmd); else Script.Buffer := new String'(""); end if; else if Active (Me_Error) then PyErr_Fetch (Typ, Occurrence, Traceback); PyErr_NormalizeException (Typ, Occurrence, Traceback); S := PyObject_Repr (Occurrence); if S /= null then Trace (Me_Error, "Exception " & PyString_AsString (S)); Py_DECREF (S); end if; PyErr_Restore (Typ, Occurrence, Traceback); end if; PyErr_Print; end if; if not Hide_Output then Display_Prompt (Script); end if; if Console /= null then Set_Default_Console (Script, Default_Console); if Default_Console_Refed then Unref (Default_Console); end if; end if; return Result; exception when E : others => Trace (Me_Error, E); Errors.all := True; if Default_Console_Refed then Unref (Default_Console); end if; return Result; end Run_Command; --------------------- -- Execute_Command -- --------------------- procedure Execute_Command (Script : access Python_Scripting_Record; CL : Arg_List; Console : Virtual_Console := null; Hide_Output : Boolean := False; Show_Command : Boolean := True; Errors : out Boolean) is Lock : Ada_GIL_Lock with Unreferenced; E : aliased Boolean; Result : PyObject; begin if Script.Blocked then Errors := True; Insert_Error (Script, Console, "A command is already executing"); else Result := Run_Command (Script, Get_Command (CL), Console => Console, Need_Output => False, Hide_Output => Hide_Output, Show_Command => Show_Command, Errors => E'Unchecked_Access); Py_XDECREF (Result); Errors := E; end if; end Execute_Command; --------------------- -- Execute_Command -- --------------------- function Execute_Command (Script : access Python_Scripting_Record; CL : Arg_List; Console : Virtual_Console := null; Hide_Output : Boolean := False; Show_Command : Boolean := True; Errors : access Boolean) return String is Lock : Ada_GIL_Lock with Unreferenced; pragma Unreferenced (Show_Command); begin if Script.Blocked then Errors.all := True; Insert_Error (Script, Console, "A command is already executing"); return ""; else return Run_Command (Script, Get_Command (CL), Console => Console, Hide_Output => Hide_Output, Errors => Errors); end if; end Execute_Command; --------------------- -- Execute_Command -- --------------------- function Execute_Command (Script : access Python_Scripting_Record; CL : Arg_List; Console : Virtual_Console := null; Hide_Output : Boolean := False; Errors : access Boolean) return Boolean is Lock : Ada_GIL_Lock with Unreferenced; Obj : PyObject; Result : Boolean; begin if Script.Blocked then Errors.all := True; Insert_Error (Script, Console, "A command is already executing"); return False; else Obj := Run_Command (Script, Get_Command (CL), Need_Output => True, Console => Console, Hide_Output => Hide_Output, Errors => Errors); Result := Obj /= null and then ((PyInt_Check (Obj) and then PyInt_AsLong (Obj) = 1) or else (PyBool_Check (Obj) and then PyBool_Is_True (Obj)) or else (PyString_Check (Obj) and then PyString_AsString (Obj) = "true") or else (PyUnicode_Check (Obj) and then Unicode_AsString (Obj) = "true")); Py_XDECREF (Obj); return Result; end if; end Execute_Command; --------------------- -- Execute_Command -- --------------------- function Execute_Command (Script : access Python_Scripting_Record; Command : String; Args : Callback_Data'Class) return Boolean is Lock : Ada_GIL_Lock with Unreferenced; Obj : PyObject; Errors : aliased Boolean; begin if Script.Blocked then return False; else Obj := Run_Command (Script, Command => Command, Need_Output => True, Console => null, Errors => Errors'Unchecked_Access); if Obj /= null and then PyFunction_Check (Obj) then return Execute_Command (Script, Obj, Args, Errors'Access); else return False; end if; end if; end Execute_Command; --------------------- -- Execute_Command -- --------------------- function Execute_Command (Script : access Python_Scripting_Record'Class; Command : PyObject; Args : Callback_Data'Class; Error : access Boolean) return PyObject is Lock : Ada_GIL_Lock with Unreferenced; Obj : PyObject; Old, Args2, Item : PyObject; Size : Integer; begin Error.all := False; if Command = null then Trace (Me_Error, "Trying to execute 'null'"); return null; end if; if Active (Me_Log) then Obj := PyObject_Repr (Command); if Obj /= null then Trace (Me_Log, "Execute " & PyString_AsString (Obj)); Py_DECREF (Obj); end if; end if; if Script.Blocked then Error.all := True; Trace (Me_Error, "A python command is already executing"); return null; end if; -- If we are calling a bound method whose self is the same as the -- first parameter in Args, we remove the first parameter to avoid -- a duplicate. This allows registering callbacks as: -- class MyClass(object): -- def my_callback(self, arg1): -- pass -- def __init__(self): -- register_callback(self, self.my_callback) -- register_callback(self, MyClass.my_callback) -- If Ada calls the registered callback by passing the instance as -- the first parameter in the Callback_Data, both the calls above -- have the same effect when we remove the duplication. Otherwise, -- the first one will result in an error since my_callback will be -- called with three arguments (self, self, arg1). -- Note that the second call does not provide dynamic dispatching when -- MyClass is subclassed and my_callback overridden. Old := Python_Callback_Data (Args).Args; Size := PyTuple_Size (Old); if PyMethod_Check (Command) and then PyMethod_Self (Command) /= null and then Size > 0 and then PyMethod_Self (Command) = PyTuple_GetItem (Old, 0) then if Size = 1 then Args2 := Py_None; Py_INCREF (Args2); else Args2 := PyTuple_New (Size => Size - 1); for T in 1 .. Size - 1 loop -- Remove arg 0 Item := PyTuple_GetItem (Old, T); -- same refcount Py_INCREF (Item); PyTuple_SetItem (Args2, T - 1, Item); -- same refcount end loop; end if; else Args2 := Old; Py_INCREF (Args2); end if; Obj := PyObject_Call (Command, Args2, Python_Callback_Data (Args).Kw); Py_DECREF (Args2); if Obj = null then Error.all := True; Trace (Me_Error, "Calling object raised an exception"); Log_Python_Exception; PyErr_Print; end if; return Obj; exception when E : others => Trace (Me_Error, E, Error_Message_With_Stack); raise; end Execute_Command; --------------------- -- Execute_Command -- --------------------- function Execute_Command (Script : access Python_Scripting_Record'Class; Command : PyObject; Args : Callback_Data'Class; Error : access Boolean) return String is Lock : Ada_GIL_Lock with Unreferenced; Obj : constant PyObject := Execute_Command (Script, Command, Args, Error); begin if Obj /= null and then PyString_Check (Obj) then declare Str : constant String := PyString_AsString (Obj); begin Py_DECREF (Obj); return Str; end; elsif Obj /= null and then PyUnicode_Check (Obj) then declare Str : constant String := Unicode_AsString (Obj, "utf-8"); begin Py_DECREF (Obj); return Str; end; else if Obj /= null then Py_DECREF (Obj); else Error.all := True; end if; return ""; end if; end Execute_Command; --------------------- -- Execute_Command -- --------------------- function Execute_Command (Script : access Python_Scripting_Record'Class; Command : PyObject; Args : Callback_Data'Class; Error : access Boolean) return Any_Type is Lock : Ada_GIL_Lock with Unreferenced; Obj : constant PyObject := Execute_Command (Script, Command, Args, Error); begin if Obj /= null then declare Any : constant Any_Type := GNATCOLL.Any_Types.Python.From_PyObject (Obj); begin Py_DECREF (Obj); return Any; end; else return Empty_Any_Type; end if; end Execute_Command; --------------------- -- Execute_Command -- --------------------- function Execute_Command (Script : access Python_Scripting_Record'Class; Command : PyObject; Args : Callback_Data'Class; Error : access Boolean) return Boolean is Lock : Ada_GIL_Lock with Unreferenced; Obj : constant PyObject := Execute_Command (Script, Command, Args, Error); Result : Boolean; begin if Obj = null then return False; else Result := ((PyInt_Check (Obj) and then PyInt_AsLong (Obj) = 1) or else (PyBool_Check (Obj) and then PyBool_Is_True (Obj)) or else (PyString_Check (Obj) and then PyString_AsString (Obj) = "true") or else (PyUnicode_Check (Obj) and then Unicode_AsString (Obj) = "true")); Py_DECREF (Obj); return Result; end if; end Execute_Command; ------------------ -- Execute_File -- ------------------ procedure Execute_File (Script : access Python_Scripting_Record; Filename : String; Console : Virtual_Console := null; Hide_Output : Boolean := False; Show_Command : Boolean := True; Errors : out Boolean) is Lock : Ada_GIL_Lock with Unreferenced; begin Script.Current_File := To_Unbounded_String (Filename); -- Before executing a Python script, add its directory to sys.path. -- This is to mimic the behavior of the command-line shell, and -- allow the loaded script to "import" scripts in the same directory. declare D : constant String := +Create (+Filename).Dir_Name; -- Use Virtual_File as a reliable way to get the directory L : Natural := D'Last; begin -- Strip the ending '\' if any. if D /= "" and then D (L) = '\' then L := L - 1; end if; Execute_Command (Script, Create ("import sys;sys.path.insert(0, r'" & D (D'First .. L) & "')"), Console => null, Hide_Output => True, Show_Command => False, Errors => Errors); end; -- The call to compile is only necessary to get an error message -- pointing back to Filename if Is_Python3 then Execute_Command (Script, Create ("exec(compile(open(r'" & Filename & "').read(),r'" & Filename & "','exec'))"), Console, Hide_Output, Show_Command, Errors); else Execute_Command (Script, Create ("execfile(r'" & Filename & "')"), Console, Hide_Output, Show_Command, Errors); end if; Script.Current_File := Null_Unbounded_String; end Execute_File; -------------- -- Get_Name -- -------------- function Get_Name (Script : access Python_Scripting_Record) return String is pragma Unreferenced (Script); begin return Python_Name; end Get_Name; ---------------- -- Get_Script -- ---------------- function Get_Script (Data : Python_Callback_Data) return Scripting_Language is begin return Scripting_Language (Data.Script); end Get_Script; -------------------- -- Get_Repository -- -------------------- function Get_Repository (Script : access Python_Scripting_Record) return Scripts_Repository is begin return Script.Repo; end Get_Repository; -------------------- -- Current_Script -- -------------------- function Current_Script (Script : access Python_Scripting_Record) return String is begin if Script.Current_File = Null_Unbounded_String then return ""; else return To_String (Script.Current_File); end if; end Current_Script; ------------------------- -- Number_Of_Arguments -- ------------------------- function Number_Of_Arguments (Data : Python_Callback_Data) return Natural is Lock : Ada_GIL_Lock with Unreferenced; begin if Data.Kw /= null then return PyDict_Size (Data.Kw) + PyObject_Size (Data.Args); else return PyObject_Size (Data.Args); end if; end Number_Of_Arguments; --------------------- -- Name_Parameters -- --------------------- procedure Name_Parameters (Data : in out Python_Callback_Data; Params : Param_Array) is First : Integer := 0; Old_Args : constant PyObject := Data.Args; Item : PyObject; Nargs : Natural := 0; -- Number of entries in Data.Args Nkeywords : Integer; -- Number of unhandled entries in Data.Kw begin if Data.Kw = null then return; end if; Nkeywords := PyDict_Size (Data.Kw); if Data.Args /= null then Nargs := PyObject_Size (Data.Args); end if; -- Modify Data.Args in place, so we need to resize it appropriately. -- Then, through a single loop, we fill it. if Data.First_Arg_Is_Self then First := 1; end if; Data.Args := PyTuple_New (Params'Length + First); if First > 0 then -- Copy "self" if Old_Args /= null then Item := PyObject_GetItem (Old_Args, 0); Py_DECREF (Item); else Item := PyDict_GetItemString (Data.Kw, "self"); if Item = null then First := 0; -- Unbound method ? end if; end if; if Item /= null then PyTuple_SetItem (Data.Args, 0, Item); Py_INCREF (Item); end if; end if; for N in Params'Range loop -- Do we have a corresponding keyword parameter ? Item := PyDict_GetItemString (Data.Kw, Params (N).Name.all); if Item /= null then Nkeywords := Nkeywords - 1; if N - Params'First + First < Nargs then Set_Error_Msg (Data, "Parameter cannot be both positional (" & Image (N - Params'First + 1 + First, 0) & Nargs'Img & Params'First'Img & ") and named: " & Params (N).Name.all); Py_DECREF (Old_Args); raise Invalid_Parameter; end if; Py_INCREF (Item); elsif N - Params'First + First < Nargs then Item := PyObject_GetItem (Old_Args, N - Params'First + First); else Item := Py_None; Py_INCREF (Item); end if; PyTuple_SetItem (Data.Args, N - Params'First + First, Item); end loop; Py_DECREF (Old_Args); -- Are there unused keyword arguments ? if Nkeywords > 0 then declare Pos : Integer := 0; Key, Value : PyObject; begin loop PyDict_Next (Data.Kw, Pos, Key, Value); exit when Pos = 1; declare K : constant String := PyString_AsString (Key); Found : Boolean := False; begin for N in Params'Range loop if Params (N).Name.all = K then Found := True; exit; end if; end loop; if not Found then Set_Error_Msg (Data, "Invalid keyword parameter: " & K); raise Invalid_Parameter with "Invalid keyword parameter " & K; end if; end; end loop; end; end if; -- Get rid of the old arguments Py_DECREF (Data.Kw); Data.Kw := null; end Name_Parameters; --------------------- -- Name_Parameters -- --------------------- procedure Name_Parameters (Data : in out Python_Callback_Data; Names : Cst_Argument_List) is Lock : Ada_GIL_Lock with Unreferenced; function Convert is new Ada.Unchecked_Conversion (Cst_String_Access, GNAT.Strings.String_Access); Params : Param_Array (Names'Range); begin for N in Names'Range loop -- The conversion here is safe: Name_Parameters does not modify the -- string, nor does it try to free it Params (N) := (Name => Convert (Names (N)), Optional => True); end loop; Name_Parameters (Data, Params); end Name_Parameters; --------------- -- Get_Param -- --------------- function Get_Param (Data : Python_Callback_Data'Class; N : Positive) return PyObject is Lock : Ada_GIL_Lock with Unreferenced; Obj : PyObject := null; begin if Data.Args /= null and then N <= PyObject_Size (Data.Args) then Obj := PyObject_GetItem (Data.Args, N - 1); end if; if Obj = null and then Data.Kw /= null then -- We haven't called Name_Parameters PyErr_SetString (Data.Script.Exception_Misc, "Keyword parameters not supported"); raise Invalid_Parameter; end if; if Obj = null or else Obj = Py_None then raise No_Such_Parameter with N'Img; end if; Py_DECREF (Obj); -- Return a borrowed reference return Obj; end Get_Param; --------------- -- Get_Param -- --------------- procedure Get_Param (Data : Python_Callback_Data'Class; N : Positive; Result : out PyObject; Success : out Boolean) is Lock : Ada_GIL_Lock with Unreferenced; begin Result := null; if Data.Args /= null and then N <= PyObject_Size (Data.Args) then Result := PyObject_GetItem (Data.Args, N - 1); Py_DECREF (Result); -- We want to return a borrowed reference end if; if Result = null and then Data.Kw /= null then -- We haven't called Name_Parameters PyErr_SetString (Data.Script.Exception_Misc, "Keyword parameters not supported"); raise Invalid_Parameter; end if; Success := Result /= null and then Result /= Py_None; end Get_Param; ------------- -- Nth_Arg -- ------------- overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive) return List_Instance'Class is Lock : Ada_GIL_Lock with Unreferenced; Item : PyObject; Success : Boolean; List : Python_Callback_Data; Iter : PyObject; begin List.Script := Data.Script; List.First_Arg_Is_Self := False; Get_Param (Data, N, Item, Success); if not Success then List.Args := PyTuple_New (0); -- An empty list else Iter := PyObject_GetIter (Item); if Iter = null then raise Invalid_Parameter with "Parameter" & Integer'Image (N) & " should be iterable"; end if; if PyDict_Check (Item) then raise Invalid_Parameter with "Parameter" & Integer'Image (N) & " should not be dictionary"; end if; if PyAnySet_Check (Item) then raise Invalid_Parameter with "Parameter" & Integer'Image (N) & " should not be set"; end if; Py_DECREF (Iter); List.Args := Item; -- Item is a borrowed reference ? Py_INCREF (Item); -- so we just increase the refcount end if; return List; end Nth_Arg; ------------- -- Nth_Arg -- ------------- overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive) return Dictionary_Instance'Class is Lock : Ada_GIL_Lock with Unreferenced; Item : PyObject; Success : Boolean; Dictionary : Python_Dictionary_Instance; begin Dictionary.Script := Data.Script; Get_Param (Data, N, Item, Success); if not Success then Dictionary.Dict := PyDict_New; -- An empty dictionary else if not PyDict_Check (Item) then Raise_Exception (Invalid_Parameter'Identity, "Parameter" & Integer'Image (N) & " should be dictionary"); end if; Dictionary.Dict := Item; -- Item is a borrowed reference ? Py_INCREF (Item); -- so we just increase the refcount end if; return Dictionary; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive; Success : access Boolean) return String is Item : PyObject; begin Get_Param (Data, N, Item, Success.all); if not Success.all then return ""; end if; if PyString_Check (Item) then return PyString_AsString (Item); elsif PyUnicode_Check (Item) then return Unicode_AsString (Item, "utf-8"); else raise Invalid_Parameter with "Parameter" & Integer'Image (N) & " should be a string or unicode"; end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive; Success : access Boolean) return Unbounded_String is Item : PyObject; begin Get_Param (Data, N, Item, Success.all); if not Success.all then return Null_Unbounded_String; end if; return To_Unbounded_String (String'(Nth_Arg (Data, N, Success))); end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive; Success : access Boolean) return Integer is Item : PyObject; begin Get_Param (Data, N, Item, Success.all); if not Success.all then return 0; end if; if not PyInt_Check (Item) then raise Invalid_Parameter with "Parameter" & Integer'Image (N) & " should be an integer"; else return Integer (PyInt_AsLong (Item)); end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive; Success : access Boolean) return Float is Item : PyObject; begin Get_Param (Data, N, Item, Success.all); if not Success.all then return 0.0; end if; if not PyFloat_Check (Item) then if PyInt_Check (Item) then return Float (PyInt_AsLong (Item)); else raise Invalid_Parameter with "Parameter" & Integer'Image (N) & " should be a float"; end if; else return Float (PyFloat_AsDouble (Item)); end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive; Success : access Boolean) return Boolean is Item : PyObject; begin Get_Param (Data, N, Item, Success.all); if not Success.all then return False; end if; -- For backward compatibility, accept these as "False" values. -- Don't check for unicode here, which was never supported anyway. if PyString_Check (Item) and then (To_Lower (PyString_AsString (Item)) = "false" or else PyString_AsString (Item) = "0") then Insert_Text (Get_Script (Data), null, "Warning: using string 'false' instead of" & " boolean False is obsolescent"); return False; else -- Use standard python behavior return PyObject_IsTrue (Item); end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive; Success : access Boolean) return Subprogram_Type is Item : PyObject; begin Get_Param (Data, N, Item, Success.all); if not Success.all then return null; end if; if Item /= null and then (PyFunction_Check (Item) or else PyMethod_Check (Item)) then Py_INCREF (Item); return new Python_Subprogram_Record' (Subprogram_Record with Script => Python_Scripting (Get_Script (Data)), Subprogram => Item); else raise Invalid_Parameter; end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive; Class : Class_Type; Allow_Null : Boolean; Success : access Boolean) return Class_Instance is Item : PyObject; C : PyObject; Item_Class : PyObject; begin if Class /= Any_Class then C := Lookup_Object (Data.Script, Class.Qualified_Name.all); end if; Get_Param (Data, N, Item, Success.all); -- Item is a borrowed reference if not Success.all then return No_Class_Instance; end if; if Class /= Any_Class and then not PyObject_IsInstance (Item, C) then raise Invalid_Parameter with "Parameter" & Integer'Image (N) & " should be an instance of " & Get_Name (Class); end if; Item_Class := PyObject_GetAttrString (Item, "__class__"); -- Item_Class must be DECREF'd if Item_Class = null then raise Invalid_Parameter with "Parameter" & Integer'Image (N) & " should be an instance of " & Get_Name (Class) & " but has no __class__"; end if; Py_DECREF (Item_Class); return Get_CI (Python_Scripting (Get_Script (Data)), Item); exception when No_Such_Parameter => if Allow_Null then return No_Class_Instance; else raise; end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive) return String is Lock : Ada_GIL_Lock with Unreferenced; Success : aliased Boolean; Result : constant String := Nth_Arg (Data, N, Success'Access); begin if not Success then raise No_Such_Parameter with N'Img; else return Result; end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive) return Unbounded_String is Lock : Ada_GIL_Lock with Unreferenced; Success : aliased Boolean; Result : constant Unbounded_String := Nth_Arg (Data, N, Success'Access); begin if not Success then raise No_Such_Parameter with N'Img; else return Result; end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive) return Integer is Lock : Ada_GIL_Lock with Unreferenced; Success : aliased Boolean; Result : constant Integer := Nth_Arg (Data, N, Success'Access); begin if not Success then raise No_Such_Parameter with N'Img; else return Result; end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive) return Float is Lock : Ada_GIL_Lock with Unreferenced; Success : aliased Boolean; Result : constant Float := Nth_Arg (Data, N, Success'Access); begin if not Success then raise No_Such_Parameter with N'Img; else return Result; end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive) return Boolean is Lock : Ada_GIL_Lock with Unreferenced; Success : aliased Boolean; Result : constant Boolean := Nth_Arg (Data, N, Success'Access); begin if not Success then raise No_Such_Parameter with N'Img; else return Result; end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive) return Subprogram_Type is Lock : Ada_GIL_Lock with Unreferenced; Success : aliased Boolean; Result : constant Subprogram_Type := Nth_Arg (Data, N, Success'Access); begin if not Success then raise No_Such_Parameter with N'Img; else return Result; end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive; Class : Class_Type; Allow_Null : Boolean := False) return Class_Instance is Lock : Ada_GIL_Lock with Unreferenced; Success : aliased Boolean; Result : constant Class_Instance := Nth_Arg (Data, N, Class, Allow_Null, Success'Access); begin if not Success then if Allow_Null then return No_Class_Instance; else raise No_Such_Parameter with N'Img; end if; else return Result; end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive; Default : String) return String is Lock : Ada_GIL_Lock with Unreferenced; Success : aliased Boolean; Result : constant String := Nth_Arg (Data, N, Success'Access); begin if not Success then return Default; else return Result; end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive; Default : Integer) return Integer is Lock : Ada_GIL_Lock with Unreferenced; Success : aliased Boolean; Result : constant Integer := Nth_Arg (Data, N, Success'Access); begin if not Success then return Default; else return Result; end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive; Default : Boolean) return Boolean is Lock : Ada_GIL_Lock with Unreferenced; Success : aliased Boolean; Result : constant Boolean := Nth_Arg (Data, N, Success'Access); begin if not Success then return Default; else return Result; end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive; Class : Class_Type := Any_Class; Default : Class_Instance; Allow_Null : Boolean := False) return Class_Instance is Lock : Ada_GIL_Lock with Unreferenced; Success : aliased Boolean; Result : constant Class_Instance := Nth_Arg (Data, N, Class, Allow_Null, Success'Access); begin if not Success then return Default; else return Result; end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive; Default : Subprogram_Type) return Subprogram_Type is Lock : Ada_GIL_Lock with Unreferenced; Success : aliased Boolean; Result : constant Subprogram_Type := Nth_Arg (Data, N, Success'Access); begin if not Success then return Default; else return Result; end if; end Nth_Arg; ------------------- -- Get_User_Data -- ------------------- overriding function Get_User_Data (Inst : not null access Python_Class_Instance_Record) return access User_Data_List is begin if not Finalized then declare Lock : Ada_GIL_Lock with Unreferenced; Item : constant PyObject := PyObject_GetAttrString (Inst.Data, "__gps_data"); Data : PyObject; Tmp : PyObject_Data; Tmp_Addr : System.Address; begin if Item = null then PyErr_Clear; -- error about "no such attribute" Tmp := new PyObject_Data_Record; Data := PyCObject_FromVoidPtr (Tmp.all'Address, On_PyObject_Data_Destroy'Access); if PyObject_GenericSetAttrString (Inst.Data, "__gps_data", Data) /= 0 then Trace (Me, "Error creating __gps_data"); PyErr_Clear; Py_DECREF (Data); Unchecked_Free (Tmp); return null; end if; Py_DECREF (Data); return Tmp.Props'Access; else Tmp_Addr := PyCObject_AsVoidPtr (Item); Tmp := Convert (Tmp_Addr); Py_DECREF (Item); return Tmp.Props'Access; end if; end; else return null; end if; end Get_User_Data; ------------------------------ -- On_PyObject_Data_Destroy -- ------------------------------ procedure On_PyObject_Data_Destroy (Data : System.Address) is D : PyObject_Data := Convert (Data); begin Free_User_Data_List (D.Props); Unchecked_Free (D); end On_PyObject_Data_Destroy; --------------------------------- -- Unregister_Python_Scripting -- --------------------------------- procedure Unregister_Python_Scripting (Repo : access Scripts.Scripts_Repository_Record'Class) is Script : constant Scripting_Language := Lookup_Scripting_Language (Repo, Python_Name); begin if Script /= null then Destroy (Script); end if; end Unregister_Python_Scripting; ------------ -- Get_CI -- ------------ function Get_CI (Script : Python_Scripting; Object : PyObject) return Class_Instance is CI : Python_Class_Instance; begin PyErr_Clear; -- If there was no instance, avoid a python exception later CI := new Python_Class_Instance_Record; CI.Script := Script; CI.Data := Object; -- adopts the object Py_INCREF (Object); -- the class_instance needs to own one ref (decref'ed in Free) return R : Class_Instance do CI_Pointers.Set (R.Ref, CI); end return; end Get_CI; ---------- -- Free -- ---------- overriding procedure Free (Self : in out Python_Class_Instance_Record) is begin if not Finalized then declare Lock : Ada_GIL_Lock with Unreferenced; begin Py_XDECREF (Self.Data); end; end if; end Free; ------------------ -- Get_PyObject -- ------------------ function Get_PyObject (Instance : Class_Instance) return PyObject is begin return Python_Class_Instance (Get_CIR (Instance)).Data; end Get_PyObject; ----------------- -- Is_Subclass -- ----------------- function Is_Subclass (Instance : access Python_Class_Instance_Record; Base : String) return Boolean is Lock : Ada_GIL_Lock with Unreferenced; C, B : PyObject; begin if Instance.Data = null then raise Program_Error; end if; C := PyObject_GetAttrString (Instance.Data, "__class__"); B := Lookup_Object (Python_Scripting (Instance.Script), Base); return Py_IsSubclass (C, Base => B); end Is_Subclass; ------------------------ -- Setup_Return_Value -- ------------------------ procedure Setup_Return_Value (Data : in out Python_Callback_Data'Class) is begin Py_XDECREF (Data.Return_Value); Data.Has_Return_Value := True; Data.Return_As_List := False; Data.Return_Value := null; end Setup_Return_Value; ------------------- -- Set_Error_Msg -- ------------------- procedure Set_Error_Msg (Data : in out Python_Callback_Data; Msg : String) is Lock : Ada_GIL_Lock with Unreferenced; begin Setup_Return_Value (Data); if Msg /= "" then PyErr_SetString (Data.Script.Exception_Misc, Msg); end if; end Set_Error_Msg; ----------------------- -- Prepare_Value_Key -- ----------------------- procedure Prepare_Value_Key (Data : in out Python_Callback_Data'Class; Key : PyObject; Append : Boolean) is Obj, List : PyObject; Tmp : Integer; pragma Unreferenced (Tmp); Created_List : Boolean := False; begin if Data.Return_Dict = null then Data.Return_Dict := PyDict_New; end if; if Append then Obj := PyDict_GetItem (Data.Return_Dict, Key); if Obj /= null then if PyList_Check (Obj) then List := Obj; else List := PyList_New; Tmp := PyList_Append (List, Obj); Created_List := True; end if; Tmp := PyList_Append (List, Data.Return_Value); else List := Data.Return_Value; end if; else List := Data.Return_Value; end if; Tmp := PyDict_SetItem (Data.Return_Dict, Key, List); if Created_List then Py_DECREF (List); -- The only reference is now owned by the dictionary end if; -- Return_Value was either added to the value or directly to the -- dictionary. In both cases, its refcount was increased by one. Py_DECREF (Data.Return_Value); Data.Return_Value := Py_None; Py_INCREF (Data.Return_Value); Data.Return_As_List := False; end Prepare_Value_Key; -------------------------- -- Set_Return_Value_Key -- -------------------------- procedure Set_Return_Value_Key (Data : in out Python_Callback_Data; Key : Integer; Append : Boolean := False) is Lock : Ada_GIL_Lock with Unreferenced; K : constant PyObject := PyInt_FromLong (long (Key)); begin Prepare_Value_Key (Data, K, Append); Py_DECREF (K); end Set_Return_Value_Key; -------------------------- -- Set_Return_Value_Key -- -------------------------- procedure Set_Return_Value_Key (Data : in out Python_Callback_Data; Key : String; Append : Boolean := False) is Lock : Ada_GIL_Lock with Unreferenced; K : constant PyObject := PyString_FromString (Key); begin Prepare_Value_Key (Data, K, Append); Py_DECREF (K); end Set_Return_Value_Key; -------------------------- -- Set_Return_Value_Key -- -------------------------- procedure Set_Return_Value_Key (Data : in out Python_Callback_Data; Key : Class_Instance; Append : Boolean := False) is Lock : Ada_GIL_Lock with Unreferenced; K : constant PyObject := Python_Class_Instance (Get_CIR (Key)).Data; begin Prepare_Value_Key (Data, K, Append); -- Do not decrease the reference counting here (even though the key has -- now one more reference owned by Data.Return_Dict), since a -- Class_Instance is refcounted as well, and will automatically decrease -- the reference counting when no longer in use -- Py_DECREF (K); end Set_Return_Value_Key; ------------------------------ -- Set_Return_Value_As_List -- ------------------------------ procedure Set_Return_Value_As_List (Data : in out Python_Callback_Data; Size : Natural := 0; Class : Class_Type := No_Class) is pragma Unreferenced (Size); Lock : Ada_GIL_Lock with Unreferenced; begin Setup_Return_Value (Data); Data.Return_As_List := True; Data.Has_Return_Value := True; if Class = No_Class then Data.Return_Value := PyList_New; else declare C : constant Class_Instance := New_Instance (Data.Script, Class); begin if C = No_Class_Instance then raise Program_Error; end if; Data.Return_Value := Python_Class_Instance (Get_CIR (C)).Data; Py_INCREF (Data.Return_Value); end; end if; end Set_Return_Value_As_List; ---------------------- -- Set_Return_Value -- ---------------------- procedure Set_Return_Value (Data : in out Python_Callback_Data; Value : PyObject) is Lock : Ada_GIL_Lock with Unreferenced; Num : Integer; pragma Unreferenced (Num); begin if Data.Return_As_List then Num := PyList_Append (Data.Return_Value, Value); else Setup_Return_Value (Data); Data.Return_Value := Value; Py_INCREF (Value); end if; end Set_Return_Value; ---------------------- -- Set_Return_Value -- ---------------------- procedure Set_Return_Value (Data : in out Python_Callback_Data; Value : Integer) is Lock : Ada_GIL_Lock with Unreferenced; Val : constant PyObject := PyInt_FromLong (long (Value)); begin Set_Return_Value (Data, Val); Py_DECREF (Val); end Set_Return_Value; ------------------------------ -- Set_Address_Return_Value -- ------------------------------ overriding procedure Set_Address_Return_Value (Data : in out Python_Callback_Data; Value : System.Address) is Lock : Ada_GIL_Lock with Unreferenced; Val : constant PyObject := PyInt_FromSize_t (size_t (To_Integer (Value))); begin Set_Return_Value (Data, Val); Py_DECREF (Val); end Set_Address_Return_Value; ---------------------- -- Set_Return_Value -- ---------------------- procedure Set_Return_Value (Data : in out Python_Callback_Data; Value : Float) is Lock : Ada_GIL_Lock with Unreferenced; Val : constant PyObject := PyFloat_FromDouble (double (Value)); begin Set_Return_Value (Data, Val); Py_DECREF (Val); end Set_Return_Value; ---------------------- -- Set_Return_Value -- ---------------------- procedure Set_Return_Value (Data : in out Python_Callback_Data; Value : String) is Lock : Ada_GIL_Lock with Unreferenced; Val : constant PyObject := PyString_FromString (Value); begin Set_Return_Value (Data, Val); Py_DECREF (Val); end Set_Return_Value; ---------------------- -- Set_Return_Value -- ---------------------- procedure Set_Return_Value (Data : in out Python_Callback_Data; Value : Boolean) is Lock : Ada_GIL_Lock with Unreferenced; Val : constant PyObject := PyBool_FromBoolean (Value); begin Set_Return_Value (Data, Val); Py_DECREF (Val); end Set_Return_Value; ---------------------- -- Set_Return_Value -- ---------------------- procedure Set_Return_Value (Data : in out Python_Callback_Data; Value : Class_Instance) is Lock : Ada_GIL_Lock with Unreferenced; V : constant Python_Class_Instance := Python_Class_Instance (Get_CIR (Value)); Obj : PyObject; Num : Integer; pragma Unreferenced (Num); begin if V /= null then Obj := V.Data; if Active (Me) then Assert (Me, V.Data /= null, "A Class_Instance has no PyObject"); end if; else Obj := Py_None; end if; if Data.Return_As_List then Num := PyList_Append (Data.Return_Value, Obj); -- Increase refcount -- Py_DECREF (Obj); -- The reference to Object is adopted by the result else Setup_Return_Value (Data); Data.Return_Value := Obj; Py_INCREF (Obj); end if; end Set_Return_Value; ---------------------- -- Set_Return_Value -- ---------------------- procedure Set_Return_Value (Data : in out Python_Callback_Data; Value : List_Instance) is Lock : Ada_GIL_Lock with Unreferenced; V : constant PyObject := Python_Callback_Data (Value).Args; Num : Integer; pragma Unreferenced (Num); begin if Data.Return_As_List then Num := PyList_Append (Data.Return_Value, V); -- Increase refcount else Py_INCREF (V); Setup_Return_Value (Data); Data.Return_Value := V; end if; end Set_Return_Value; -------------- -- New_List -- -------------- overriding function New_List (Script : access Python_Scripting_Record; Class : Class_Type := No_Class) return List_Instance'Class is Lock : Ada_GIL_Lock with Unreferenced; List : Python_Callback_Data; begin List.Script := Python_Scripting (Script); List.First_Arg_Is_Self := False; if Class = No_Class then List.Args := PyList_New; else declare C : constant Class_Instance := New_Instance (Script, Class); begin if C = No_Class_Instance then raise Program_Error; end if; List.Args := Python_Class_Instance (Get_CIR (C)).Data; Py_INCREF (List.Args); end; end if; return List; end New_List; ------------------ -- New_Instance -- ------------------ function New_Instance (Script : access Python_Scripting_Record; Class : Class_Type) return Class_Instance is Lock : Ada_GIL_Lock with Unreferenced; Klass : constant PyObject := Lookup_Object (Script, Class.Qualified_Name.all); Inst : Class_Instance; Obj : PyObject; Args : PyObject; begin if Klass = null then return No_Class_Instance; end if; -- Creating a new instance is equivalent to calling its metaclass. This -- is true for both new-style classes and old-style classes (for which -- the tp_call slot is set to PyInstance_New. -- Here, we are in fact calling Class.__new__ (cls, *args, **kwargs). -- After allocating memory, this in turns automatically tp_init in the -- type definition, which in the case of GNATCOLL cases is often set to -- slot_tp_init. The latter in turn calls __init__ -- -- ??? This API does not permit passing extra parameters to the call Args := PyTuple_New (0); Script.Ignore_Constructor := True; Obj := PyObject_Call (Object => Klass, Args => Args, Kw => null); -- NOT: Py_None, which is not a valid dictionary Script.Ignore_Constructor := False; Py_DECREF (Args); if Obj = null then if Active (Me) then Trace (Me, "Could not create instance"); PyErr_Print; -- debugging only end if; return No_Class_Instance; end if; if Active (Me) then Assert (Me, Get_Refcount (Obj) = 1, "Object's refcount should be 1, got " & Get_Refcount (Obj)'Img, Raise_Exception => False); end if; Inst := Get_CI (Python_Scripting (Script), Obj); -- increases refcount Py_DECREF (Obj); -- The PyObject should have a single reference in the end, owned by -- the class instance itself. if Active (Me) then Assert (Me, Get_Refcount (Python_Class_Instance (Get_CIR (Inst)).Data) = 1, "New_Instance should own a single refcount of PyObject, got " & Print_Refcount (Get_CIR (Inst)), Raise_Exception => False); end if; return Inst; exception when others => Script.Ignore_Constructor := False; raise; end New_Instance; ---------------- -- Get_Method -- ---------------- overriding function Get_Method (Instance : access Python_Class_Instance_Record; Name : String) return Subprogram_Type is Lock : Ada_GIL_Lock with Unreferenced; Inst : constant PyObject := Instance.Data; Subp : constant PyObject := PyObject_GetAttrString (Inst, Name => Name); begin if Subp = null then -- Clear the raised python exception PyErr_Clear; return null; else return new Python_Subprogram_Record' (Script => Python_Scripting (Instance.Script), Subprogram => Subp); end if; end Get_Method; -------------------- -- Print_Refcount -- -------------------- function Print_Refcount (Instance : access Python_Class_Instance_Record) return String is begin if Instance.Data /= null then return Print_Refcount (Class_Instance_Record (Instance.all)'Access) & " Py=" & Value (Refcount_Msg (Instance.Data)); else return Print_Refcount (Class_Instance_Record (Instance.all)'Access) & " Py="; end if; end Print_Refcount; ------------- -- Execute -- ------------- overriding function Execute (Subprogram : access Python_Subprogram_Record; Args : Callback_Data'Class; Error : not null access Boolean) return Boolean is Lock : Ada_GIL_Lock with Unreferenced; begin return Execute_Command (Script => Subprogram.Script, Command => Subprogram.Subprogram, Args => Args, Error => Error); end Execute; ------------- -- Execute -- ------------- overriding function Execute (Subprogram : access Python_Subprogram_Record; Args : Callback_Data'Class; Error : not null access Boolean) return String is Lock : Ada_GIL_Lock with Unreferenced; begin return Execute_Command (Script => Subprogram.Script, Command => Subprogram.Subprogram, Args => Args, Error => Error); end Execute; ------------- -- Execute -- ------------- overriding function Execute (Subprogram : access Python_Subprogram_Record; Args : Callback_Data'Class; Error : not null access Boolean) return Class_Instance is Lock : Ada_GIL_Lock with Unreferenced; Obj : PyObject; begin Obj := Execute_Command (Script => Subprogram.Script, Command => Subprogram.Subprogram, Args => Args, Error => Error); if Obj = null then return No_Class_Instance; else return Get_CI (Subprogram.Script, Obj); end if; end Execute; ------------- -- Execute -- ------------- overriding function Execute (Subprogram : access Python_Subprogram_Record; Args : Callback_Data'Class; Error : not null access Boolean) return List_Instance'Class is Lock : Ada_GIL_Lock with Unreferenced; Obj : PyObject; List : Python_Callback_Data; begin Obj := Execute_Command (Script => Subprogram.Script, Command => Subprogram.Subprogram, Args => Args, Error => Error); List.Script := Subprogram.Script; List.First_Arg_Is_Self := False; List.Args := Obj; -- now owns the reference to Obj return List; end Execute; ------------- -- Execute -- ------------- overriding function Execute (Subprogram : access Python_Subprogram_Record; Args : Callback_Data'Class; Error : not null access Boolean) return Any_Type is Lock : Ada_GIL_Lock with Unreferenced; begin return Execute_Command (Script => Subprogram.Script, Command => Subprogram.Subprogram, Args => Args, Error => Error); end Execute; ------------- -- Execute -- ------------- function Execute (Subprogram : access Python_Subprogram_Record; Args : Callback_Data'Class; Error : not null access Boolean) return GNAT.Strings.String_List is Lock : Ada_GIL_Lock with Unreferenced; Obj : constant PyObject := Execute_Command (Script => Subprogram.Script, Command => Subprogram.Subprogram, Args => Args, Error => Error); begin if Obj = null then return (1 .. 0 => null); elsif Obj = Py_None then Py_DECREF (Obj); return (1 .. 0 => null); elsif PyString_Check (Obj) then declare Str : constant String := PyString_AsString (Obj); begin Py_DECREF (Obj); return (1 .. 1 => new String'(Str)); end; elsif PyUnicode_Check (Obj) then declare Str : constant String := Unicode_AsString (Obj); begin Py_DECREF (Obj); return (1 .. 1 => new String'(Str)); end; elsif PyList_Check (Obj) then declare Result : GNAT.Strings.String_List (1 .. PyList_Size (Obj)); Item : PyObject; begin for J in 0 .. PyList_Size (Obj) - 1 loop Item := PyList_GetItem (Obj, J); if PyString_Check (Item) then Result (J + 1) := new String'(PyString_AsString (Item)); elsif PyUnicode_Check (Item) then Result (J + 1) := new String'(Unicode_AsString (Item)); end if; end loop; Py_DECREF (Obj); return Result; end; end if; Py_DECREF (Obj); return (1 .. 0 => null); end Execute; ---------- -- Free -- ---------- procedure Free (Subprogram : in out Python_Subprogram_Record) is begin if not Finalized then declare Lock : Ada_GIL_Lock with Unreferenced; begin Py_DECREF (Subprogram.Subprogram); end; end if; end Free; -------------- -- Get_Name -- -------------- function Get_Name (Subprogram : access Python_Subprogram_Record) return String is Lock : Ada_GIL_Lock with Unreferenced; S : constant PyObject := PyObject_Str (Subprogram.Subprogram); Name : constant String := PyString_AsString (S); begin Py_DECREF (S); return Name; end Get_Name; ---------------- -- Get_Script -- ---------------- function Get_Script (Subprogram : Python_Subprogram_Record) return Scripting_Language is begin return Scripting_Language (Subprogram.Script); end Get_Script; ------------------------- -- Set_Default_Console -- ------------------------- procedure Set_Default_Console (Script : access Python_Scripting_Record; Console : Virtual_Console) is Lock : Ada_GIL_Lock with Unreferenced; Inst : Class_Instance; Cons : PyObject := Py_None; Errors : aliased Boolean; begin Set_Default_Console (Scripting_Language_Record (Script.all)'Access, Console); if Console /= null and then Get_Console_Class (Get_Repository (Script)) /= No_Class then Inst := Get_Instance (Script, Console); if Inst = No_Class_Instance then Inst := New_Instance (Script, Get_Console_Class (Get_Repository (Script))); Set_Data (Inst, Console => Console); end if; Cons := Python_Class_Instance (Get_CIR (Inst)).Data; PyDict_SetItemString (PyModule_GetDict (PyImport_ImportModule ("sys")), "stdout", Cons); PyDict_SetItemString (PyModule_GetDict (PyImport_ImportModule ("sys")), "stderr", Cons); PyDict_SetItemString (PyModule_GetDict (PyImport_ImportModule ("sys")), "stdin", Cons); else Cons := Run_Command (Script, "sys.stdout, sys.stdin, sys.stderr = " & "sys.__stdout__, sys.__stdin__, sys.__stderr__", Hide_Output => True, Need_Output => False, Errors => Errors'Access); Py_XDECREF (Cons); end if; end Set_Default_Console; ------------------ -- Set_Property -- ------------------ overriding procedure Set_Property (Instance : access Python_Class_Instance_Record; Name : String; Value : Integer) is Lock : Ada_GIL_Lock with Unreferenced; Val : PyObject; Result : Integer with Unreferenced; begin Val := PyInt_FromLong (long (Value)); Result := PyObject_GenericSetAttrString (Instance.Data, Name, Val); Py_DECREF (Val); end Set_Property; overriding procedure Set_Property (Instance : access Python_Class_Instance_Record; Name : String; Value : Float) is Lock : Ada_GIL_Lock with Unreferenced; Val : PyObject; Result : Integer with Unreferenced; begin Val := PyFloat_FromDouble (double (Value)); Result := PyObject_GenericSetAttrString (Instance.Data, Name, Val); Py_DECREF (Val); end Set_Property; overriding procedure Set_Property (Instance : access Python_Class_Instance_Record; Name : String; Value : Boolean) is Lock : Ada_GIL_Lock with Unreferenced; Val : PyObject; Result : Integer with Unreferenced; begin Val := PyBool_FromBoolean (Value); Result := PyObject_GenericSetAttrString (Instance.Data, Name, Val); Py_DECREF (Val); end Set_Property; overriding procedure Set_Property (Instance : access Python_Class_Instance_Record; Name : String; Value : String) is Lock : Ada_GIL_Lock with Unreferenced; Val : PyObject; Result : Integer with Unreferenced; begin Val := PyString_FromString (Value); Result := PyObject_GenericSetAttrString (Instance.Data, Name, Val); Py_DECREF (Val); end Set_Property; -------------------- -- Load_Directory -- -------------------- overriding procedure Load_Directory (Script : access Python_Scripting_Record; Directory : GNATCOLL.VFS.Virtual_File; To_Load : Script_Loader := Load_All'Access) is Lock : Ada_GIL_Lock with Unreferenced; Files : File_Array_Access; Path : constant String := +Directory.Full_Name (True); Last : Integer := Path'Last; Errors : Boolean; begin if not Directory.Is_Directory then return; end if; Trace (Me, "Load python files from " & Path); -- Add the directory to the default python search path. -- Python requires no trailing dir separator (at least on Windows) if Is_Directory_Separator (Path (Last)) then Last := Last - 1; end if; Execute_Command (Script, Create ("sys.path=[r'" & Path (Path'First .. Last) & "']+sys.path"), Show_Command => False, Hide_Output => True, Errors => Errors); -- ??? Should also check for python modules (ie subdirectories that -- contain a __init__.py file Files := Directory.Read_Dir; -- Sort the files, to make the load order more stable than the -- filesystem order. Sort (Files.all); for J in Files'Range loop if Equal (Files (J).File_Extension, ".py") then if To_Load (Files (J)) then Trace (Me, "Load " & Files (J).Display_Full_Name); Execute_Command (Script, Create ("import " & (+Base_Name (Files (J), ".py"))), Show_Command => False, Hide_Output => True, Errors => Errors); end if; elsif Is_Regular_File (Create_From_Dir (Files (J), "__init__.py")) and then To_Load (Files (J)) then Trace (Me, "Load " & (+Base_Dir_Name (Files (J))) & "/"); Execute_Command (Script, Create ("import " & (+Base_Dir_Name (Files (J)))), Show_Command => False, Hide_Output => True, Errors => Errors); end if; end loop; Unchecked_Free (Files); end Load_Directory; ------------------------ -- Execute_Expression -- ------------------------ overriding procedure Execute_Expression (Result : in out Python_Callback_Data; Expression : String; Hide_Output : Boolean := True) is Lock : Ada_GIL_Lock with Unreferenced; Script : constant Python_Scripting := Python_Scripting (Get_Script (Result)); Res : PyObject; Errors : aliased Boolean; begin if Script.Blocked then Set_Error_Msg (Result, "A command is already executing"); else Res := Run_Command (Script, Command => Expression, Hide_Output => Hide_Output, Hide_Exceptions => Hide_Output, Need_Output => True, Errors => Errors'Access); Setup_Return_Value (Result); if Errors then Py_XDECREF (Res); PyErr_Clear; raise Error_In_Command with "Error in '" & Expression & "()'"; else Result.Return_Value := Res; -- Adopts a reference end if; end if; end Execute_Expression; --------------------- -- Execute_Command -- --------------------- overriding procedure Execute_Command (Args : in out Python_Callback_Data; Command : String; Hide_Output : Boolean := True) is Lock : Ada_GIL_Lock with Unreferenced; Script : constant Python_Scripting := Python_Scripting (Get_Script (Args)); Func : PyObject; Errors : aliased Boolean; Result : PyObject; begin if Script.Blocked then Set_Error_Msg (Args, "A command is already executing"); else -- Fetch a handle on the function to execute. What we want to execute -- is: -- func = module.function_name -- func(args) Func := Run_Command (Script, Command => Command, Hide_Output => Hide_Output, Need_Output => True, Errors => Errors'Access); if Func /= null and then PyCallable_Check (Func) then Setup_Return_Value (Args); Result := Execute_Command (Script, Func, Args, Errors'Access); if Errors then Py_XDECREF (Result); PyErr_Clear; raise Error_In_Command with "Error in '" & Command & "()'"; else Args.Return_Value := Result; -- Adopts a reference end if; else raise Error_In_Command with Command & " is not a function"; end if; end if; end Execute_Command; ------------------ -- Return_Value -- ------------------ overriding function Return_Value (Data : Python_Callback_Data) return String is Lock : Ada_GIL_Lock with Unreferenced; begin if Data.Return_Value = null then raise Invalid_Parameter with "Returned value is null (a python exception ?)"; elsif PyString_Check (Data.Return_Value) then return PyString_AsString (Data.Return_Value); elsif PyUnicode_Check (Data.Return_Value) then return Unicode_AsString (Data.Return_Value); else raise Invalid_Parameter with "Returned value is not a string"; end if; end Return_Value; ------------------ -- Return_Value -- ------------------ overriding function Return_Value (Data : Python_Callback_Data) return Integer is Lock : Ada_GIL_Lock with Unreferenced; begin if not PyInt_Check (Data.Return_Value) then raise Invalid_Parameter with "Returned value is not an integer"; else return Integer (PyInt_AsLong (Data.Return_Value)); end if; end Return_Value; ------------------ -- Return_Value -- ------------------ overriding function Return_Value (Data : Python_Callback_Data) return Float is Lock : Ada_GIL_Lock with Unreferenced; begin if not PyFloat_Check (Data.Return_Value) then raise Invalid_Parameter with "Returned value is not a float"; else return Float (PyFloat_AsDouble (Data.Return_Value)); end if; end Return_Value; ------------------ -- Return_Value -- ------------------ overriding function Return_Value (Data : Python_Callback_Data) return Boolean is Lock : Ada_GIL_Lock with Unreferenced; begin return PyObject_IsTrue (Data.Return_Value); end Return_Value; ------------------ -- Return_Value -- ------------------ overriding function Return_Value (Data : Python_Callback_Data) return Class_Instance is Lock : Ada_GIL_Lock with Unreferenced; begin if Data.Return_Value = Py_None then return No_Class_Instance; else return Get_CI (Python_Scripting (Get_Script (Data)), Data.Return_Value); end if; end Return_Value; ------------------ -- Return_Value -- ------------------ overriding function Return_Value (Data : Python_Callback_Data) return List_Instance'Class is Lock : Ada_GIL_Lock with Unreferenced; List : Python_Callback_Data; Iter : PyObject; begin List.Script := Data.Script; List.First_Arg_Is_Self := False; Iter := PyObject_GetIter (Data.Return_Value); if Iter = null then raise Invalid_Parameter with "Return value is not an iterable"; end if; Py_DECREF (Iter); List.Args := Data.Return_Value; Py_INCREF (List.Args); return List; end Return_Value; -------------- -- Iterator -- -------------- function Iterator (Self : Python_Dictionary_Instance) return Dictionary_Iterator'Class is begin return Python_Dictionary_Iterator' (Script => Self.Script, Dict => Self.Dict, Position => 0, Key => null, Value => null); end Iterator; ---------- -- Next -- ---------- function Next (Self : not null access Python_Dictionary_Iterator) return Boolean is begin if Self.Position /= -1 then PyDict_Next (Self.Dict, Self.Position, Self.Key, Self.Value); end if; return Self.Position /= -1; end Next; ------------- -- Has_Key -- ------------- function Has_Key (Self : Python_Dictionary_Instance; Key : String) return Boolean is K : constant PyObject := PyString_FromString (Key); begin return Result : constant Boolean := PyDict_Contains (Self.Dict, K) do Py_DECREF (K); end return; end Has_Key; ------------- -- Has_Key -- ------------- function Has_Key (Self : Python_Dictionary_Instance; Key : Integer) return Boolean is K : constant PyObject := PyInt_FromLong (Interfaces.C.long (Key)); begin return Result : constant Boolean := PyDict_Contains (Self.Dict, K) do Py_DECREF (K); end return; end Has_Key; ------------- -- Has_Key -- ------------- function Has_Key (Self : Python_Dictionary_Instance; Key : Float) return Boolean is K : constant PyObject := PyFloat_FromDouble (Interfaces.C.double (Key)); begin return Result : constant Boolean := PyDict_Contains (Self.Dict, K) do Py_DECREF (K); end return; end Has_Key; ------------- -- Has_Key -- ------------- function Has_Key (Self : Python_Dictionary_Instance; Key : Boolean) return Boolean is K : constant PyObject := PyBool_FromBoolean (Key); begin return Result : constant Boolean := PyDict_Contains (Self.Dict, K) do Py_DECREF (K); end return; end Has_Key; -------------------- -- Conditional_To -- -------------------- function Conditional_To (Condition : Boolean; Object : PyObject; Name : String) return String is begin if not Condition or else Object = null or else Object = Py_None then return ""; end if; if PyString_Check (Object) then return PyString_AsString (Object); elsif PyUnicode_Check (Object) then return Unicode_AsString (Object, "utf-8"); else raise Invalid_Parameter with Name & " should be a string or unicode"; end if; end Conditional_To; -------------------- -- Conditional_To -- -------------------- function Conditional_To (Condition : Boolean; Object : PyObject; Name : String) return Integer is begin if not Condition or else Object = null or else Object = Py_None then return 0; end if; if PyInt_Check (Object) then return Integer (PyInt_AsLong (Object)); else raise Invalid_Parameter with Name & " should be an integer"; end if; end Conditional_To; -------------------- -- Conditional_To -- -------------------- function Conditional_To (Condition : Boolean; Object : PyObject; Name : String) return Float is begin if not Condition or else Object = null or else Object = Py_None then return 0.0; end if; if not PyFloat_Check (Object) then if PyInt_Check (Object) then return Float (PyInt_AsLong (Object)); else raise Invalid_Parameter with Name & " should be a float"; end if; else return Float (PyFloat_AsDouble (Object)); end if; end Conditional_To; -------------------- -- Conditional_To -- -------------------- function Conditional_To (Condition : Boolean; Script : Scripting_Language; Object : PyObject) return Boolean is begin if not Condition or else Object = null or else Object = Py_None then return False; end if; -- For backward compatibility, accept these as "False" values. -- Don't check for unicode here, which was never supported anyway. if PyString_Check (Object) and then (To_Lower (PyString_AsString (Object)) = "false" or else PyString_AsString (Object) = "0") then Insert_Text (Script, null, "Warning: using string 'false' instead of" & " boolean False is obsolescent"); return False; else -- Use standard python behavior return PyObject_IsTrue (Object); end if; end Conditional_To; ----------------- -- Internal_To -- ----------------- function Internal_To (Object : PyObject; Name : String) return String is begin return Conditional_To (True, Object, Name); end Internal_To; ----------------- -- Internal_To -- ----------------- function Internal_To (Object : PyObject; Name : String) return Integer is begin return Conditional_To (True, Object, Name); end Internal_To; ----------------- -- Internal_To -- ----------------- function Internal_To (Object : PyObject; Name : String) return Float is begin return Conditional_To (True, Object, Name); end Internal_To; ----------------- -- Internal_To -- ----------------- function Internal_To (Script : Scripting_Language; Object : PyObject) return Boolean is begin return Conditional_To (True, Script, Object); end Internal_To; --------- -- Key -- --------- function Key (Self : Python_Dictionary_Iterator) return String is begin return Conditional_To (Self.Position /= -1, Self.Key, "Key"); end Key; --------- -- Key -- --------- function Key (Self : Python_Dictionary_Iterator) return Integer is begin return Conditional_To (Self.Position /= -1, Self.Key, "Key"); end Key; --------- -- Key -- --------- function Key (Self : Python_Dictionary_Iterator) return Float is begin return Conditional_To (Self.Position /= -1, Self.Key, "Key"); end Key; --------- -- Key -- --------- function Key (Self : Python_Dictionary_Iterator) return Boolean is begin return Conditional_To (Self.Position /= -1, Scripting_Language (Self.Script), Self.Key); end Key; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : String) return String is K : constant PyObject := PyUnicode_FromString (Key); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (V, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : Integer) return String is K : constant PyObject := PyInt_FromLong (Interfaces.C.long (Key)); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (V, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : Float) return String is K : constant PyObject := PyFloat_FromDouble (Interfaces.C.double (Key)); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (V, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : Boolean) return String is K : constant PyObject := PyBool_FromBoolean (Key); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (V, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : String) return Integer is K : constant PyObject := PyUnicode_FromString (Key); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (V, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : Integer) return Integer is K : constant PyObject := PyInt_FromLong (Interfaces.C.long (Key)); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (V, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : Float) return Integer is K : constant PyObject := PyFloat_FromDouble (Interfaces.C.double (Key)); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (V, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : Boolean) return Integer is K : constant PyObject := PyBool_FromBoolean (Key); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (V, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : String) return Float is K : constant PyObject := PyUnicode_FromString (Key); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (V, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : Integer) return Float is K : constant PyObject := PyInt_FromLong (Interfaces.C.long (Key)); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (V, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : Float) return Float is K : constant PyObject := PyFloat_FromDouble (Interfaces.C.double (Key)); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (V, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : Boolean) return Float is K : constant PyObject := PyBool_FromBoolean (Key); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (V, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : String) return Boolean is K : constant PyObject := PyUnicode_FromString (Key); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (Scripting_Language (Self.Script), V); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : Integer) return Boolean is K : constant PyObject := PyInt_FromLong (Interfaces.C.long (Key)); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (Scripting_Language (Self.Script), V); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : Float) return Boolean is K : constant PyObject := PyFloat_FromDouble (Interfaces.C.double (Key)); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (Scripting_Language (Self.Script), V); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : Boolean) return Boolean is K : constant PyObject := PyBool_FromBoolean (Key); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (Scripting_Language (Self.Script), V); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Iterator) return String is begin return Conditional_To (Self.Position /= -1, Self.Value, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Iterator) return Integer is begin return Conditional_To (Self.Position /= -1, Self.Value, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Iterator) return Float is begin return Conditional_To (Self.Position /= -1, Self.Value, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Iterator) return Boolean is begin return Conditional_To (Self.Position /= -1, Scripting_Language (Self.Script), Self.Value); end Value; ------------------------- -- Begin_Allow_Threads -- ------------------------- function Begin_Allow_Threads return PyThreadState is -- Import only if the function exists in python, otherwise -- we can undefined symbols error at link time. function PyEval_SaveThread return PyThreadState; pragma Import (C, PyEval_SaveThread, "ada_PyEval_SaveThread"); begin return PyEval_SaveThread; end Begin_Allow_Threads; ------------------------- -- Begin_Allow_Threads -- ------------------------- procedure Begin_Allow_Threads is State : PyThreadState; pragma Unreferenced (State); begin State := Begin_Allow_Threads; end Begin_Allow_Threads; ----------------------- -- End_Allow_Threads -- ----------------------- procedure End_Allow_Threads (State : PyThreadState) is procedure PyEval_RestoreThread (State : PyThreadState); pragma Import (C, PyEval_RestoreThread, "ada_PyEval_RestoreThread"); begin PyEval_RestoreThread (State); end End_Allow_Threads; --------------------------- -- Get_This_Thread_State -- --------------------------- function Get_This_Thread_State return PyThreadState is function PyGILState_GetThisThreadState return PyThreadState; pragma Import (C, PyGILState_GetThisThreadState, "ada_PyGILState_GetThisThreadState"); begin return PyGILState_GetThisThreadState; end Get_This_Thread_State; ------------------------- -- Ensure_Thread_State -- ------------------------- procedure Ensure_Thread_State is function PyGILState_Ensure return Integer; pragma Import (C, PyGILState_Ensure, "ada_PyGILState_Ensure"); Ignored : Integer; pragma Unreferenced (Ignored); begin Ignored := PyGILState_Ensure; end Ensure_Thread_State; -------------------------------- -- Initialize_Threads_Support -- -------------------------------- procedure Initialize_Threads_Support is Lock : Ada_GIL_Lock with Unreferenced; procedure PyEval_InitThreads; pragma Import (C, PyEval_InitThreads, "ada_PyEval_InitThreads"); begin PyEval_InitThreads; end Initialize_Threads_Support; ---------------------- -- Python_Backtrace -- ---------------------- function Python_Backtrace return String is Lock : Ada_GIL_Lock with Unreferenced; F : PyFrameObject := Last_Call_Frame; Aux : Ada.Strings.Unbounded.Unbounded_String; begin if F /= null then while F /= null loop declare Image : String := Integer'Image (PyFrame_GetLineNumber (F)); begin Image (Image'First) := ':'; Append (Aux, " " & PyString_AsString (PyCode_Get_Filename (PyFrame_Get_Code (F))) & Image & ASCII.LF); end; F := PyFrame_Get_Back (F); end loop; end if; return To_String (Aux); end Python_Backtrace; ------------------------------ -- Error_Message_With_Stack -- ------------------------------ function Error_Message_With_Stack return String is Aux : Ada.Strings.Unbounded.Unbounded_String; begin if Last_Call_Frame /= null then Append (Aux, "Unexpected exception: Python execution stack" & ASCII.LF); Append (Aux, Python_Backtrace); return To_String (Aux); else return "Unexpected exception: "; end if; end Error_Message_With_Stack; ----------------------- -- Trace_Python_Code -- ----------------------- function Trace_Python_Code (User_Arg : GNATCOLL.Python.PyObject; Frame : GNATCOLL.Python.PyFrameObject; Why : GNATCOLL.Python.Why_Trace_Func; Object : GNATCOLL.Python.PyObject) return Integer is pragma Unreferenced (User_Arg); pragma Unreferenced (Object); begin if Why in PyTrace_Call | PyTrace_C_Call then if Last_Call_Frame /= null then Py_DECREF (PyObject (Last_Call_Frame)); end if; Last_Call_Frame := Frame; Py_INCREF (PyObject (Last_Call_Frame)); end if; return 0; end Trace_Python_Code; end GNATCOLL.Scripts.Python; gnatcoll-bindings-25.0.0/python/gnatcoll-scripts-python.ads000066400000000000000000000522541464374334300240400ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2003-2019, 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 Ada_05; with Ada.Strings.Unbounded; with GNATCOLL.Python; use GNATCOLL.Python; with System; package GNATCOLL.Scripts.Python is Python_Name : constant String := "python"; procedure Register_Python_Scripting (Repo : access Scripts.Scripts_Repository_Record'Class; Module : String; Program_Name : String := "python"; Python_Home : String := ""); -- All commands and classes will be added in the specified module. -- -- Program_Name should be the name of the program registering Python -- scripting. The interpreter will resove run-time libraries relative to -- this executable. -- -- If Python_Home is non-empty, it will be used as home, and libraries will -- be searched for in /lib/python procedure Unregister_Python_Scripting (Repo : access Scripts.Scripts_Repository_Record'Class); -- Mark the python scripting language as no longer valid. This should be -- called before your application exits, to prevent unwanted storage_error -- in the finalization of the application (since some class_instances might -- be automatically finalized after python itself was destroyed, otherwise) type Python_Scripting_Record is new Scripting_Language_Record with private; type Python_Scripting is access all Python_Scripting_Record'Class; pragma No_Strict_Aliasing (Python_Scripting); type Python_Callback_Data is new Callback_Data with private; function Get_Param (Data : Python_Callback_Data'Class; N : Positive) return PyObject; procedure Get_Param (Data : Python_Callback_Data'Class; N : Positive; Result : out PyObject; Success : out Boolean); -- Return the N-th command line parameter, taking into account the keywords -- if any. -- The returned value is a borrowed reference and must not be DECREF'd procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : PyObject); -- Sets the N-th command line parameter using a low-level PyObject. procedure Set_Return_Value (Data : in out Python_Callback_Data; Value : PyObject); -- Sets the return value using a low-level PyObject. -- The refcounting of Value is increased. function Run_Command (Script : access Python_Scripting_Record'Class; Command : String; Need_Output : Boolean; Console : Virtual_Console := null; Show_Command : Boolean := False; Hide_Output : Boolean := False; Hide_Exceptions : Boolean := False; Errors : access Boolean) return PyObject; -- Execute a command in the interpreter, and send its output to the -- console. Return its return value (which doesn't need to be Py_DECREF, -- since it is a borrowed reference). -- If Hide_Output is True, then nothing is printed on the console. If the -- command is incomplete and would require extra input (a secondary prompt -- in interactive mode), then it is not executed. -- Errors is set to True if there was an error executing the command or -- if the input was incomplete. -- -- If Need_Output is True, the result of Command will be returned -- (otherwise Py_None is returned). However, this also restricts what -- commands can be executed, since only expressions can be called (ie not -- function definitions or import statements, for instance). function Get_PyObject (Instance : Class_Instance) return PyObject; -- Returns the low level PyObject enclosed in a Python Class_Instance. -- You need to be absolutely sure that Instance is a Python Instance. -------------------------- -- Multitasking support -- -------------------------- -- Python itself is not task-safe. It uses a Global Interpreter Lock to -- make sure that a single thread is accessing it at any one time. However, -- to simulate parallelism, it will automatically release and re-acquire -- the lock every 100 or so opcode instructions, thus giving a chance to -- run to other threads. -- -- This has several implications on multitasking Ada programs that want to -- access python: -- - the tasks that do not need to access python do not need anything -- special and can be left as is. -- - other tasks must create a python-specific data structure associated -- with the task. This is done by Ensure_Thread_State below. -- -- In addition, whenever you want to access python, you need to first -- acquire the Global Interpreter Lock (which can conveniently be done -- through Ensure_Thread_Safe). You should then release it when you are -- done manipulating python data structures, through a call to -- Begin_Allow_Threads. As such, a typical Ada program would look like: -- -- Register_Python_Scripting (...); -- Initialize_Threads_Support; -- Begin_Allow_Threads; -- -- and then in all tasks that access python: -- -- Ensure_Thread_State; -- ... python commands -- Begin_Allow_Threads; -- -- NOTE: -- The following functions have no effect if python was compiled without -- support for threading. They do not raise an exception either, so that -- you can run the code even if python doesn't have threads. -- -- Input-Output and multi-tasking -- ------------------------------ -- -- In a multi-tasking application, it is recommended that you always call -- the various Execute_Command subprograms with Hide_Output=>False. -- Otherwise, there might be some confusion where a thread disabled the -- output (which is done by redirecting sys.stdout) but the next one -- puts its back, and thus the output of the first thread is visible in -- the end. This also seems to avoid some errors in the python interpreter -- itself. Has_Thread_Support : constant Boolean; pragma Import (C, Has_Thread_Support, "python_with_thread"); -- Whether python was compiled with support for threading. procedure Initialize_Threads_Support; -- Add support for multi-tasking on the python side. This also acquires the -- Global Interpreter Lock, so you should call Begin_Allow_Threads later on -- to allow other threads to run. type PyThreadState is private; function Begin_Allow_Threads return PyThreadState; procedure Begin_Allow_Threads; -- Allow other python threads to run (for instance because we are blocked -- in a system call or in a section of code that doesn't need to execute -- python commands). This also releases the Global Interpreter Lock. procedure End_Allow_Threads (State : PyThreadState); -- Acquires the Global Interpreter Lock, and make State the current -- python thread. It must correspond to the current system thread. function Get_This_Thread_State return PyThreadState; -- Return the python thread state corresponding to the current -- system thread (hopefully this is also the current python thread, -- but there is no guarantee) procedure Ensure_Thread_State; -- Make sure that the current system thread has an equivalent python -- thread state. This should be called for all tasks created in Ada and -- that need to access python commands. -- This also makes sure that the current python thread state matches the -- system thread (so basically lets python know that a different thread -- is running). -- Finally, this acquires the Global Interpreter Lock (it runs the -- equivalent of End_Allow_Threads) function Python_Backtrace return String; -- Return current traceback of execution of the Python code. private type PyThreadState is new System.Address; ---------------------- -- Python_scripting -- ---------------------- type Python_Scripting_Record is new Scripting_Language_Record with record Repo : Scripts_Repository; Blocked : Boolean := False; Module : PyObject; Builtin : PyObject; Exception_Misc : PyObject; Exception_Missing_Args : PyObject; Exception_Invalid_Arg : PyObject; Exception_Unexpected : PyObject; Globals : PyObject; -- The global symbols for the python interpreter Use_Secondary_Prompt : Boolean := False; -- Which type of prompt should be displayed Buffer : GNAT.Strings.String_Access; -- Buffer for the command, to be added in front of any command before -- executing. This is used for multi-line input. Ignore_Constructor : Boolean := False; -- Whether we are creating a new instance of a class. -- This is used to disable the call to __init__ (for backward -- compatibility and because we wouldn't know how to pass extra -- arguments to New_Instance). In_Process : Boolean := False; -- True while we are processing a command. This is used to control the -- behavior of control-c: either interrupt, or copy. Current_File : Ada.Strings.Unbounded.Unbounded_String; -- The script we are currently executing end record; overriding function Command_Line_Treatment (Script : access Python_Scripting_Record) return Command_Line_Mode; overriding procedure Destroy (Script : access Python_Scripting_Record); overriding procedure Block_Commands (Script : access Python_Scripting_Record; Block : Boolean); overriding procedure Register_Command (Script : access Python_Scripting_Record; Cmd : Command_Descr_Access); overriding procedure Register_Property (Script : access Python_Scripting_Record; Prop : Property_Descr_Access); overriding procedure Register_Class (Script : access Python_Scripting_Record; Name : String; Base : Class_Type := No_Class; Module : Module_Type := Default_Module); overriding function Create (Script : access Python_Scripting_Record; Arguments_Count : Natural) return Callback_Data'Class; overriding function New_Instance (Script : access Python_Scripting_Record; Class : Class_Type) return Class_Instance; overriding procedure Execute_Command (Script : access Python_Scripting_Record; CL : Arg_List; Console : Virtual_Console := null; Hide_Output : Boolean := False; Show_Command : Boolean := True; Errors : out Boolean); overriding function Execute_Command (Script : access Python_Scripting_Record; CL : Arg_List; Console : Virtual_Console := null; Hide_Output : Boolean := False; Show_Command : Boolean := True; Errors : access Boolean) return String; overriding function Execute_Command (Script : access Python_Scripting_Record; CL : Arg_List; Console : Virtual_Console := null; Hide_Output : Boolean := False; Errors : access Boolean) return Boolean; overriding function Execute_Command (Script : access Python_Scripting_Record; Command : String; Args : Callback_Data'Class) return Boolean; function Execute_Command (Script : access Python_Scripting_Record'Class; Command : PyObject; Args : Callback_Data'Class; Error : access Boolean) return String; function Execute_Command (Script : access Python_Scripting_Record'Class; Command : PyObject; Args : Callback_Data'Class; Error : access Boolean) return Any_Type; function Execute_Command (Script : access Python_Scripting_Record'Class; Command : PyObject; Args : Callback_Data'Class; Error : access Boolean) return PyObject; -- Need to unref the returned value function Execute_Command (Script : access Python_Scripting_Record'Class; Command : PyObject; Args : Callback_Data'Class; Error : access Boolean) return Boolean; overriding procedure Load_Directory (Script : access Python_Scripting_Record; Directory : GNATCOLL.VFS.Virtual_File; To_Load : Script_Loader := Load_All'Access); overriding procedure Execute_File (Script : access Python_Scripting_Record; Filename : String; Console : Virtual_Console := null; Hide_Output : Boolean := False; Show_Command : Boolean := True; Errors : out Boolean); overriding function Get_Name (Script : access Python_Scripting_Record) return String; overriding function Get_Repository (Script : access Python_Scripting_Record) return Scripts_Repository; overriding function Current_Script (Script : access Python_Scripting_Record) return String; overriding procedure Set_Default_Console (Script : access Python_Scripting_Record; Console : Virtual_Console); overriding procedure Display_Prompt (Script : access Python_Scripting_Record; Console : Virtual_Console := null); overriding function Get_Prompt (Script : access Python_Scripting_Record) return String; overriding function Interrupt (Script : access Python_Scripting_Record) return Boolean; overriding procedure Complete (Script : access Python_Scripting_Record; Input : String; Completions : out String_Lists.List); overriding function New_List (Script : access Python_Scripting_Record; Class : Class_Type := No_Class) return List_Instance'Class; -- See doc from inherited subprograms type Python_Callback_Data is new Callback_Data with record Script : Python_Scripting; Args, Kw : PyObject; -- Args is a tuple, a list, or any iterable. -- These are the arguments passed by python. If Name_Parameters was -- called, these are modified in place: Kw is reset to null, and its -- contents merged into Args. Args is resized appropriately (to the -- number of arguments passed to Name_Parameters). This cannot be used -- for functions with a variable number of parameters. Return_Value : PyObject; Return_Dict : PyObject; Has_Return_Value : Boolean := False; Return_As_List : Boolean := False; First_Arg_Is_Self : Boolean; -- True if the first argument is "self", ie we are calling a method end record; overriding function Clone (Data : Python_Callback_Data) return Callback_Data'Class; overriding function Get_Script (Data : Python_Callback_Data) return Scripting_Language; overriding function Number_Of_Arguments (Data : Python_Callback_Data) return Natural; overriding procedure Name_Parameters (Data : in out Python_Callback_Data; Names : Cst_Argument_List); overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive) return String; overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive) return Unbounded_String; overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive) return Integer; overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive) return Float; overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive) return Boolean; overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive) return Subprogram_Type; overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive; Class : Class_Type; Allow_Null : Boolean := False) return Class_Instance; overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive; Default : String) return String; overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive; Default : Integer) return Integer; overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive; Default : Boolean) return Boolean; overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive; Class : Class_Type := Any_Class; Default : Class_Instance; Allow_Null : Boolean := False) return Class_Instance; overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive; Default : Subprogram_Type) return Subprogram_Type; overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive) return List_Instance'Class; overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive) return Dictionary_Instance'Class; overriding procedure Set_Error_Msg (Data : in out Python_Callback_Data; Msg : String); overriding procedure Set_Return_Value_As_List (Data : in out Python_Callback_Data; Size : Natural := 0; Class : Class_Type := No_Class); overriding procedure Set_Return_Value (Data : in out Python_Callback_Data; Value : Integer); overriding procedure Set_Return_Value (Data : in out Python_Callback_Data; Value : Float); overriding procedure Set_Return_Value (Data : in out Python_Callback_Data; Value : String); overriding procedure Set_Return_Value (Data : in out Python_Callback_Data; Value : Boolean); overriding procedure Set_Return_Value (Data : in out Python_Callback_Data; Value : Class_Instance); overriding procedure Set_Return_Value (Data : in out Python_Callback_Data; Value : List_Instance); overriding procedure Set_Address_Return_Value (Data : in out Python_Callback_Data; Value : System.Address); overriding procedure Set_Return_Value_Key (Data : in out Python_Callback_Data; Key : String; Append : Boolean := False); overriding procedure Set_Return_Value_Key (Data : in out Python_Callback_Data; Key : Integer; Append : Boolean := False); overriding procedure Set_Return_Value_Key (Data : in out Python_Callback_Data; Key : Class_Instance; Append : Boolean := False); overriding procedure Free (Data : in out Python_Callback_Data); overriding procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : String); overriding procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : Integer); overriding procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : Float); overriding procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : Boolean); overriding procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : Class_Instance); overriding procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : List_Instance); overriding procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : Subprogram_Type); overriding procedure Execute_Command (Args : in out Python_Callback_Data; Command : String; Hide_Output : Boolean := True); overriding function Return_Value (Data : Python_Callback_Data) return String; overriding function Return_Value (Data : Python_Callback_Data) return Integer; overriding function Return_Value (Data : Python_Callback_Data) return Float; overriding function Return_Value (Data : Python_Callback_Data) return Boolean; overriding function Return_Value (Data : Python_Callback_Data) return Class_Instance; overriding function Return_Value (Data : Python_Callback_Data) return List_Instance'Class; overriding procedure Execute_Expression (Result : in out Python_Callback_Data; Expression : String; Hide_Output : Boolean := True); -- See doc from inherited subprogram end GNATCOLL.Scripts.Python; gnatcoll-bindings-25.0.0/python/gnatcoll_python.gpr000066400000000000000000000110661464374334300224520ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2015-2020, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with "gnatcoll_core"; library project GnatColl_Python is Version := External ("GNATCOLL_VERSION", "0.0"); Name := "gnatcoll_python"; type Build_Type is ("DEBUG", "PROD"); Build : Build_Type := External ("GNATCOLL_BUILD_MODE", External ("BUILD", "PROD")); type Library_Type_Type is ("relocatable", "static", "static-pic"); Library_Type : Library_Type_Type := External ("LIBRARY_TYPE", "static"); Python_CFLAGS := External_As_List ("GNATCOLL_PYTHON_CFLAGS", " "); Python_Libs := External_As_List ("GNATCOLL_PYTHON_LIBS", " "); Python_Static_Lib := External("GNATCOLL_PYTHON_STATIC_LIB", ""); Libpython_Kind := External("GNATCOLL_LIBPYTHON_KIND", "shared"); for Source_Dirs use ("."); for Library_Kind use Library_Type; for Object_Dir use "obj/" & Project'Library_Kind; for Library_Dir use "lib/" & Project'Library_Kind; for Library_Name use Name; for Languages use ("Ada", "C"); case Library_Type is when "relocatable" => for Library_Version use "lib" & Name & Gnatcoll_Core.So_Ext & "." & Version; for Leading_Library_Options use External_As_List ("LDFLAGS", " "); case Libpython_Kind is when "shared" => for Library_Options use Python_Libs; end case; when others => null; end case; package Compiler is case Build is when "DEBUG" => for Switches ("Ada") use ("-g", "-O0", "-gnata", "-gnatVa", "-gnatQ", "-gnaty", "-gnateE", "-gnatwaCJe", "-fstack-check"); for Switches ("C") use ("-g", "-Wunreachable-code") & Python_CFLAGS; when "PROD" => -- Do not use -gnatwe for production mode for Switches ("Ada") use ("-O2", "-gnatn", "-gnatwaCJ"); for Switches ("C") use ("-O2", "-Wunreachable-code") & Python_CFLAGS; end case; for Switches ("Ada") use Compiler'Switches ("Ada") & External_As_List ("ADAFLAGS", " "); for Switches ("C") use Compiler'Switches ("C") & External_As_List ("CFLAGS", " ") & External_As_List ("CPPFLAGS", " "); end Compiler; package Binder is case Build is when "DEBUG" => for Switches ("Ada") use ("-E"); when "PROD" => null; end case; end Binder; package Builder is case Build is when "DEBUG" => for Global_Configuration_Pragmas use "../gnat_debug.adc"; when "PROD" => null; end case; end Builder; package Linker is case Libpython_Kind is when "shared" => for Linker_Options use Python_Libs; when others => for Linker_Options use (Python_Static_Lib) & Python_Libs; end case; end Linker; package Ide is for VCS_Kind use "Git"; end Ide; end GnatColl_Python; gnatcoll-bindings-25.0.0/python/python_support.c000066400000000000000000000526671464374334300220310ustar00rootroot00000000000000/*---------------------------------------------------------------------------- -- G N A T C O L L -- -- -- -- Copyright (C) 2003-2021, 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 this software; see file -- -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- -- of the license. -- ----------------------------------------------------------------------------*/ /* Force a value for the macro. It will only work for gcc, but otherwise * we cannot use the mingwin python with gcc on Windows*/ #define PY_LONG_LONG long long #include #include /* PyCodeObject definition in older versions*/ #include /* PyFrameObject definition */ #include /* On Windows and if we have HAVE_DECLSPEC_DLL defined remove the __declspec(dllexport) attribute from PyMODINIT_FUNC. Having such attribute to flag symbols to export from a DLL means that *only* those symbols are exported. */ #if _WIN32 #ifdef HAVE_DECLSPEC_DLL #undef PyMODINIT_FUNC #define PyMODINIT_FUNC void #endif #endif #undef DEBUG /* #define DEBUG */ #if PY_MAJOR_VERSION >= 3 #ifndef PyDescr_TYPE #define PyDescr_TYPE(x) (((PyDescrObject *)(x))->d_type) #define PyDescr_NAME(x) (((PyDescrObject *)(x))->d_name) #endif #endif /***************************************************************************** * Modules *****************************************************************************/ #if PY_MAJOR_VERSION >= 3 PyMODINIT_FUNC #else PyObject * #endif ada_Py_InitModule4 (char *name, PyMethodDef *methods, char *doc, PyObject *self) { #if PY_MAJOR_VERSION >= 3 struct PyModuleDef def = { PyModuleDef_HEAD_INIT, name, /* m_name */ doc, /* m_doc */ -1, /* m_size */ methods, /* m_methods */ NULL, /* m_reload */ NULL, /* m_traverse */ NULL, /* m_clear */ NULL}; /* m_free */ struct PyModuleDef* module = (struct PyModuleDef*) malloc(sizeof(struct PyModuleDef)); PyObject* mod; PyObject* imported; memcpy(module, &def, sizeof(struct PyModuleDef)); mod = PyModule_Create(module); return imported; #else return Py_InitModule4 (name, methods, doc, self, PYTHON_API_VERSION); #endif } #if PY_MAJOR_VERSION >= 3 // The definition of the module the user is creating via GNATCOLL. // There is a single such module, so it is simpler to declare the // variable as static rather than use calls to malloc(). static PyMethodDef user_methods[] = { {NULL, NULL} /* Sentinel */ }; static struct PyModuleDef user_module = { PyModuleDef_HEAD_INIT, NULL, /* m_name */ NULL, /* m_doc */ -1, /* m_size */ user_methods, /* m_methods */ NULL, /* m_reload */ NULL, /* m_traverse */ NULL, /* m_clear */ NULL /* m_free */ }; #endif static char* user_module_name; PyMODINIT_FUNC init_user_module(void) { //struct PyModuleDef* module = (struct PyModuleDef*)malloc(sizeof(def)); //memcpy(module, &def, sizeof(struct PyModuleDef)); #if PY_MAJOR_VERSION >= 3 return PyModule_Create(&user_module); #else Py_InitModule4 (user_module_name, NULL, "", NULL, PYTHON_API_VERSION); #endif }; // To hide the output, we also need to rewrite displayhook. // Otherwise, calling a python function from Ada will print its // output to stdout (even though we have redirected sys.stdout ?) // So we make sure that nothing is ever printed. We cannot do this // systematically though, since in interactive mode (consoles...) // we still want the usual python behavior. PyObject* ada_py_initialize_and_module(char* program_name, char* name) { PyObject* module; PyObject* imported; user_module_name = strdup(name); #if PY_MAJOR_VERSION >= 3 user_module.m_name = user_module_name; Py_SetProgramName ((wchar_t*)program_name); #else Py_SetProgramName (program_name); #endif PyImport_AppendInittab(user_module_name, init_user_module); Py_InitializeEx(0); #ifdef WITH_THREAD PyEval_InitThreads(); #endif // Initialize the prompt if needed PyObject* prompt = PySys_GetObject ("ps1"); if (prompt == NULL) { prompt = PyUnicode_FromString (">>> "); PySys_SetObject ("ps1", prompt); Py_DECREF (prompt); } prompt = PySys_GetObject ("ps2"); if (prompt == NULL) { prompt = PyUnicode_FromString ("... "); PySys_SetObject ("ps2", prompt); Py_DECREF (prompt); } // Make the user's module visible to scripts. We cannot use // PyImport_ImportModule, which imports the module but doesn't add // it to the global dictionary and as such it is not visible to // user scripts. imported = PyImport_ImportModule(name); if (imported == NULL) { printf ("Could not import module %s", name); return NULL; } // Import 'sys', which is needed for instance in Set_Default_Console // to get access to the default value PyRun_SimpleString("import sys\n"); char* command = (char*)malloc(9 + strlen(name)); strcpy (command, "import "); strcat (command, name); strcat (command, "\n"); PyRun_SimpleString(command); free (command); return imported; }; /************************************************************************ * Methods * To implement methods, we have the following requirements: * - we need to support the notion of bound methods in python (where self * is set automatically by python to the instance that calls the method). * - we need to pass data back to Ada, that was set when the method was * declared. This data describes how the method is implemented in Ada. * The implementation is based on Python descriptors. However, none of the * predefined descriptors provides support for passing data back to Ada. * So we define our own descriptor, heavily based on the predefined one. * * From python, when you do a.foo(), the following occurs behind the scene: * - retrieves "A.foo", as a PyAdaMethodDescrObject * - since this is a descriptor, calls .__get__() to get the function * to execute. In practice, this calls adamethod_descr_get which * creates a bound method through PyMethod_New (bound to 'a') * - call that object. The implementation of classobject.c::method_call * adds self, ie 'a', as the first argument in the tuple of arguments, * then executes the wrapped function. Here, the wrapped function is * a PyCFunction that was created when the method was registered * initially, and that always calls back Ada but always passes the * same 'self' argument (the data Ada itself provided). ************************************************************************/ #if PY_MAJOR_VERSION >= 3 typedef struct { PyDescr_COMMON; PyObject* cfunc; // An instance of PyCFunction, bound with the // data that Ada needs, in the form of a PyCapsule. } PyAdaMethodDescrObject; PyTypeObject PyAdaMethodDescr_Type; int adamethod_descr_initialized = 0; // Implementation of the __get__ descriptor method. The code is heavily // copied from descrobject.c::method_get. static PyObject * adamethod_descr_get (PyAdaMethodDescrObject *descr, PyObject *obj, PyObject *type) { PyObject *res; if (obj == NULL) { Py_INCREF(descr); return (PyObject*) descr; } if (!PyObject_TypeCheck(obj, PyDescr_TYPE(descr))) { PyErr_Format(PyExc_TypeError, "descriptor '%V' for '%s' objects " "doesn't apply to '%s' object", PyDescr_NAME(descr), "?", PyDescr_TYPE(descr)->tp_name, obj->ob_type->tp_name); return NULL; } return PyMethod_New (descr->cfunc, obj); } // Creates a new AdaMethod instance. 'method' is the description of the Ada // function to call, and 'data' is a PyCapsule that is passed to Ada as 'self'. PyObject * PyDescr_NewAdaMethod(PyTypeObject *type, PyObject* cfunc, const char* name) { if (!adamethod_descr_initialized) { adamethod_descr_initialized = 1; memcpy (&PyAdaMethodDescr_Type, &PyMethodDescr_Type, sizeof (PyTypeObject)); PyAdaMethodDescr_Type.tp_basicsize = sizeof(PyAdaMethodDescrObject); PyAdaMethodDescr_Type.tp_descr_get = (descrgetfunc)adamethod_descr_get; } PyAdaMethodDescrObject *descr = (PyAdaMethodDescrObject*) PyType_GenericAlloc (&PyAdaMethodDescr_Type, 0); if (descr != NULL) { Py_XINCREF(type); PyDescr_TYPE(descr) = type; PyDescr_NAME(descr) = PyUnicode_InternFromString(name); if (PyDescr_NAME(descr) == NULL) { Py_DECREF(descr); descr = NULL; } } if (descr != NULL) { descr->cfunc = cfunc; } return (PyObject *)descr; } #endif /* python 3.x */ // Adds a new method to the class 'class'. // 'module' is the module to which the class belongs, and is used to set // the __module__ attribute of the new method. // 'def' described the C function that will be called when the function is // executed in python. // 'data' is data to pass from C->Python->C (generally wrapped in a PyCapsule). // It will be pass as the "Self" argument to First_Level. void ada_py_add_method (PyMethodDef* def, PyObject* data, PyObject* class, PyObject* module) { PyObject* cfunc = PyCFunction_NewEx (def, data, PyUnicode_FromString (PyModule_GetName (module))); #if PY_MAJOR_VERSION >= 3 PyObject* method = PyDescr_NewAdaMethod ((PyTypeObject*)class, cfunc, def->ml_name); #else PyObject* method = PyMethod_New (cfunc, NULL, class); #endif PyObject_SetAttrString (class, def->ml_name, method); Py_DECREF (method); }; /*****************************************************************************/ int ada_pyget_refcount (PyObject* obj) { return obj->ob_refcnt; } char* ada_py_refcount_msg (PyObject* obj) { static char msg[200]; if (obj) { snprintf (msg, 199, "%p (%s, rc=%ld)", obj, obj->ob_type->tp_name, obj->ob_refcnt); } else { msg[0] = '\0'; } return msg; } void ada_py_print_refcount (PyObject* obj, char* msg) { if (obj) printf ("DEBUG %s %s\n", msg, ada_py_refcount_msg (obj)); } void ada_py_incref (PyObject* obj) { Py_INCREF (obj); #ifdef DEBUG ada_py_print_refcount (obj, "after incref"); #endif } void ada_py_decref (PyObject* obj) { #ifdef DEBUG ada_py_print_refcount (obj, "before decref"); #endif Py_DECREF (obj); } void ada_py_xincref (PyObject* obj) { Py_XINCREF (obj); #ifdef DEBUG ada_py_print_refcount (obj, "after xincref"); #endif } void ada_py_xdecref (PyObject* obj) { #ifdef DEBUG ada_py_print_refcount (obj, "before xdecref"); #endif Py_XDECREF (obj); } int ada_pybasestring_check (PyObject* obj) { #if PY_MAJOR_VERSION >= 3 return PyUnicode_Check (obj); #else return PyString_Check (obj) || PyUnicode_Check (obj); #endif } int ada_pystring_check (PyObject* obj) { #if PY_MAJOR_VERSION >= 3 return PyUnicode_Check (obj); #else return PyString_Check (obj); #endif } PyObject* ada_PyUnicode_AsEncodedString (PyObject *unicode, const char *encoding, const char *errors) { #ifdef Py_UNICODE_WIDE return PyUnicodeUCS4_AsEncodedString (unicode, encoding, errors); #else return PyUnicodeUCS2_AsEncodedString (unicode, encoding, errors); #endif } PyObject* ada_PyUnicode_FromString (const char *u) { #if PY_VERSION_HEX >= 0x02060000 #ifdef Py_UNICODE_WIDE return PyUnicodeUCS4_FromString (u); #else return PyUnicodeUCS2_FromString (u); #endif #else /* Not available in this version */ return 0; #endif } int ada_pyunicode_check (PyObject* obj) { return PyUnicode_Check (obj); } int ada_pyint_check (PyObject* obj) { #if PY_MAJOR_VERSION >= 3 return PyLong_Check (obj); #else return PyInt_Check (obj); #endif } int ada_pyfloat_check (PyObject* obj) { return PyFloat_Check (obj); } int ada_pybool_check (PyObject* obj) { #ifdef PyBool_Check return PyBool_Check (obj); #else return 0; #endif } int ada_pybool_is_true (PyObject* obj) { return PyObject_IsTrue (obj); } int ada_pydict_check (PyObject* obj) { return PyDict_Check (obj); } int ada_pyanyset_check (PyObject* obj) { return PyAnySet_Check (obj); } int ada_pyfunction_check (PyObject* obj) { return PyFunction_Check (obj); } PyObject* ada_pyfunction_get_globals (PyObject* obj) { return PyFunction_GET_GLOBALS (obj); } PyObject* ada_pyfunction_get_code (PyObject* obj) { return PyFunction_GET_CODE (obj); } PyObject* ada_pyfunction_get_closure (PyObject* obj) { return PyFunction_GET_CLOSURE (obj); } PyObject* ada_pyfunction_get_defaults (PyObject* obj) { return PyFunction_GET_DEFAULTS (obj); } PyObject* ada_PyEval_EvalCodeEx (PyCodeObject *co, PyObject *globals, PyObject *locals, PyObject *args, PyObject *kwds, PyObject *defs, PyObject *closure) { /* Code copied from funcobject.c::function_call() */ PyObject **k, **d; PyObject* result; PyObject* kwtuple; int nk, nd; if (defs != NULL && PyTuple_Check(defs)) { d = &PyTuple_GET_ITEM((PyTupleObject *)defs, 0); nd = PyTuple_Size(defs); } else { d = NULL; nd = 0; } if (kwds != NULL && PyDict_Check(kwds)) { int i = 0; #if PY_MAJOR_VERSION > 2 || (PY_MAJOR_VERSION==2 && PY_MINOR_VERSION>=5) Py_ssize_t pos = 0; #else int pos = 0; #endif nk = PyDict_Size(kwds); kwtuple = PyTuple_New(2*nk); if (kwtuple == NULL) return NULL; k = &PyTuple_GET_ITEM(kwtuple, 0); pos = i = 0; while (PyDict_Next(kwds, &pos, &k[i], &k[i+1])) { Py_INCREF(k[i]); Py_INCREF(k[i+1]); i += 2; } nk = i/2; } else { k = NULL; nk = 0; } #if PY_MAJOR_VERSION >= 3 result = (PyObject*) PyEval_EvalCodeEx ((PyObject*) co, globals, locals, &PyTuple_GET_ITEM (args, 0) /* args */, PyTuple_Size (args) /* argc*/, k /* kwds */, nk /* kwdc */, d /* defs */, nd /* defcount */, NULL, /* kwdefs */ closure /* closure */); #else result = (PyObject*) PyEval_EvalCodeEx (co, globals, locals, &PyTuple_GET_ITEM (args, 0) /* args */, PyTuple_Size (args) /* argc*/, k /* kwds */, nk /* kwdc */, d /* defs */, nd /* defcount */, closure /* closure */); #endif Py_XDECREF (kwtuple); return result; } int ada_pycobject_check (PyObject* obj) { #if PY_MAJOR_VERSION >= 3 return PyCapsule_CheckExact (obj); #else return PyCObject_Check (obj); #endif } int ada_pytuple_check (PyObject* obj) { return PyTuple_Check (obj); } int ada_pylist_check (PyObject* obj) { return PyList_Check (obj); } int ada_pyiter_check (PyObject* obj) { return PyIter_Check (obj); } int ada_pymethod_check (PyObject* obj) { return PyMethod_Check (obj); } PyTypeObject* ada_gettypeobject (PyObject* obj) { return (PyTypeObject*)(obj->ob_type); } char* ada_tp_name (PyTypeObject* obj) { return (char *)obj->tp_name; } PyObject* ada_py_none () { return Py_None; } PyObject* ada_py_false() { return Py_False; } PyObject* ada_py_true() { return Py_True; } PyObject * ada_py_object_callmethod (PyObject *o, char *m) { return PyObject_CallMethod (o, m, ""); } PyObject * ada_py_object_callmethod_obj (PyObject *o, char *m, PyObject *arg) { return PyObject_CallMethod (o, m, "(O)", arg); } PyObject * ada_py_object_callmethod_int (PyObject *o, char *m, int arg) { return PyObject_CallMethod (o, m, "(i)", arg); } int ada_py_arg_parsetuple_ptr (PyObject *o, char *fmt, void *arg1) { return PyArg_ParseTuple (o, fmt, arg1); } int ada_py_arg_parsetuple_ptr2 (PyObject *o, char *fmt, void *arg1, void *arg2) { return PyArg_ParseTuple (o, fmt, arg1, arg2); } int ada_py_arg_parsetuple_ptr3 (PyObject *o, char *fmt, void *arg1, void * arg2, void *arg3) { return PyArg_ParseTuple (o, fmt, arg1, arg2, arg3); } int ada_py_arg_parsetuple_ptr4 (PyObject *o, char *fmt, void *arg1, void * arg2, void *arg3, void *arg4) { return PyArg_ParseTuple (o, fmt, arg1, arg2, arg3, arg4); } int ada_py_arg_parsetuple_ptr5 (PyObject *o, char *fmt, void *arg1, void * arg2, void *arg3, void *arg4, void *arg5) { return PyArg_ParseTuple (o, fmt, arg1, arg2, arg3, arg4, arg5); } extern int gnat_argc; extern char **gnat_argv; int ada_py_main () { #if PY_MAJOR_VERSION >= 3 return Py_Main (gnat_argc, (wchar_t**) gnat_argv); #else return Py_Main (gnat_argc, (char**) gnat_argv); #endif } PyObject* ada_type_new (PyTypeObject* meta, char* name, PyObject* bases, PyObject* dict) { PyTypeObject* m = meta; PyObject *args, *kwargs, *b=NULL; PyObject* result; PyObject* str; if (dict == NULL) { printf ("ada_type_new requires a non-null dict\n"); return NULL; } if (meta == NULL) { m = &PyType_Type; } /* Construct the parameter list. Do not use keyword arguments, since the __init__ of the builtin types do not accept them, and tp_new will try to call __init__, resulting in an error */ args = PyTuple_New (3); kwargs = PyDict_New (); #if PY_MAJOR_VERSION >= 3 str = PyUnicode_FromString (name); #else str = PyString_FromString (name); #endif PyTuple_SET_ITEM (args, 0, str); /* steal reference to str */ if (bases == NULL) { b = PyTuple_New (0); PyTuple_SET_ITEM (args, 1, b); /* steal ref to b */ } else { PyTuple_SetItem (args, 1, bases); /* increase refcount for bases */ } PyTuple_SetItem (args, 2, dict); /* increase refcount for dict */ result = PyType_Type.tp_new (m, args, kwargs); Py_XDECREF (args); Py_XDECREF (kwargs); return result; } int ada_pydescr_newGetSet (PyTypeObject* type, char* name, setter set, getter get, char* doc, void* closure) { struct PyGetSetDef *descr = (struct PyGetSetDef*)malloc (sizeof (struct PyGetSetDef)); PyObject* prop; descr->name = name; descr->get = get; descr->set = set; descr->doc = doc; descr->closure = closure; prop = PyDescr_NewGetSet (type, descr); if (prop == NULL) { return 0; } else { PyDict_SetItemString(type->tp_dict, name, prop); Py_DECREF (prop); return 1; } } #ifdef WITH_THREAD const int python_with_thread = 1; #else const int python_with_thread = 0; #endif PyThreadState* ada_PyEval_SaveThread() { #ifdef WITH_THREAD return PyEval_SaveThread(); #else return NULL; #endif } void ada_PyEval_RestoreThread (PyThreadState* state) { #ifdef WITH_THREAD PyEval_RestoreThread (state); #endif } PyThreadState* ada_PyGILState_GetThisThreadState() { #ifdef WITH_THREAD return PyGILState_GetThisThreadState(); #else return NULL; #endif } int ada_PyGILState_Ensure() { if (Py_IsInitialized ()) { #ifdef WITH_THREAD return (int)PyGILState_Ensure(); #else return 0; #endif } return 0; } void ada_PyGILState_Release(int state) { #ifdef WITH_THREAD if (Py_IsInitialized ()) { PyGILState_Release((PyGILState_STATE)state); } #endif } void ada_PyEval_InitThreads() { #ifdef WITH_THREAD PyEval_InitThreads(); #endif } int ada_is_subclass (PyObject* class, PyObject* base) { if (!class || !base) { return -1; } else { return PyObject_IsSubclass (class, base); } } const char* ada_py_builtin() { #if PY_MAJOR_VERSION >= 3 return "builtins"; #else return "__builtin__"; #endif } const char* ada_py_builtins() { #if PY_MAJOR_VERSION >= 3 return "__builtins__"; #else return "__builtins__"; #endif } /* Result value must be freed */ PyAPI_FUNC(const char *) ada_PyString_AsString(PyObject * val) { #if PY_MAJOR_VERSION >= 3 PyObject* utf8 = PyUnicode_AsUTF8String(val); char* tmp = PyBytes_AsString (utf8); char* str = strdup (tmp); Py_XDECREF(utf8); return str; #else char * str = PyString_AsString(val); return strdup(str); #endif }; #if PY_MAJOR_VERSION >= 3 int ada_is_python3() { return 1; } PyAPI_FUNC(PyObject *) PyInt_FromLong(long val) { return PyLong_FromLong(val); }; PyAPI_FUNC(long) PyInt_AsLong(PyObject * val) { return PyLong_AsLong(val); }; PyAPI_FUNC(PyObject *) PyString_FromStringAndSize( const char *val, Py_ssize_t s) { return PyUnicode_FromStringAndSize(val, s); }; PyAPI_FUNC(void *) PyCObject_AsVoidPtr(PyObject * val) { void* data = PyCapsule_GetPointer(val, "GNATCOLL._C_API"); return data; }; PyAPI_FUNC(PyObject *) PyCObject_FromVoidPtr( void *cobj, void (*destruct)(void*)) { return PyCapsule_New( cobj /* pointer */, "GNATCOLL._C_API" /* name */, (PyCapsule_Destructor) destruct); }; #else int ada_is_python3() { return 0; } #endif PyCodeObject* ada_pyframe_get_code (PyFrameObject* obj) { return obj->f_code; } PyFrameObject* ada_pyframe_get_back (PyFrameObject* obj) { return obj->f_back; } PyObject* ada_pycode_get_filename (PyCodeObject* obj) { return obj->co_filename; } PyObject* ada_pycode_get_name (PyCodeObject* obj) { return obj->co_name; } gnatcoll-bindings-25.0.0/python/setup.py000077500000000000000000000213021464374334300202430ustar00rootroot00000000000000#!/usr/bin/env python import logging import sys import re import os import json import shutil sys.path.append(os.path.dirname(os.path.dirname(os.path.abspath(__file__)))) from setup_support import SetupApp, Config PYTHON_DATA_SCRIPT = """ from distutils.sysconfig import (get_config_var, get_python_inc, get_config_vars, PREFIX) import json result = {'config_vars': get_config_vars(), 'python_inc': get_python_inc(), 'python_inc_plat': get_python_inc(plat_specific=True), 'prefix': PREFIX} print(json.dumps(result)) """ def fetch_python_config(config): logging.info('Fetch Python information...') python_output = config.run(config.data['python_exec'], '-c', PYTHON_DATA_SCRIPT, grab=True) python_data = json.loads(python_output) config_vars = python_data['config_vars'] python_version = config_vars["VERSION"] python_ldversion = config_vars.get("LDVERSION", python_version) logging.info(' %-24s %s', 'Python version:', python_version) # Current python location current_prefix = python_data['prefix'] # Fetch prefix during the build process. Some paths of interest might # still reference a location used during the Python build process. build_prefix = ([sys.prefix] + re.findall(r"'--prefix=([^']+)'", config_vars.get('CONFIG_ARGS', '')))[-1] def relocate(path): if os.path.isabs(path): rel_path = os.path.relpath(path, build_prefix) if not rel_path.startswith(os.pardir): # If the input path is relative to the original build # directory, replace build prefix by the current one. return os.path.join(current_prefix, rel_path) else: # Otherwise, return it unchanged return path else: # The input path is relative so assume it's relative to the current # python prefix. return os.path.join(current_prefix, path) # Retrieve cflags, and linker flags static_dir = relocate(config_vars.get('LIBPL', 'libs')) logging.info(' %-24s %s', 'Static dir', static_dir) shared_dir = relocate(config_vars.get('LIBDIR', '.')) logging.info(' %-24s %s', 'Shared dir', shared_dir) # Add first relocated include dirs followed by non-relocated version. # Indeed, when using venv and maybe virtualenv, includes are not copied. cflags = "-I" + relocate(python_data['python_inc']) if python_data['python_inc'] != python_data['python_inc_plat']: cflags += " -I" + relocate(python_data['python_inc_plat']) cflags += " -I" + python_data['python_inc_plat'] cflags += " -I" + python_data['python_inc'] logging.info(' %-24s %s', 'CFLAGS', cflags) if python_version.startswith('3'): # In python 3.x MODLIBS seems to drag in too many libraries python_libs = [config_vars[v] for v in ("LIBS", "SYSLIBS") if v in config_vars and config_vars[v]] else: python_libs = [config_vars[v] for v in ("LIBS", "SYSLIBS", "MODLIBS") if v in config_vars and config_vars[v]] python_libs = " ".join(python_libs) python_shared_libs = "-L%s -lpython%s %s" % (shared_dir, python_ldversion, python_libs) python_static_libs = python_libs libpython_a = os.path.join( static_dir, config_vars.get('LIBRARY', 'libpython%s.a' % python_version)) if os.path.isfile(libpython_a): config.set_data('GNATCOLL_PYTHON_STATIC_LIB', libpython_a, sub='gprbuild') else: logging.info('static python library not found') if sys.platform.startswith('linux'): # On Linux platform, even when linking with the static libpython, # symbols not used by the application itself should be exported so # that shared library present in Python can use the Python C API. python_static_libs += ' -export-dynamic' python_shared_libs += ' -export-dynamic' logging.info(' %-24s %s', 'Shared linker flags', python_shared_libs) logging.info(' %-24s %s', 'Static linker flags', python_static_libs) # User does not have the choice between linking with static libpython # and shared libpython. If --enable-shared or --enable-framework was # passed to Python's configure during Python build, then we should # link with the shared libpython, otherwise with the static one. # Indeed otherwise some C modules might not work as expected or even # crash. On Windows always link with shared version of libpython # (if the static is present, this is just an indirection to the shared) if '--enable-shared' in config_vars.get('CONFIG_ARGS', '') or \ '--enable-framework' in config_vars.get('CONFIG_ARGS', '') or \ sys.platform.startswith('win'): logging.info('Force link to shared python library') config.set_data('GNATCOLL_PYTHON_LIBS', python_shared_libs, sub='gprbuild') config.set_data('GNATCOLL_LIBPYTHON_KIND', 'shared', sub='gprbuild') else: logging.info('Force link to static python library') config.set_data('GNATCOLL_PYTHON_LIBS', python_static_libs, sub='gprbuild') config.set_data('GNATCOLL_LIBPYTHON_KIND', 'static', sub='gprbuild') config.set_data('GNATCOLL_PYTHON_CFLAGS', cflags, sub='gprbuild') class GNATCollPython(SetupApp): name = 'gnatcoll_python' project = 'gnatcoll_python.gpr' description = 'GNATColl Python bindings' def create(self): super(GNATCollPython, self).create() self.build_cmd.add_argument( '--python-exec', help='set python executable location', metavar='PATH', default=sys.executable) self.build_cmd.add_argument( '--debug', help='build project in debug mode', action="store_true", default=False) def update_config(self, config, args): # Fetch python information config.set_data('python_exec', args.python_exec) fetch_python_config(config) logging.info('%-26s %s', 'Libraries kind', ", ".join(config.data['library_types'])) # Set library version with open(os.path.join(config.source_dir, '..', 'version_information'), 'r') as fd: version = fd.read().strip() config.set_data('GNATCOLL_VERSION', version, sub='gprbuild') logging.info('%-26s %s', 'Version', version) # Set build mode config.set_data('BUILD', 'DEBUG' if args.debug else 'PROD', sub='gprbuild') logging.info('%-26s %s', 'Build mode', config.data['gprbuild']['BUILD']) # Set GNATCOLL_OS if 'darwin' in config.data['canonical_target']: gnatcoll_os = 'osx' elif 'windows' in config.data['canonical_target']: gnatcoll_os = 'windows' else: # Assume this is an Unix system gnatcoll_os = 'unix' config.set_data('GNATCOLL_OS', gnatcoll_os, sub='gprbuild') def variants(self, config, cmd): result = [] for library_type in config.data['library_types']: gpr_vars = {'LIBRARY_TYPE': library_type, 'XMLADA_BUILD': library_type, 'GPR_BUILD': library_type} if cmd == 'install': result.append((['--build-name=%s' % library_type, '--build-var=LIBRARY_TYPE'], gpr_vars)) else: result.append(([], gpr_vars)) return result def install(self, args): config = Config() has_static_python = "GNATCOLL_PYTHON_STATIC_LIB" in config.data["gprbuild"] if has_static_python: python_la = config.data["gprbuild"]["GNATCOLL_PYTHON_STATIC_LIB"] prefix = config.data["prefix"] target = os.path.join( "..", "..", "lib", "gnatcoll_python.static", os.path.basename(python_la) ) config.set_data("GNATCOLL_PYTHON_STATIC_LIB", target, sub='gprbuild') config.save_data() super(GNATCollPython, self).install(args) if has_static_python: # Copy over the libpython*.la shutil.copy( python_la, os.path.join(prefix, "lib", "gnatcoll_python.static")) if __name__ == '__main__': app = GNATCollPython() sys.exit(app.run()) gnatcoll-bindings-25.0.0/python3/000077500000000000000000000000001464374334300166135ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/python3/README.md000066400000000000000000000015351464374334300200760ustar00rootroot00000000000000The GNAT Components Collection (GNATCOLL) - Python ================================================== This is the Python component of the GNAT Components Collection. Standard interface to the Python 3 interpreter. NOTE: This binding is not compatible with Python 2. Dependencies ------------ This component requires the following external components, that should be available on your system: - gprbuild - gnatcoll-core - Python 3, at least version 3.7, but the most recent available version of Python 3 from www.python.org is recommended. NOTE for Windows users: if you are installing the official distrib, you should install it in "just for me" mode, otherwise the python DLL will be placed in C:\Windows\System32 folder and it will result in shared library's link failure. The workaround in this case is to copy it by hand back to python install dir. gnatcoll-bindings-25.0.0/python3/gnatcoll-any_types-python.adb000066400000000000000000000074201464374334300244210ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2020, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ package body GNATCOLL.Any_Types.Python is ------------------- -- From_PyObject -- ------------------- function From_PyObject (Object : PyObject) return Any_Type is begin if Object = null or else Object = Py_None then return Empty_Any_Type; end if; if PyInt_Check (Object) then declare A : Any_Type (Integer_Type, 0); begin A.Int := PyInt_AsLong (Object); return A; end; elsif PyString_Check (Object) then declare S : constant String := PyString_AsString (Object); A : Any_Type (String_Type, S'Length); begin A.Str := S; return A; end; elsif PyUnicode_Check (Object) then declare S : constant String := Unicode_AsString (Object); A : Any_Type (String_Type, S'Length); begin A.Str := S; return A; end; elsif PyList_Check (Object) then declare Size : constant Integer := PyList_Size (Object); Arr : Any_Type_Array (1 .. Size); A : Any_Type (List_Type, Size); begin for J in 1 .. Size loop Arr (J) := new Any_Type' (From_PyObject (PyList_GetItem (Object, J - 1))); end loop; A.List := Arr; return A; end; elsif PyTuple_Check (Object) then declare Size : constant Integer := PyTuple_Size (Object); Arr : Any_Type_Array (1 .. Size); A : Any_Type (Tuple_Type, Size); begin for J in 1 .. Size loop Arr (J) := new Any_Type' (From_PyObject (PyTuple_GetItem (Object, J - 1))); end loop; A.Tuple := Arr; return A; end; else -- When adding support for new types, add the corresponding cases -- here. null; end if; return Empty_Any_Type; end From_PyObject; end GNATCOLL.Any_Types.Python; gnatcoll-bindings-25.0.0/python3/gnatcoll-any_types-python.ads000066400000000000000000000045761464374334300244530ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2020, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package provides a utilities to manipulate Python objects. This is not -- meant to be very performance-efficient, but to provide an interface simpler -- than the direct manipulation of PyObjects. with GNATCOLL.Python; use GNATCOLL.Python; package GNATCOLL.Any_Types.Python is function From_PyObject (Object : PyObject) return Any_Type; -- Create an Any_Type from the contents of Object. This creates copies in -- of any data in Object. -- Empty_Any_Type is returned if the underlying Python type (or its -- children in case of container types) is not supported. -- The result must be freed by the caller, by calling Free. end GNATCOLL.Any_Types.Python; gnatcoll-bindings-25.0.0/python3/gnatcoll-python-capsule.adb000066400000000000000000000143011464374334300240360ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2020, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with Interfaces.C.Strings; with System; with GNATCOLL.Python.Errors; use type System.Address; package body GNATCOLL.Python.Capsule is package C renames Interfaces.C.Strings; package PyErr renames GNATCOLL.Python.Errors; -------------------------- -- PyCapsule_CheckExact -- -------------------------- function PyCapsule_CheckExact (Object : PyObject) return Boolean is begin return Py_TYPE (Object) = PyCapsule_Type; end PyCapsule_CheckExact; -------------------------- -- PyCapsule_GetContext -- -------------------------- function PyCapsule_GetContext (Capsule : PyCapsule) return System.Address is function Internal (Capsule : PyCapsule) return System.Address; pragma Import (C, Internal, "PyCapsule_GetContext"); Result : System.Address; begin Result := Internal (Capsule => Capsule); if Result = System.Null_Address and then PyErr.PyErr_Occurred /= null then raise PyCapsule_Error with "cannot get capsule context"; end if; return Result; end PyCapsule_GetContext; --------------------------- -- PyCapsule_GetPointer -- --------------------------- function PyCapsule_GetPointer (Capsule : PyCapsule; Name : String) return System.Address is function Internal (Capsule : PyCapsule; Name : String) return System.Address; pragma Import (C, Internal, "PyCapsule_GetPointer"); Result : System.Address; begin Result := Internal (Capsule => Capsule, Name => Name & ASCII.NUL); if Result = System.Null_Address then raise PyCapsule_Error with "cannot retrieve pointer from capsule " & Name; end if; return Result; end PyCapsule_GetPointer; function PyCapsule_GetPointer (Capsule : PyCapsule) return System.Address is function Internal (Capsule : PyCapsule; Name : System.Address) return System.Address; pragma Import (C, Internal, "PyCapsule_GetPointer"); Result : System.Address; begin Result := Internal (Capsule => Capsule, Name => System.Null_Address); if Result = System.Null_Address then raise PyCapsule_Error with "cannot retrieve pointer from unnamed capsule"; end if; return Result; end PyCapsule_GetPointer; ------------------- -- PyCapsule_New -- ------------------- function PyCapsule_New (Pointer : System.Address; Name : String; Destructor : PyCapsule_Destructor := null) return PyCapsule is function Internal (Pointer : System.Address; Name : C.chars_ptr; Destructor : PyCapsule_Destructor) return PyCapsule; pragma Import (C, Internal, "PyCapsule_New"); Internal_Name : constant C.chars_ptr := C.New_String (Name & ASCII.NUL); Result : PyCapsule; begin Result := Internal (Pointer => Pointer, Name => Internal_Name, Destructor => Destructor); if Result = null then raise PyCapsule_Error with "cannot create capsule " & Name; end if; return Result; end PyCapsule_New; function PyCapsule_New (Pointer : System.Address; Destructor : PyCapsule_Destructor := null) return PyCapsule is function Internal (Pointer : System.Address; Name : System.Address; Destructor : PyCapsule_Destructor) return PyCapsule; pragma Import (C, Internal, "PyCapsule_New"); Result : PyCapsule; begin Result := Internal (Pointer => Pointer, Name => System.Null_Address, Destructor => Destructor); if Result = null then raise PyCapsule_Error with "cannot create unnamed capsule"; end if; return Result; end PyCapsule_New; -------------------------- -- PyCapsule_SetContext -- -------------------------- procedure PyCapsule_SetContext (Capsule : PyCapsule; Context : System.Address) is function Internal (Capsule : PyCapsule; Context : System.Address) return Integer; pragma Import (C, Internal, "PyCapsule_SetContext"); Status : Integer; begin Status := Internal (Capsule => Capsule, Context => Context); if Status /= 0 then raise PyCapsule_Error with "cannot set capsule context"; end if; end PyCapsule_SetContext; end GNATCOLL.Python.Capsule; gnatcoll-bindings-25.0.0/python3/gnatcoll-python-capsule.ads000066400000000000000000000111441464374334300240610ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2003-2020, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ -- Bindings to functions manipulating capsules package GNATCOLL.Python.Capsule is PyCapsule_Error : exception; PyCapsule_Type_Opaque : aliased PyObject_Opaque; pragma Import (C, PyCapsule_Type_Opaque, "PyCapsule_Type"); PyCapsule_Type : constant PyTypeObject := PyCapsule_Type_Opaque'Access; subtype PyCapsule is PyObject; -- This subtype of PyObject represents an opaque value, useful for C -- extension modules who need to pass an opaque value (as a void* pointer) -- through Python code to other C code. It is often used to make a C -- function pointer defined in one module available to other modules, so -- the regular import mechanism can be used to access C APIs defined in -- dynamically loaded modules. type PyCapsule_Destructor is access procedure (Capsule : PyCapsule); pragma Convention (C, PyCapsule_Destructor); -- Type for the capsule destructor callbacks function PyCapsule_CheckExact (Object : PyObject) return Boolean; pragma Inline (PyCapsule_CheckExact); -- Return True is the Object is a PyCapsule. function PyCapsule_New (Pointer : System.Address; Name : String; Destructor : PyCapsule_Destructor := null) return PyCapsule; -- Create a PyCapsule encapsulating the pointer. The pointer argument may -- not be NULL. -- -- On failure, raise PyCapsuleError -- -- Note that an Interfaces.C.String.chars_ptr associated with the capsule -- name is allocated by the function. The object can be freed when the -- destructor is called. Use PyCapsule_GetName to retrieve it. -- -- If the destructor argument is not NULL, it will be called with the -- capsule as its argument when it is destroyed. -- -- If this capsule will be stored as an attribute of a module, the name -- should be specified as modulename.attributename. This will enable other -- modules to import the capsule using PyCapsule_Import(). function PyCapsule_New (Pointer : System.Address; Destructor : PyCapsule_Destructor := null) return PyCapsule; -- Likewise for capsule with no name associated function PyCapsule_GetPointer (Capsule : PyCapsule; Name : String) return System.Address; -- Retrieve the pointer stored in the capsule. On failure, raise -- PyCapsuleError. -- -- The name parameter must compare exactly to the name stored in the -- capsule. function PyCapsule_GetPointer (Capsule : PyCapsule) return System.Address; -- Likewise for capsule with no name associated. procedure PyCapsule_SetContext (Capsule : PyCapsule; Context : System.Address); -- Set the context pointer inside capsule to context. -- Raise PyCapsule_Error on error. function PyCapsule_GetContext (Capsule : PyCapsule) return System.Address; -- Return the current context stored in the capsule. On failure raise -- PyCapsule_Error. end GNATCOLL.Python.Capsule; gnatcoll-bindings-25.0.0/python3/gnatcoll-python-ctypes.ads000066400000000000000000000040621464374334300237350ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2020, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ -- Declaration of some low-level types used by python bindings. with Interfaces.C; with System; package GNATCOLL.Python.Ctypes is type Size_T is new Interfaces.C.size_t; type Char_Addr is new System.Address; type WChar_Addr is new System.Address; Null_WChar_Addr : WChar_Addr := WChar_Addr (System.Null_Address); end GNATCOLL.Python.Ctypes; gnatcoll-bindings-25.0.0/python3/gnatcoll-python-errors.ads000066400000000000000000000051061464374334300237420ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2003-2020, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ -- Bindings to error handling functions package GNATCOLL.Python.Errors is function PyErr_Occurred return PyObject; pragma Import (C, PyErr_Occurred, "PyErr_Occurred"); -- Return value: Borrowed reference. -- -- Test whether the error indicator is set. If set, return the exception -- type (the first argument to the last call to one of the PyErr_Set*() -- functions or to PyErr_Restore()). If not set, return NULL. You do not -- own a reference to the return value, so you do not need to Py_DECREF() -- it. -- -- Note: Do not compare the return value to a specific exception. Use -- PyErr_ExceptionMatches() instead. The comparison could easily fail -- since the exception may be an instance instead of a class, -- in the case of a class exception, or it may be a subclass of the -- expected exception. end GNATCOLL.Python.Errors; gnatcoll-bindings-25.0.0/python3/gnatcoll-python-eval.ads000066400000000000000000000047621464374334300233640ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2003-2020, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ package GNATCOLL.Python.Eval is function PyEval_SaveThread return PyThreadState; pragma Import (C, PyEval_SaveThread, "PyEval_SaveThread"); -- Release the global interpreter lock (if it has been created) and reset -- the thread state to NULL, returning the previous thread state (which -- is not NULL). If the lock has been created, the current thread must -- have acquired it. procedure PyEval_RestoreThread (State : PyThreadState); pragma Import (C, PyEval_RestoreThread, "PyEval_RestoreThread"); -- Acquire the global interpreter lock (if it has been created) and set -- the thread state to State, which must not be NULL. If the lock has -- been created, the current thread must not have acquired it, otherwise -- deadlock ensues. end GNATCOLL.Python.Eval; gnatcoll-bindings-25.0.0/python3/gnatcoll-python-exceptions.ads000066400000000000000000000036171464374334300246140ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2020, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ -- Exception that may be raised when using the present binding. package GNATCOLL.Python.Exceptions is DecodingError : exception; MemoryError : exception; end GNATCOLL.Python.Exceptions; gnatcoll-bindings-25.0.0/python3/gnatcoll-python-fileutils.adb000066400000000000000000000051671464374334300244140ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2020, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with GNATCOLL.Python.Exceptions; package body GNATCOLL.Python.Fileutils is use type C.WChar_Addr; use type C.Size_T; package Exc renames GNATCOLL.Python.Exceptions; --------------------- -- Py_DecodeLocale -- --------------------- function Py_DecodeLocale (Arg : String) return C.WChar_Addr is function Internal (Arg : String; Size : out C.Size_T) return C.WChar_Addr; pragma Import (C, Internal, "Py_DecodeLocale"); Result : C.WChar_Addr; Size : C.Size_T; begin Result := Internal (Arg => Arg & ASCII.NUL, Size => Size); if Result = C.Null_WChar_Addr then -- An error occured during decoding. if Size = C.Size_T'Last - 1 then raise Exc.MemoryError; else raise Exc.DecodingError; end if; end if; return Result; end Py_DecodeLocale; end GNATCOLL.Python.Fileutils; gnatcoll-bindings-25.0.0/python3/gnatcoll-python-fileutils.ads000066400000000000000000000060251464374334300244270ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2020, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ -- Bindings to functions declared in python include file fileutils.h with GNATCOLL.Python.Ctypes; package GNATCOLL.Python.Fileutils is package C renames GNATCOLL.Python.Ctypes; function Py_DecodeLocale (Arg : String) return C.WChar_Addr; -- Decode a byte string from the locale encoding with the surrogateescape -- error handler: undecodable bytes are decoded as characters in range -- U+DC80..U+DCFF. If a byte sequence can be decoded as a surrogate -- character, escape the bytes using the surrogateescape error handler -- instead of decoding them. -- Encoding, highest priority to lowest priority: -- * UTF-8 on macOS, Android, and VxWorks; -- * UTF-8 on Windows if Py_LegacyWindowsFSEncodingFlag is zero; -- * UTF-8 if the Python UTF-8 mode is enabled; -- * ASCII if the LC_CTYPE locale is "C", nl_langinfo(CODESET) returns -- the ASCII encoding (or an alias), and mbstowcs() and wcstombs() -- functions uses the ISO-8859-1 encoding. -- * the current locale encoding. -- Return a pointer to a newly allocated wide character string, use -- PyMem_RawFree() to free the memory. -- Raise DecodingError or MemoryError in case of error -- Decoding errors should never happen, unless there is a bug in the C -- library. end GNATCOLL.Python.Fileutils; gnatcoll-bindings-25.0.0/python3/gnatcoll-python-lifecycle.adb000066400000000000000000000065771464374334300243610ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2020-2021, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with GNATCOLL.Python.Fileutils; with Ada.Command_Line; package body GNATCOLL.Python.Lifecycle is package Fileutils renames GNATCOLL.Python.Fileutils; Finalized : Boolean := False; ------------------ -- Is_Finalized -- ------------------ function Is_Finalized return Boolean is begin return Finalized; end Is_Finalized; ----------------- -- Py_Finalize -- ----------------- function Py_Finalize return Boolean is function Internal return Integer; pragma Import (C, Internal, "Py_FinalizeEx"); begin Finalized := True; return Internal = 0; end Py_Finalize; ------------------- -- Py_Initialize -- ------------------- procedure Py_Initialize (Initialize_Signal_Handlers : Boolean := True) is procedure Internal (Init_Sigs : Integer); pragma Import (C, Internal, "Py_InitializeEx"); begin Finalized := False; if Initialize_Signal_Handlers then Internal (Init_Sigs => 1); else Internal (Init_Sigs => 0); end if; end Py_Initialize; ---------------------- -- Py_SetPythonHome -- ---------------------- procedure Py_SetPythonHome (Home : String) is begin Py_SetPythonHome (Home => Fileutils.Py_DecodeLocale (Home)); end Py_SetPythonHome; ------------------------ -- Py_SetProgramName -- ------------------------ procedure Py_SetProgramName (Name : String) is begin Py_SetProgramName (Name => Fileutils.Py_DecodeLocale (Name)); end Py_SetProgramName; procedure Py_SetProgramName is begin Py_SetProgramName (Name => Ada.Command_Line.Command_Name); end Py_SetProgramName; end GNATCOLL.Python.Lifecycle; gnatcoll-bindings-25.0.0/python3/gnatcoll-python-lifecycle.ads000066400000000000000000000153331464374334300243700ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2020-2021, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ -- Bindings to functions controlling the interpreter lifecycle with GNATCOLL.Python.Ctypes; package GNATCOLL.Python.Lifecycle is package C renames GNATCOLL.Python.Ctypes; procedure Py_SetPythonHome (Home : C.WChar_Addr); pragma Import (C, Py_SetPythonHome, "Py_SetPythonHome"); -- Set the default "home" directory, that is, the location of the standard -- Python libraries. See PYTHONHOME for the meaning of the argument string. -- The argument should point to a zero-terminated character string in -- static storage whose contents will not change for the duration of the -- program's execution. No code in the Python interpreter will change the -- contents of this storage. -- Use Py_DecodeLocale() to decode a bytes string to get a WChar_Addr -- string. procedure Py_SetPythonHome (Home : String); -- Same as previous function except that Py_DecodeLocale is called -- automatically. procedure Py_SetProgramName (Name : C.WChar_Addr); pragma Import (C, Py_SetProgramName, "Py_SetProgramName"); -- This function should be called before Py_Initialize() is called for the -- first time, if it is called at all. It tells the interpreter the value -- of the argv[0] argument to the main() function of the program -- (converted to wide characters). This is used by Py_GetPath() and some -- other functions below to find the Python run-time libraries relative to -- the interpreter executable. The default value is 'python'. The argument -- should point to a zero-terminated wide character string in static -- storage whose contents will not change for the duration of the -- program's execution. No code in the Python interpreter will change the -- contents of this storage. -- Use Py_DecodeLocale() to decode a bytes string to get a WChar_Addr -- string. procedure Py_SetProgramName (Name : String); -- Same as previous procedure except that Py_DecodeLocale is called -- automatically procedure Py_SetProgramName; -- Same as previous procedure except that the procedure use -- Ada.Commmand_Line.Command_Name as Name. procedure Py_Initialize (Initialize_Signal_Handlers : Boolean := True); -- Initialize the Python interpreter. In an application embedding Python, -- this should be called before using any other Python/C API functions. -- For the few exceptions see Python documentation. -- This initializes the table of loaded modules (sys.modules), and creates -- the fundamental modules builtins, __main__ and sys. It also initializes -- the module search path (sys.path). It does not set sys.argv; use -- PySys_SetArgvEx() for that. This is a no-op when called for a second -- time (without calling Py_FinalizeEx() first). There is no return value; -- it is a fatal error if the initialization fails. -- If Initialize_Signal_Handlers is set to True (default) the -- initialization performs the registration of the signal handlers. -- If not, it skipsregistration of signal handlers, which might be useful -- when Python is embedded. procedure Py_Finalize; pragma Import (C, Py_Finalize, "Py_Finalize"); -- Undo all initializations made by Py_Initialize() and subsequent use of -- Python/C API functions, and destroy all sub-interpreters (see -- Py_NewInterpreter() below) that were created and not yet destroyed since -- the last call to Py_Initialize(). Ideally, this frees all memory -- allocated by the Python interpreter. This is a no-op when called for a -- second time (without calling Py_Initialize() again first). function Is_Finalized return Boolean; function Py_Finalize return Boolean; -- Same as previous function but return True if finalization managed to -- free all the memory buffers. Return False otherwise. type Interpreter_Status is private; Interpreter_Exit_Normally : constant Interpreter_Status; Interpreter_Raise_Exception : constant Interpreter_Status; Interpreter_Invalid_Command_Line : constant Interpreter_Status; function Py_Main return Interpreter_Status; pragma Import (C, Py_Main, "__gnatcoll_py_main"); -- The main program for the standard interpreter. This is made available -- for programs which embed Python. The return value will be -- Interpreter_Exit_Normally if the interpreter exits normally (i.e., -- without an exception), Interpreter_Raise_Exception if the -- interpreter exits due to an exception, or -- Interpreter_Invalid_Command_Line if the parameter list does not -- represent a valid Python command line. -- Note that if an otherwise unhandled SystemExit is raised, this function -- will not return Interpreter_Raise_Exception, but exit the process, as -- long as Py_InspectFlag is not set. private type Interpreter_Status is new Integer; Interpreter_Exit_Normally : constant Interpreter_Status := 0; Interpreter_Raise_Exception : constant Interpreter_Status := 1; Interpreter_Invalid_Command_Line : constant Interpreter_Status := 2; end GNATCOLL.Python.Lifecycle; gnatcoll-bindings-25.0.0/python3/gnatcoll-python-state.adb000066400000000000000000000042131464374334300235230ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2003-2021, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ package body GNATCOLL.Python.State is ---------------- -- Initialize -- ---------------- overriding procedure Initialize (Self : in out Ada_GIL_Lock) is begin Self.State := PyGILState_Ensure; end Initialize; -------------- -- Finalize -- -------------- overriding procedure Finalize (Self : in out Ada_GIL_Lock) is begin PyGILState_Release (Self.State); end Finalize; end GNATCOLL.Python.State; gnatcoll-bindings-25.0.0/python3/gnatcoll-python-state.ads000066400000000000000000000065421464374334300235530ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2003-2021, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ -- Subprograms to manipulate GIL state and wrapper to simplify such -- operations in Ada code. with Ada.Finalization; package GNATCOLL.Python.State is type Ada_GIL_Lock is new Ada.Finalization.Limited_Controlled with private; -- This type is a wrapper around PyGILState_Ensure/Release, to avoid -- manual call to release, especially in the case of an exception. type PyGILState_STATE is private; PyGILState_LOCKED : constant PyGILState_STATE; PyGILState_UNLOCKED : constant PyGILState_STATE; function PyGILState_Ensure return PyGILState_STATE; pragma Import (C, PyGILState_Ensure, "ada_PyGILState_Ensure"); -- Ensure that the current thread is ready to call the Python C API -- regardless of the current state of Python, or of the global -- interpreter lock. This may be called as many times as desired by a -- thread as long as each call is matched with a call to -- PyGILState_Release(). procedure PyGILState_Release (State : PyGILState_STATE); pragma Import (C, PyGILState_Release, "ada_PyGILState_Release"); -- Release any resources previously acquired. After this call, Python's -- state will be the same as it was prior to the corresponding -- PyGILState_Ensure(). private overriding procedure Initialize (Self : in out Ada_GIL_Lock); overriding procedure Finalize (Self : in out Ada_GIL_Lock); type Ada_GIL_Lock is new Ada.Finalization.Limited_Controlled with record State : PyGILState_STATE; end record; type PyGILState_STATE is new Integer; PyGILState_LOCKED : constant PyGILState_STATE := 0; PyGILState_UNLOCKED : constant PyGILState_STATE := 1; end GNATCOLL.Python.State; gnatcoll-bindings-25.0.0/python3/gnatcoll-python.adb000066400000000000000000001053461464374334300224160ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2003-2022, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with System; use System; with Interfaces.C.Strings; use Interfaces.C.Strings; package body GNATCOLL.Python is No_Method_Def : constant PyMethodDef := (Name => Null_Ptr, Func => null, Flags => METH_VARGS or METH_KEYWORDS, Doc => Null_Ptr); type Methods_Access is access PyMethodDef_Array; type MethodDef_Access is access PyMethodDef; pragma Convention (C, MethodDef_Access); function PyCFunction_New (MethodDef : MethodDef_Access; Self : PyObject; Module : PyObject := null) return PyObject; pragma Import (C, PyCFunction_New, "PyCFunction_NewEx"); -- Create a new callable object, which, when called from python, will call -- the Ada subprogram. -- Self is the first argument that will be passed to the Ada subprogram. -- Module is the value of the __module__ attribute for the new function. ------------------------ -- PyRun_SimpleString -- ------------------------ function PyRun_SimpleString (Cmd : String) return Boolean is function Internal (Cmd : String) return Integer; pragma Import (C, Internal, "PyRun_SimpleString"); begin return Internal (Cmd & ASCII.NUL) = 0; end PyRun_SimpleString; ------------------------ -- PyImport_AddModule -- ------------------------ function PyImport_AddModule (Module_Name : String) return PyObject is function Internal (Name : String) return PyObject; pragma Import (C, Internal, "PyImport_AddModule"); begin return Internal (Module_Name & ASCII.NUL); end PyImport_AddModule; --------------------------- -- PyImport_ImportModule -- --------------------------- function PyImport_ImportModule (Module_Name : String) return PyObject is function Internal (Name : String) return PyObject; pragma Import (C, Internal, "PyImport_ImportModule"); begin return Internal (Module_Name & ASCII.NUL); end PyImport_ImportModule; ------------------ -- PyRun_String -- ------------------ function PyRun_String (Str : String; Start : Interpreter_State; Globals : PyObject; Locals : PyObject) return PyObject is function Internal (Str : String; Start : Interpreter_State; Globals : PyObject; Locals : PyObject) return PyObject; pragma Import (C, Internal, "PyRun_String"); begin return Internal (Str & ASCII.LF, Start, Globals, Locals); end PyRun_String; ---------------------- -- PyArg_ParseTuple -- ---------------------- function PyArg_ParseTuple (Arg : PyObject; Format : String; Value1 : System.Address) return Boolean is function Internal (Arg : PyObject; Format : String; V1 : System.Address) return Integer; pragma Import (C, Internal, "ada_py_arg_parsetuple_ptr"); begin return Internal (Arg, Format & ASCII.NUL, Value1) = 1; end PyArg_ParseTuple; function PyArg_ParseTuple (Arg : PyObject; Format : String; Value1, Value2 : System.Address) return Boolean is function Internal (Arg : PyObject; Format : String; V1, V2 : System.Address) return Integer; pragma Import (C, Internal, "ada_py_arg_parsetuple_ptr2"); begin return Internal (Arg, Format & ASCII.NUL, Value1, Value2) = 1; end PyArg_ParseTuple; function PyArg_ParseTuple (Arg : PyObject; Format : String; Value1, Value2, Value3 : System.Address) return Boolean is function Internal (Arg : PyObject; Format : String; V1, V2, V3 : System.Address) return Integer; pragma Import (C, Internal, "ada_py_arg_parsetuple_ptr3"); begin return Internal (Arg, Format & ASCII.NUL, Value1, Value2, Value3) = 1; end PyArg_ParseTuple; function PyArg_ParseTuple (Arg : PyObject; Format : String; Value1, Value2, Value3, Value4 : System.Address) return Boolean is function Internal (Arg : PyObject; Format : String; V1, V2, V3, V4 : System.Address) return Integer; pragma Import (C, Internal, "ada_py_arg_parsetuple_ptr4"); begin return Internal (Arg, Format & ASCII.NUL, Value1, Value2, Value3, Value4) = 1; end PyArg_ParseTuple; function PyArg_ParseTuple (Arg : PyObject; Format : String; Value1, Value2, Value3, Value4, Value5 : System.Address) return Boolean is function Internal (Arg : PyObject; Format : String; V1, V2, V3, V4, V5 : System.Address) return Integer; pragma Import (C, Internal, "ada_py_arg_parsetuple_ptr5"); begin return Internal (Arg, Format & ASCII.NUL, Value1, Value2, Value3, Value4, Value5) = 1; end PyArg_ParseTuple; ---------------------- -- PyFunction_Check -- ---------------------- function PyFunction_Check (Func : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pyfunction_check"); begin return Internal (Func) = 1; end PyFunction_Check; ---------------------- -- PyCallable_Check -- ---------------------- function PyCallable_Check (Func : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "PyCallable_Check"); begin return Internal (Func) = 1; end PyCallable_Check; -------------------- -- PyString_Check -- -------------------- function PyString_Check (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pystring_check"); begin return Internal (Obj) = 1; end PyString_Check; --------------------- -- PyUnicode_Check -- --------------------- function PyUnicode_Check (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pyunicode_check"); begin return Internal (Obj) = 1; end PyUnicode_Check; ------------------------ -- PyBaseString_Check -- ------------------------ function PyBaseString_Check (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pybasestring_check"); begin return Internal (Obj) = 1; end PyBaseString_Check; ------------------ -- PyList_Check -- ------------------ function PyList_Check (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pylist_check"); begin return Internal (Obj) = 1; end PyList_Check; ------------------ -- PyIter_Check -- ------------------ function PyIter_Check (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pyiter_check"); begin return Internal (Obj) = 1; end PyIter_Check; ----------------- -- PyInt_Check -- ----------------- function PyInt_Check (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pyint_check"); begin return Internal (Obj) = 1; end PyInt_Check; ------------------ -- PyLong_Check -- ------------------ function PyLong_Check (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pylong_check"); begin return Internal (Obj) = 1; end PyLong_Check; ------------------- -- PyFloat_Check -- ------------------- function PyFloat_Check (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pyfloat_check"); begin return Internal (Obj) = 1; end PyFloat_Check; ------------------------ -- PyBool_FromBoolean -- ------------------------ function PyBool_FromBoolean (Value : Boolean) return PyObject is function PyTrue return PyObject; pragma Import (C, PyTrue, "ada_py_true"); function PyFalse return PyObject; pragma Import (C, PyFalse, "ada_py_false"); Result : PyObject; begin if Value then Result := PyTrue; else Result := PyFalse; end if; Py_INCREF (Result); return Result; end PyBool_FromBoolean; ------------------ -- PyBool_Check -- ------------------ function PyBool_Check (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pybool_check"); begin return Internal (Obj) = 1; end PyBool_Check; -------------------- -- PyBool_Is_True -- -------------------- function PyBool_Is_True (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pybool_is_true"); begin return Internal (Obj) = 1; end PyBool_Is_True; ------------------- -- PyTuple_Check -- ------------------- function PyTuple_Check (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pytuple_check"); begin return Internal (Obj) = 1; end PyTuple_Check; ---------------------- -- PyObject_GetItem -- ---------------------- function PyObject_GetItem (Obj : PyObject; Key : Integer) return PyObject is K : PyObject; Result : PyObject; begin K := PyInt_FromLong (Interfaces.C.long (Key)); Result := PyObject_GetItem (Obj, K); Py_DECREF (K); return Result; end PyObject_GetItem; ---------------------- -- PyObject_SetItem -- ---------------------- procedure PyObject_SetItem (Obj : PyObject; Key : Integer; Value : PyObject) is K : PyObject; Result : Integer; pragma Unreferenced (Result); begin K := PyInt_FromLong (Interfaces.C.long (Key)); Result := PyObject_SetItem (Obj, K, Value); Py_DECREF (K); end PyObject_SetItem; ----------------------- -- PyString_AsString -- ----------------------- function PyString_AsString (Str : PyObject) return String is function Low (Str : PyObject) return Interfaces.C.Strings.chars_ptr; pragma Import (C, Low, "ada_PyString_AsString"); -- Returns a NULL terminated representation of the contents of string. -- Result value must be freed. C : constant Interfaces.C.Strings.chars_ptr := Low (Str); begin if C = Null_Ptr then return ""; else declare R : constant String := Value (C); procedure C_Free (S : chars_ptr); pragma Import (C, C_Free, "free"); begin -- Since C was allocated by ada_PyString_AsString via strdup(), -- and not via System.Memory, we should not be using -- Interfaces.C.Strings.Free which goes through System.Memory. -- So we call free() directly instead. C_Free (C); return R; end; end if; end PyString_AsString; ------------------------- -- PyString_FromString -- ------------------------- function PyString_FromString (Str : String) return PyObject is function Internal (Str : String; Size : Integer) return PyObject; pragma Import (C, Internal, "PyString_FromStringAndSize"); begin return Internal (Str, Str'Length); end PyString_FromString; -------------------------- -- PyUnicode_FromString -- -------------------------- function PyUnicode_FromString (Str : String) return PyObject is function Internal (Str : String) return PyObject; pragma Import (C, Internal, "ada_PyUnicode_FromString"); begin return Internal (Str & ASCII.NUL); end PyUnicode_FromString; ------------------------------- -- PyUnicode_AsEncodedString -- ------------------------------- function PyUnicode_AsEncodedString (Unicode : PyObject; Encoding : String; Errors : Unicode_Error_Handling := Strict) return PyObject is function Internal (Unicode : PyObject; Encoding, Errors : String) return PyObject; pragma Import (C, Internal, "ada_PyUnicode_AsEncodedString"); begin case Errors is when Strict => return Internal (Unicode, Encoding & ASCII.NUL, "strict" & ASCII.NUL); when Ignore => return Internal (Unicode, Encoding & ASCII.NUL, "ignore" & ASCII.NUL); when Replace => return Internal (Unicode, Encoding & ASCII.NUL, "replace" & ASCII.NUL); end case; end PyUnicode_AsEncodedString; ---------------------- -- Unicode_AsString -- ---------------------- function Unicode_AsString (Str : PyObject; Encoding : String := "utf-8") return String is S : constant PyObject := PyUnicode_AsEncodedString (Unicode => Str, Encoding => Encoding, Errors => Replace); Result : constant String := PyString_AsString (S); begin Py_DECREF (S); return Result; end Unicode_AsString; --------------------- -- PySys_SetObject -- --------------------- procedure PySys_SetObject (Name : String; Object : PyObject) is procedure Internal (Name : String; Object : PyObject); pragma Import (C, Internal, "PySys_SetObject"); begin Internal (Name & ASCII.NUL, Object); end PySys_SetObject; --------------------- -- PySys_GetObject -- --------------------- function PySys_GetObject (Name : String) return PyObject is function Internal (Name : String) return PyObject; pragma Import (C, Internal, "PySys_GetObject"); begin return Internal (Name & ASCII.NUL); end PySys_GetObject; ------------------------- -- PyObject_CallMethod -- ------------------------- function PyObject_CallMethod (Object : PyObject; Name : String) return PyObject is function Internal (Object : PyObject; Name : String) return PyObject; pragma Import (C, Internal, "ada_py_object_callmethod"); begin return Internal (Object, Name & ASCII.NUL); end PyObject_CallMethod; function PyObject_CallMethod (Object : PyObject; Name : String; Arg1 : PyObject) return PyObject is function Internal (Object : PyObject; Name : String; Arg : PyObject) return PyObject; pragma Import (C, Internal, "ada_py_object_callmethod_obj"); begin return Internal (Object, Name & ASCII.NUL, Arg1); end PyObject_CallMethod; function PyObject_CallMethod (Object : PyObject; Name : String; Arg1 : Integer) return PyObject is function Internal (Object : PyObject; Name : String; Arg : Integer) return PyObject; pragma Import (C, Internal, "ada_py_object_callmethod_int"); begin return Internal (Object, Name & ASCII.NUL, Arg1); end PyObject_CallMethod; ---------------------- -- Py_CompileString -- ---------------------- function Py_CompileString (Cmd : String; Name : String; State : Interpreter_State) return PyCodeObject is function Internal (Cmd, Name : String; State : Interpreter_State) return PyCodeObject; pragma Import (C, Internal, "Py_CompileString"); begin return Internal (Cmd & ASCII.NUL, Name & ASCII.NUL, State); end Py_CompileString; ------------------ -- PyDict_Check -- ------------------ function PyDict_Check (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pydict_check"); begin return Internal (Obj) /= 0; end PyDict_Check; -------------------- -- PyAnySet_Check -- -------------------- function PyAnySet_Check (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pyanyset_check"); begin return Internal (Obj) /= 0; end PyAnySet_Check; -------------------------- -- PyDict_SetItemString -- -------------------------- procedure PyDict_SetItemString (Dict : PyDictObject; Key : String; Obj : PyObject) is S : chars_ptr := New_String (Key); Result : constant Integer := PyDict_SetItemString (Dict, S, Obj); pragma Unreferenced (Result); begin Free (S); end PyDict_SetItemString; ------------------------ -- PyModule_AddObject -- ------------------------ function PyModule_AddObject (Module : PyObject; Name : String; Object : PyObject) return Integer is S : chars_ptr := New_String (Name); Result : Integer; begin Result := PyModule_AddObject (Module, S, Object); Free (S); return Result; end PyModule_AddObject; -------------------------- -- PyDict_GetItemString -- -------------------------- function PyDict_GetItemString (Dict : PyDictObject; Key : String) return PyObject is S : chars_ptr := New_String (Key); Result : constant PyObject := PyDict_GetItemString (Dict, S); begin Free (S); return Result; end PyDict_GetItemString; ------------------ -- Create_Tuple -- ------------------ function Create_Tuple (Objects : PyObject_Array) return PyObject is Tuple : constant PyObject := PyTuple_New (Objects'Length); begin for O in Objects'Range loop PyTuple_SetItem (Tuple, O - Objects'First, Objects (O)); end loop; return Tuple; end Create_Tuple; ------------------------ -- PyErr_NewException -- ------------------------ function PyErr_NewException (Name : String; Base : PyObject := null; Dict : PyObject := null) return PyObject is function Internal (Name : String; Base, Dict : PyObject) return PyObject; pragma Import (C, Internal, "PyErr_NewException"); begin return Internal (Name & ASCII.NUL, Base, Dict); end PyErr_NewException; --------------------- -- PyErr_SetString -- --------------------- procedure PyErr_SetString (Except : PyObject; Msg : String) is procedure Internal (Except : PyObject; Msg : String); pragma Import (C, Internal, "PyErr_SetString"); begin Internal (Except, Msg & ASCII.NUL); end PyErr_SetString; ---------------------------- -- PyObject_GetAttrString -- ---------------------------- function PyObject_GetAttrString (Object : PyObject; Name : String) return PyObject is function Internal (Object : PyObject; S : String) return PyObject; pragma Import (C, Internal, "PyObject_GetAttrString"); begin return Internal (Object, Name & ASCII.NUL); end PyObject_GetAttrString; ---------------------------- -- PyObject_HasAttrString -- ---------------------------- function PyObject_HasAttrString (Obj : PyObject; Attr_Name : String) return Boolean is function Internal (Object : PyObject; S : String) return Integer; pragma Import (C, Internal, "PyObject_HasAttrString"); begin return Boolean'Val (Internal (Obj, Attr_Name & ASCII.NUL)); end PyObject_HasAttrString; ---------------------------- -- PyObject_SetAttrString -- ---------------------------- procedure PyObject_SetAttrString (Obj : PyObject; Attr_Name : String; Value : PyObject) is procedure Internal (Obj : PyObject; Name : String; Val : PyObject); pragma Import (C, Internal, "PyObject_SetAttrString"); begin Internal (Obj, Attr_Name & ASCII.NUL, Value); end PyObject_SetAttrString; ---------------------------- -- PyObject_SetAttrString -- ---------------------------- function PyObject_SetAttrString (Obj : PyObject; Attr_Name : String; Value : PyObject) return Integer is function Internal (Obj : PyObject; Name : String; Val : PyObject) return Integer; pragma Import (C, Internal, "PyObject_SetAttrString"); begin return Internal (Obj, Attr_Name & ASCII.NUL, Value); end PyObject_SetAttrString; ----------------------------------- -- PyObject_GenericSetAttrString -- ----------------------------------- function PyObject_GenericSetAttrString (Object : PyObject; Name : String; Attr : PyObject) return Integer is N : constant PyObject := PyString_FromString (Name); Result : Integer; begin Result := PyObject_GenericSetAttr (Object, N, Attr); Py_DECREF (N); return Result; end PyObject_GenericSetAttrString; --------------------- -- PyDict_Contains -- --------------------- function PyDict_Contains (Dict : PyDictObject; Key : PyObject) return Boolean is function Internal (Dict : PyObject; Key : PyObject) return Integer; pragma Import (C, Internal, "PyDict_Contains"); begin return Internal (Dict, Key) = 1; end PyDict_Contains; ----------------- -- PyDict_Next -- ----------------- procedure PyDict_Next (Dict : PyObject; Pos : in out Integer; Key : out PyObject; Value : out PyObject) is function Internal (Dict : PyObject; Pos, Key, Value : System.Address) return Integer; pragma Import (C, Internal, "PyDict_Next"); P : Interfaces.C.size_t := Interfaces.C.size_t (Pos); begin if Internal (Dict, P'Address, Key'Address, Value'Address) = 0 then Pos := -1; else Pos := Integer (P); end if; end PyDict_Next; -------------------- -- Print_Refcount -- -------------------- procedure Print_Refcount (Obj : PyObject; Msg : String) is procedure Internal (Obj : PyObject; Msg : String); pragma Import (C, Internal, "ada_py_print_refcount"); begin Internal (Obj, Msg & ASCII.NUL); end Print_Refcount; ------------------------ -- PyFile_WriteString -- ------------------------ function PyFile_WriteString (Text : String; File : PyObject) return Boolean is function Internal (Text : String; File : PyObject) return Integer; pragma Import (C, Internal, "PyFile_WriteString"); begin return Internal (Text & ASCII.NUL, File) /= 0; end PyFile_WriteString; ----------------------- -- PyFile_FromString -- ----------------------- function PyFile_FromString (File_Name, Mode : String) return PyObject is function Internal (N, M : String) return PyObject; pragma Import (C, Internal, "PyFile_FromString"); begin return Internal (File_Name & ASCII.NUL, Mode & ASCII.NUL); end PyFile_FromString; ------------------- -- Py_InitModule -- ------------------- function Py_InitModule (Module_Name : String; Methods : PyMethodDef_Array := No_MethodDef_Array; Doc : String := "") return PyObject is function Internal (N : String; Methods : System.Address; Doc : String; Self : PyObject := null) return PyObject; pragma Import (C, Internal, "ada_Py_InitModule4"); M : Methods_Access; begin if Methods /= No_MethodDef_Array then -- ??? Memory is never freed, but Python is not supposed to be killed -- before the end of the application M := new PyMethodDef_Array'(Methods & No_Method_Def); return Internal (Module_Name & ASCII.NUL, M.all'Address, Doc & ASCII.NUL); else return Internal (Module_Name & ASCII.NUL, System.Null_Address, Doc & ASCII.NUL); end if; end Py_InitModule; ---------- -- Free -- ---------- procedure Free (Method : in out PyMethodDef) is procedure C_Free (C : Interfaces.C.Strings.chars_ptr); pragma Import (C, C_Free, "free"); begin C_Free (Method.Name); C_Free (Method.Doc); Method.Name := Null_Ptr; Method.Doc := Null_Ptr; end Free; ---------- -- Free -- ---------- procedure Free (Methods : in out PyMethodDef_Array) is begin for M in Methods'Range loop Free (Methods (M)); end loop; end Free; ------------------ -- PyModule_New -- ------------------ function PyModule_New (Module_Name : String) return PyObject is function Internal (N : String) return PyObject; pragma Import (C, Internal, "PyModule_New"); begin return Internal (Module_Name & ASCII.NUL); end PyModule_New; ---------------------- -- PyModule_Getname -- ---------------------- function PyModule_Getname (Module : PyObject) return String is function Internal (M : PyObject) return Interfaces.C.Strings.chars_ptr; pragma Import (C, Internal, "PyModule_GetName"); begin return Value (Internal (Module)); end PyModule_Getname; ------------------ -- Add_Function -- ------------------ procedure Add_Function (Module : PyObject; Func : PyMethodDef; Self : PyObject := null) is C_Func : PyObject; Result : Integer; pragma Unreferenced (Result); Def : constant MethodDef_Access := new PyMethodDef'(Func); begin Def.Flags := Def.Flags or METH_KEYWORDS or METH_VARGS; if Self /= null then C_Func := PyCFunction_New (Def, Self, PyString_FromString (PyModule_Getname (Module))); else C_Func := PyCFunction_New (Def, Module, PyString_FromString (PyModule_Getname (Module))); end if; if C_Func /= null then Result := PyModule_AddObject (Module, Func.Name, C_Func); end if; end Add_Function; ---------------- -- Add_Method -- ---------------- procedure Add_Method (Class : PyObject; Func : PyMethodDef; Self : PyObject := null; Module : PyObject) is procedure Add_Method (Func : MethodDef_Access; Self : PyObject; Class : PyObject; Module : PyObject); pragma Import (C, Add_Method, "ada_py_add_method"); Def : constant MethodDef_Access := new PyMethodDef'(Func); begin Def.Flags := Def.Flags or METH_KEYWORDS or METH_VARGS; Add_Method (Def, Self, Class, Module); end Add_Method; ----------------------- -- Add_Static_Method -- ----------------------- procedure Add_Static_Method (Class : PyObject; Func : PyMethodDef; Self : PyObject := null; Module : PyObject) is function PyStaticMethod_New (Method : PyObject) return PyObject; pragma Import (C, PyStaticMethod_New, "PyStaticMethod_New"); Def : constant MethodDef_Access := new PyMethodDef'(Func); C_Func : PyObject; Static : PyObject; Result : Integer; pragma Unreferenced (Result); begin if Self = null then -- Declare the method static only if self is set to null. If the -- function is declared METH_STATIC self will never be passed. -- GNATCOLL.Scripts.Python uses self to pass user data to the -- called function (i.e: to simulate a closure). -- WARNING: There is no warranty that in future Python version this -- will work as expected. Def.Flags := Def.Flags or METH_STATIC; end if; C_Func := PyCFunction_New (Def, Self, PyString_FromString (PyModule_Getname (Module))); if C_Func /= null then -- The PyStaticMeThod_New does not seems to be mandatory and not -- documented in the public API, but still used internally by -- Python 3.8.x. Does it play a role regarding memory ? Static := PyStaticMethod_New (C_Func); Result := PyObject_SetAttrString (Class, Func.Name, Static); Py_DECREF (Static); end if; end Add_Static_Method; ---------------------- -- Add_Class_Method -- ---------------------- procedure Add_Class_Method (Class : PyObject; Func : PyMethodDef; Module : PyObject) is function PyClassMethod_New (Method : PyObject) return PyObject; pragma Import (C, PyClassMethod_New, "PyClassMethod_New"); Def : constant MethodDef_Access := new PyMethodDef'(Func); C_Func : PyObject; Result : Integer; Meth : PyObject; pragma Unreferenced (Result); begin Def.Flags := Def.Flags or METH_CLASS; C_Func := PyCFunction_New (Def, null, PyString_FromString (PyModule_Getname (Module))); if C_Func /= null then Meth := PyClassMethod_New (C_Func); Result := PyObject_SetAttrString (Class, Func.Name, Meth); Py_DECREF (Meth); end if; end Add_Class_Method; ----------------------- -- PyDescr_NewGetSet -- ----------------------- function PyDescr_NewGetSet (Typ : PyObject; Name : String; Setter : C_Setter := null; Getter : C_Getter := null; Doc : String := ""; Closure : System.Address := System.Null_Address) return Boolean is function To_Callback is new Standard.Ada.Unchecked_Conversion (C_Getter, C_Callback); function To_Callback is new Standard.Ada.Unchecked_Conversion (C_Setter, C_Callback); function Internal (Typ : PyObject; Name : chars_ptr; Setter, Getter : C_Callback; Doc : chars_ptr; Closure : System.Address) return Integer; pragma Import (C, Internal, "ada_pydescr_newGetSet"); begin return Internal (Typ, New_String (Name), To_Callback (Setter), To_Callback (Getter), New_String (Doc), Closure) /= 0; end PyDescr_NewGetSet; ----------------------- -- Create_Method_Def -- ----------------------- function Create_Method_Def (Name : String; Func : C_Method_Vargs; Doc : String := "") return PyMethodDef is begin return (Name => New_String (Name), Func => To_Callback (Func), Flags => METH_KEYWORDS or METH_VARGS, Doc => New_String (Doc)); end Create_Method_Def; ----------------------- -- Create_Method_Def -- ----------------------- function Create_Method_Def (Name : String; Func : C_Method_Keywords; Doc : String := "") return PyMethodDef is D : chars_ptr := Null_Ptr; begin if Doc /= "" then D := New_String (Doc); end if; return (Name => New_String (Name), Func => To_Callback (Func), Flags => METH_KEYWORDS or METH_VARGS, Doc => D); end Create_Method_Def; ------------------- -- Lookup_Object -- ------------------- function Lookup_Object (Module : String; Name : String) return PyObject is begin return Lookup_Object (PyImport_AddModule (Module), Name); end Lookup_Object; ------------------- -- Lookup_Object -- ------------------- function Lookup_Object (Module : PyObject; Name : String) return PyObject is Dict : PyObject; begin if Module /= null then Dict := PyModule_GetDict (Module); return PyDict_GetItemString (Dict, Name); end if; return null; end Lookup_Object; -------------------- -- PyMethod_Check -- -------------------- function PyMethod_Check (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "ada_pymethod_check"); begin return Internal (Obj) = 1; end PyMethod_Check; ------------------- -- Py_IsSubclass -- ------------------- function Py_IsSubclass (Class : PyObject; Base : PyObject) return Boolean is function Internal (Class, Base : PyObject) return Integer; pragma Import (C, Internal, "ada_is_subclass"); begin return Internal (Class, Base) /= 0; end Py_IsSubclass; -------------- -- Type_New -- -------------- function Type_New (Name : String; Bases : PyTuple; Dict : PyObject; Metatype : PyTypeObject := null) return PyObject is function Internal (Meta : PyTypeObject; Name : Interfaces.C.Strings.chars_ptr; Bases : PyObject; Dict : PyObject) return PyObject; pragma Import (C, Internal, "ada_type_new"); C : chars_ptr := New_String (Name); Result : PyObject; begin Result := Internal (Metatype, C, Bases, Dict); Free (C); return Result; end Type_New; --------- -- Name -- ---------- function Name (Obj : PyTypeObject) return String is function Internal (Obj : PyTypeObject) return chars_ptr; pragma Import (C, Internal, "ada_tp_name"); begin return Value (Internal (Obj)); end Name; ------------------------- -- PyObject_IsInstance -- ------------------------- function PyObject_IsInstance (Inst : PyObject; Cls : PyObject) return Boolean is function Internal (Inst, Cls : PyObject) return Integer; pragma Import (C, Internal, "PyObject_IsInstance"); begin return Internal (Inst, Cls) /= 0; end PyObject_IsInstance; --------------------- -- PyObject_IsTrue -- --------------------- function PyObject_IsTrue (Obj : PyObject) return Boolean is function Internal (Obj : PyObject) return Integer; pragma Import (C, Internal, "PyObject_IsTrue"); Val : Integer; begin Val := Internal (Obj); if Val = -1 then return False; -- An error else return Val /= 0; end if; end PyObject_IsTrue; end GNATCOLL.Python; gnatcoll-bindings-25.0.0/python3/gnatcoll-python.ads000066400000000000000000001426701464374334300224400ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2003-2021, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ -- Standard interface to the python interpreter. -- This requires at least python 3.7 to be installed on your system. with Ada.Unchecked_Conversion; with Interfaces.C.Strings; with System; package GNATCOLL.Python is ------------- -- Objects -- ------------- type PyObject_Opaque is limited private; type PyObject is access all PyObject_Opaque; pragma Convention (C, PyObject); type PyObject_Array is array (Natural range <>) of PyObject; function Py_None return PyObject; -- Return the python's variable Py_None, which should be returned by -- procedures. Generally, one need to call Py_INCREF before returning this -- value. type PyCodeObject is new PyObject; type PyFrameObject is new PyObject; procedure Py_INCREF (Obj : PyObject); procedure Py_DECREF (Obj : PyObject); -- Increment or decrement the reference count for Obj. Obj mustn't be null procedure Py_XINCREF (Obj : PyObject); procedure Py_XDECREF (Obj : PyObject); -- Same as above, but Obj can be null procedure Print_Refcount (Obj : PyObject; Msg : String); -- A debug procedure that prints the reference count of the object on -- stdout. function Get_Refcount (Obj : PyObject) return Integer; -- Return the current reference counter for Obj. Used for debug only function PyObject_Str (Obj : PyObject) return PyObject; -- Compute the string representation of Obj. Returns the string -- representation on success, NULL on failure. This is the equivalent of -- the Python expression "str(obj)". -- This is the equivalent of the python call str(obj), and is used by -- python in print statements. -- Returned value must be Py_DECREF function PyObject_Repr (Obj : PyObject) return PyObject; -- Similar to PyObject_Str, ie provides a displayable version of Obj. This -- is the equivalent of the python call repr(obj), and is used by python -- in backquotes. -- Returned value must be Py_DECREF function PyObject_CallMethod (Object : PyObject; Name : String) return PyObject; function PyObject_CallMethod (Object : PyObject; Name : String; Arg1 : PyObject) return PyObject; function PyObject_CallMethod (Object : PyObject; Name : String; Arg1 : Integer) return PyObject; -- A few examples of functions to call a method. -- In C, the profile of this method is: -- PyObject* PyObject_CallMethod -- (PyObject* object, char* name, char* format, ...); -- For instance, to call it with an object and a integer as a parameter, -- you would use: -- result = PyObject_CallMethod (object, "method", "(Oi)", other_obj, 1); -- except that due to ABI differences, you need to use a C wrapper, -- otherwise things will break on e.g. x86_64 -- -- format has the same form as in the calls to Py_BuildValue function PyObject_Call (Object : PyObject; Args : PyObject; Kw : PyObject) return PyObject; -- Call a callable Python object, Object, with -- arguments and keywords arguments. The 'args' argument can not be -- NULL, but the 'kw' argument can be NULL. -- The returned object must be DECREF function PyObject_CallObject (Object : PyObject; Args : PyObject) return PyObject; pragma Import (C, PyObject_CallObject, "PyObject_CallObject"); -- Call a callable Python object, callable_object, with -- arguments given by the tuple, args. If no arguments are -- needed, then args may be NULL. Returns the result of the -- call on success, or NULL on failure. This is the equivalent -- of the Python expression: apply(o,args). function PyObject_SetAttrString (Object : PyObject; Name : Interfaces.C.Strings.chars_ptr; Attr : PyObject) return Integer; pragma Import (C, PyObject_SetAttrString, "PyObject_SetAttrString"); -- Set the value of the attribute named Name, for Object, to the value -- Attr. Returns -1 on failure. This is the equivalent of the Python -- statement "Object.Name = Attr". function PyObject_SetAttrString (Obj : PyObject; Attr_Name : String; Value : PyObject) return Integer; procedure PyObject_SetAttrString (Obj : PyObject; Attr_Name : String; Value : PyObject); -- Same as above function PyObject_GenericSetAttr (Object : PyObject; Name : PyObject; Attr : PyObject) return Integer; pragma Import (C, PyObject_GenericSetAttr, "PyObject_GenericSetAttr"); -- Generic attribute setter that directly interface with the object's -- __dict__, not with its __setattr__ method. -- Name must be decref-ed by the caller. function PyObject_GenericSetAttrString (Object : PyObject; Name : String; Attr : PyObject) return Integer; -- Same as above, but accepts a string as parameter function PyObject_HasAttrString (Obj : PyObject; Attr_Name : String) return Boolean; -- Whether a specific attribute exists for the object function PyObject_GetAttrString (Object : PyObject; Name : String) return PyObject; -- Lookup an attribute in the object's dictionnary. -- The returned object *must* be DECREF. function PyObject_Dir (Object : PyObject) return PyObject; -- A list of strings for all entries in Object's dictionary.. -- The returned object must be DECREF. function PyObject_IsTrue (Obj : PyObject) return Boolean; -- Returns True if the object, Obj, is considered to be true, False if Obj -- is considered to be false. This is equivalent to the Python expression: -- "not not obj" -------------- -- Integers -- -------------- function PyLong_FromLong (Value : Interfaces.C.long) return PyObject; pragma Import (C, PyLong_FromLong, "PyLong_FromLong"); -- Create a new integer object from its value function PyLong_FromSize_t (Value : Interfaces.C.size_t) return PyObject; pragma Import (C, PyLong_FromSize_t, "PyLong_FromSize_t"); -- Create a new integer object from Value function PyLong_AsLong (Int : PyObject) return Interfaces.C.long; pragma Import (C, PyLong_AsLong, "PyLong_AsLong"); -- Return the value of Int. -- Return -1 and set PyErr_Occurred if Int is not an integer object. function PyLong_Check (Obj : PyObject) return Boolean with Inline; -- Returns true if the Obj is an integer object -- Not bound: PyInt_FromString and PyInt_FromUnicode function PyInt_FromLong (Value : Interfaces.C.long) return PyObject; -- Create a new integer object from its value -- Python3 removes this function. Use PyLong_FromLong instead. function PyInt_FromSize_t (Value : Interfaces.C.size_t) return PyObject; -- Create a new integer object from Value -- Python3 removes this function. Use PyLong_FromSize_t instead. function PyInt_AsLong (Int : PyObject) return Interfaces.C.long; -- Return the value of Int. -- Return -1 and set PyErr_Occurred if Int is not an integer object. -- Python3 removes this function. Use PyLong_AsLong instead. function PyInt_GetMax return Interfaces.C.long; -- Return the maximum value an integer can have -- Python3 removes this function. It has no PyLong equivalent. function PyInt_Check (Obj : PyObject) return Boolean; -- Returns true if the Obj is an integer object -- Python3 removes this function. Use PyLong_Check instead. ------------ -- Floats -- ------------ function PyFloat_AsDouble (Float : PyObject) return Interfaces.C.double; -- Return the value of Float function PyFloat_Check (Obj : PyObject) return Boolean; -- Returns true if the Obj is a float object function PyFloat_FromDouble (Value : Interfaces.C.double) return PyObject; pragma Import (C, PyFloat_FromDouble, "PyFloat_FromDouble"); -- Creates a new float object -------------- -- Booleans -- -------------- -- Support for the "bool" type. However, older versions of python do not -- support this type, so you should also always check for PyInt_Check at -- the same time function PyBool_Check (Obj : PyObject) return Boolean; -- Returns true if Obj is a boolean object function PyBool_Is_True (Obj : PyObject) return Boolean; -- Obj must return True for PyBool_Check. This function returns True if -- obj is True. function PyBool_FromBoolean (Value : Boolean) return PyObject; -- Create a new boolean object ------------ -- Tuples -- ------------ -- The following subprograms are in fact simple examples of importing the C -- function in your C code, depending on your exact requirement. In C, -- these are function with unknown number of parameters -- -- The C function is: -- int PyArg_ParseTuple(PyObject *arg, char *format, ...); function PyArg_ParseTuple (Arg : PyObject; Format : String; Value1 : System.Address) return Boolean; function PyArg_ParseTuple (Arg : PyObject; Format : String; Value1, Value2 : System.Address) return Boolean; function PyArg_ParseTuple (Arg : PyObject; Format : String; Value1, Value2, Value3 : System.Address) return Boolean; function PyArg_ParseTuple (Arg : PyObject; Format : String; Value1, Value2, Value3, Value4 : System.Address) return Boolean; function PyArg_ParseTuple (Arg : PyObject; Format : String; Value1, Value2, Value3, Value4, Value5 : System.Address) return Boolean; -- Parses Format, and stores each of the tuple element in each of the -- Values. The number of elements in Format must be the same as the number -- of Value parameter -- The exact description of the format should be found in the python -- documentation. -- Note: there is *no* type safety in these functions, but then neither is -- there in C. subtype PyTuple is PyObject; function PyTuple_New (Size : Integer) return PyObject; -- Create a new tuple that contains Size elements function PyTuple_GetItem (Tuple : PyTuple; Index : Integer) return PyObject; -- Get the item at a specific location in the tuple, starting at index 0. -- Do not decref returned value. -- See also PyObject_GetItem procedure PyTuple_SetItem (Tuple : PyTuple; Index : Integer; Value : PyObject); -- Set an item in the tuple. The reference counting of Value is not -- increased -- See also PyObject_SetItem function PyTuple_Size (Tuple : PyTuple) return Integer; pragma Obsolescent (PyTuple_Size, "See PyObject_Size instead"); -- Return the size of the tuple function Create_Tuple (Objects : PyObject_Array) return PyObject; -- Return a new tuple made of Objects function PyTuple_Check (Obj : PyObject) return Boolean; -- Whether Object is a tuple ----------- -- Lists -- ----------- function PyList_New (Size : Integer := 0) return PyObject; -- Create a new empty list, with an initialize size function PyList_Append (List : PyObject; Obj : PyObject) return Integer; -- Append Obj at the end of List, and return the index of the newly -- inserted item. -- Increased Obj's refcount function PyList_GetItem (List : PyObject; Index : Integer) return PyObject; pragma Obsolescent (PyList_GetItem, "See PyObject_GetItem instead"); -- Get the item at a specific location in the list, starting at index 0. -- Do not decref the returned value. -- See also PyObject_GetItem. function PyList_Size (List : PyObject) return Integer; pragma Obsolescent (PyList_Size, "See PyObject_Size instead"); -- Return the number of items in the list function PyList_Check (Obj : PyObject) return Boolean; -- True if Obj is a python list --------------- -- Iterators -- --------------- -- Iterators are an extension to list and tuples, and encapsulate both, in -- addition to user-defined types that have a __iter__ method. function PyIter_Check (Obj : PyObject) return Boolean; -- True if object is an iterator (as returned by PyObject_GetIter) function PyObject_GetIter (Obj : PyObject) return PyObject; pragma Import (C, PyObject_GetIter, "PyObject_GetIter"); -- This is equivalent to the Python expression iter(o). It returns a new -- iterator for the object argument, or the object itself if the object is -- already an iterator. Raises TypeError and returns NULL if the object -- cannot be iterated. function PyObject_Size (Obj : PyObject) return Integer; pragma Import (C, PyObject_Size, "PyObject_Size"); -- Return the length of object o. If the object o provides either the -- sequence and mapping protocols, the sequence length is returned. On -- error, -1 is returned. This is the equivalent to the Python expression -- len(o). function PyObject_GetItem (Obj, Key : PyObject) return PyObject; pragma Import (C, PyObject_GetItem, "PyObject_GetItem"); -- Returns a new reference -- Return element of o corresponding to the object key or NULL on failure. -- This is the equivalent of the Python expression o[key]. function PyObject_GetItem (Obj : PyObject; Key : Integer) return PyObject; -- A special case where the key is an integer function PyObject_SetItem (Obj, Key, Value : PyObject) return Integer; pragma Import (C, PyObject_SetItem, "PyObject_SetItem"); -- Map the object key to the value v. Returns -1 on failure. This is the -- equivalent of the Python statement o[key] = v. procedure PyObject_SetItem (Obj : PyObject; Key : Integer; Value : PyObject); -- A special case where the key is an integer function PyIter_Next (Obj : PyObject) return PyObject; pragma Import (C, PyIter_Next, "PyIter_Next"); -- Return the next value from the iteration o. If the object is an -- iterator, this retrieves the next value from the iteration, and returns -- NULL with no exception set if there are no remaining items. If the -- object is not an iterator, TypeError is raised, or if there is an error -- in retrieving the item, returns NULL and passes along the exception. -- -- To write a loop which iterates over an iterator, the code should look -- something like this: -- -- Iterator : PyObject := PyObject_GetIter (Obj); -- Item : PyObject; -- -- if Iterator = null then -- -- propagate error -- else -- loop -- Item := PyIter_Next (Iterator); -- exit when Item = null; -- -- Py_DECREF (Item); -- end loop; -- -- Py_DECREF (Iterator); -- end if; ------------- -- Strings -- ------------- function PyBaseString_Check (Obj : PyObject) return Boolean; -- Returns True if Obj is either a string or a unicode object function PyString_Check (Obj : PyObject) return Boolean; -- Returns true if the Obj is a string object function PyString_AsString (Str : PyObject) return String; -- Same as above, higher-level function PyString_FromString (Str : String) return PyObject; -- Return a python object representing Str function PyUnicode_Check (Obj : PyObject) return Boolean; function PyUnicode_FromString (Str : String) return PyObject; -- A Unicode string, from a latin-1 encoded Ada string function Unicode_AsString (Str : PyObject; Encoding : String := "utf-8") return String; -- Return an encoded version of Str. -- This is not a function from python, but a wrapper around -- PyUnicode_AsEncodedString and PyString_AsString. -- In case of encoding error, characters are replaced with '?' type Unicode_Error_Handling is (Strict, Ignore, Replace); -- How encoding errors are treated for unicode objects -- Strict: raise a ValueError -- Ignore: ignore the wrong characters, which are skipped -- Replace: replace illegal characters with '?' function PyUnicode_AsEncodedString (Unicode : PyObject; -- A unicode object Encoding : String; -- The encoding Errors : Unicode_Error_Handling := Strict) -- Error handling return PyObject; -- Encodes a Unicode object and returns the result as Python string object. -- You can use PyString_AsString to get the corresponding Ada string. ------------- -- Modules -- ------------- function PyImport_AddModule (Module_Name : String) return PyObject; -- Return the module object corresponding to a module name. The name -- argument may be of the form package.module. First check the modules -- dictionary if there's one there, and if not, create a new one and insert -- in in the modules dictionary. Because the former action is most common, -- this does not return a new reference, and you do not own the returned -- reference. -- -- Warning: this function does not load or import the module; if the module -- wasn't already loaded, you will get an empty module object. Use -- PyImport_ImportModule() or one of its variants to import a module. -- Return NULL with an exception set on failure. function PyImport_ImportModule (Module_Name : String) return PyObject; -- Import a new module in the interpreter function PyImport_Import (Name : PyObject) return PyObject; pragma Import (C, PyImport_Import, "PyImport_Import"); -- Higher-level import emulator which emulates the "import" statement -- more accurately -- it invokes the __import__() function from the -- builtins of the current globals. This means that the import is -- done using whatever import hooks are installed in the current -- environment, e.g. by "rexec". -- A dummy list ["__doc__"] is passed as the 4th argument so that -- e.g. PyImport_Import(PyString_FromString("win32com.client.gencache")) -- will return instead of . */ function PyModule_GetDict (Module : PyObject) return PyObject; -- Return the dictionary object that implements module's namespace; this -- object is the same as the __dict__ attribute of the module object. This -- function never fails. -- It is recommended that you use the other PyModule_* subprograms rather -- than manipulate this dictionnary directly. -- The returned dictionary is a borrow reference, so you shouldn't -- Py_DECREF it. function PyModule_New (Module_Name : String) return PyObject; -- Create a new module. -- Use the PyModule_GetDic function to add new objects to the module, or -- better use PyModule_AddObject. function PyModule_AddObject (Module : PyObject; Name : Interfaces.C.Strings.chars_ptr; Object : PyObject) return Integer; pragma Import (C, PyModule_AddObject, "PyModule_AddObject"); -- Add a new object to the module's directory. Object can be a subprogram, -- integer, ... Do not Py_DECREF Object afterward, this is only a borrowed -- reference. -- Return 0 in case of success, -1 in case of error. -- Name can be freed immediately by the caller function PyModule_AddObject (Module : PyObject; Name : String; Object : PyObject) return Integer; -- Same as above function PyModule_Getname (Module : PyObject) return String; -- Return the name of the module ---------------------------------- -- Creating modules and methods -- ---------------------------------- type Argument_Methods is mod 2 ** Integer'Size; METH_VARGS : constant Argument_Methods := 16#0001#; METH_KEYWORDS : constant Argument_Methods := 16#0002#; METH_NOARGS : constant Argument_Methods := 16#0004#; METH_CLASS : constant Argument_Methods := 16#0010#; METH_STATIC : constant Argument_Methods := 16#0020#; -- How arguments are passed to callbacks: -- - METH_VARGS: only positional arguments in the form of a tuple are -- accepted -- - "METH_VARGS or METH_KEYWORDS": a function accepting keyword -- arguments. -- - METH_CLASS and METH_STATIC can only be used for class methods, not -- for module methods. They both indicate that a method is a class-wide -- method. They are callable from the class or an instance, but the -- instance is ignored and not passed as a parameter. type C_Method_Vargs is access function (Self : PyObject; Args : PyObject) return PyObject; pragma Convention (C, C_Method_Vargs); -- A callback for a METH_VARGS method. -- The first argument is the object on which the method is applied, or null -- if this is a standard function. -- The second argument is a tuple of the parameters. They can be extracted -- through a call to PyArg_ParseTuple. type C_Method_Keywords is access function (Self : PyObject; Args : PyObject; Kwargs : PyObject) return PyObject; pragma Convention (C, C_Method_Keywords); -- A callback for a METH_KEYWORDS method. -- The first argument is the object on which the method is applied, or null -- if this is a standard function. -- The second argument is a tuple of the positional parameters. -- The third argument is a hash table of the named parameters. -- Parameters can be extracted through a call to -- PyArg_ParseTupleAndKeywords. type C_Callback_Record is private; type C_Callback is access C_Callback_Record; pragma Convention (C, C_Callback); -- The exact type doesn't matter, we only want to cover all possible cases -- of callbacks (C_Method_Vargs, C_Method_Keywords) function To_Callback is new Standard.Ada.Unchecked_Conversion (C_Method_Vargs, C_Callback); function To_Callback is new Standard.Ada.Unchecked_Conversion (C_Method_Keywords, C_Callback); type PyMethodDef is record Name : Interfaces.C.Strings.chars_ptr; Func : C_Callback; Flags : Argument_Methods; Doc : Interfaces.C.Strings.chars_ptr; end record; pragma Convention (C, PyMethodDef); -- Definition for one of the methods of an object. -- Name is the name used in the python interpreter to reference the method -- (one would use the syntax self.Name (...)) -- Func is the callback in the Ada code that should be called when the -- method is invoked. -- Flags indicates how the arguments should be passed. -- Doc is the optional documentation string for the method No_MethodDef : constant PyMethodDef; type PyMethodDef_Array is array (Natural range <>) of PyMethodDef; pragma Convention (C, PyMethodDef_Array); -- The full list of methods supported by a type. -- You do not need to terminate this array by a null element, as is done in -- C. This is automatically taken care of by Ada. No_MethodDef_Array : constant PyMethodDef_Array; procedure Free (Method : in out PyMethodDef); procedure Free (Methods : in out PyMethodDef_Array); -- Free the memory occupied by Method function Py_InitModule (Module_Name : String; Methods : PyMethodDef_Array := No_MethodDef_Array; Doc : String := "") return PyObject; -- Create and initialize a new module, with a set of predefined methods. -- Do not free Methods while the module is in use. -- The module is not visible in the interpreter until you have done a -- "import MODULE_NAME" in the interpreter. -- -- The first parameter to the methods declared in Methods will be null. procedure Add_Function (Module : PyObject; Func : PyMethodDef; Self : PyObject := null); -- Add a new function to Module. -- Do not free Func while this function is registered. -- The first parameter to Func will be Self (defaults to Module if Self is -- null). ------------------ -- Dictionaries -- ------------------ -- Dictionaries are hash tables, used internally by python to associate -- functions with modules or methods with objects. -- See PyModule_GetDict to see how to get the dictionary from a module. subtype PyDictObject is PyObject; function PyDict_Check (Obj : PyObject) return Boolean; -- Return True if Obj is a dict object or an instance of a subtype of the -- dict type. function PyDict_New return PyDictObject; -- Create a new empty dictionary function PyDict_Contains (Dict : PyDictObject; Key : PyObject) return Boolean; -- Determine if dictionary contains key function PyDict_SetItemString (Dict : PyDictObject; Key : Interfaces.C.Strings.chars_ptr; Obj : PyObject) return Integer; pragma Import (C, PyDict_SetItemString, "PyDict_SetItemString"); -- Store a new object in Dict. Obj should be Py_DECREF after the call. -- Return 0 if all went well, -1 otherwise -- Key should be deallocated. procedure PyDict_SetItemString (Dict : PyDictObject; Key : String; Obj : PyObject); -- Same as above. Refcounting for Obj is automatically increased, you do -- not need to do it yourself. function PyDict_SetItem (Dict : PyDictObject; Key : PyObject; Value : PyObject) return Integer; -- Add a new item to the dictionary. -- Key and Value should be Py_DECREF'ed after this call. -- Return 0 if all went well, -1 otherwise function PyDict_GetItemString (Dict : PyDictObject; Key : Interfaces.C.Strings.chars_ptr) return PyObject; pragma Import (C, PyDict_GetItemString, "PyDict_GetItemString"); -- Get an object from a dictionary. Do not decref the returned value function PyDict_GetItemString (Dict : PyDictObject; Key : String) return PyObject; -- Same as above function PyDict_GetItem (Dict : PyDictObject; Key : PyObject) return PyObject; -- Same as above procedure PyDict_Next (Dict : PyObject; Pos : in out Integer; Key : out PyObject; Value : out PyObject); -- Starting with Pos = 0, this traverses all items in Dict. -- When there are no more items, Pos is set to -1. -- It isn't safe to use this in a loop that modifies Dict. function PyDict_Size (Dict : PyObject) return Integer; -- Return the number of elements in Dict ---------- -- Sets -- ---------- -- A set object is an unordered collection of distinct hashable objects. -- Common uses include membership testing, removing duplicates from a -- sequence, and computing mathematical operations such as intersection, -- union, difference, and symmetric difference. function PyAnySet_Check (Obj : PyObject) return Boolean; -- Return true if p is a set object, a frozenset object, or an instance of -- a subtype. --------------- -- Functions -- --------------- function PyFunction_Check (Func : PyObject) return Boolean; -- Whether Func is a function object function PyFunction_Get_Code (Func : PyObject) return PyCodeObject; -- Return the code of the function (see PyEval_EvalCodeEx). -- Refcount for the code is not increased. function PyFunction_Get_Globals (Func : PyObject) return PyObject; -- Return the globals dictionary the function belongs to function PyFunction_Get_Defaults (Func : PyObject) return PyObject; -- Return a tuple of the default values for all the parameters of Func function PyFunction_Get_Closure (Func : PyObject) return PyObject; -- ??? function PyCallable_Check (Func : PyObject) return Boolean; -- Determine if the object o is callable. This function always succeeds ------------------ -- Object types -- ------------------ subtype PyTypeObject is PyObject; -- The internal structure that describes a Python type (and all the default -- primitive subprograms like __getattr__, __setattr__, ... function Py_TYPE (Obj : PyObject) return PyTypeObject; -- Return the type object of a given object. function Name (Obj : PyTypeObject) return String; -- Name of type, useful for printing, in format "." function Type_New (Name : String; Bases : PyTuple; Dict : PyObject; Metatype : PyTypeObject := null) return PyObject; -- Creates a so called new-style class in python. -- Such classes have a metaclass (ie their type) that is "type" or one of -- its ancestors. Their provide a number of advantages over older classes: -- - it is possible to extend builtin types such as "list" or "tuple" -- - support for the "super" function, to provide collaborative multiple -- inheritance -- - support for properties (ie fields manipulated through setters and -- getters) -- - better Method Resolution Order, more compatible with multiple -- inheritance. -- See the original paper at -- http://www.python.org/download/releases/2.2.3/descrintro -- -- This replaces the older PyClass_New. -- This isn't a standard python function, but is specific to Ada. If the -- Metatype is not specified, it will default to "type", although depending -- on the list of base classes you provide, python might decide to use -- another metaclass. -- This function is similar to calling the "type()" function from within -- python: -- A = type ("Name", (list,), {}); -- which creates a new class Name deriving from "list". -- -- Dict can contain any number of things (including for instance the list -- of methods for the class, although you can add some later), just as if -- you were defining the class in Python: -- - "__slots__" -- - "__module__" (although that is set automatically otherwise) -- - "__doc__" function PyObject_IsInstance (Inst : PyObject; Cls : PyObject) return Boolean; -- Return if the metaclass of Inst is Cls (ie Inst was created with -- something like "Inst = Cls (...)" ---------------- -- Exceptions -- ---------------- procedure PyErr_Print; -- Print the current exception and its traceback to sys.stderr. -- This also clears the error indicator. -- Call this procedure only if the error indicator is set procedure PyErr_SetInterrupt; -- Interrupt the current command in the interpreter. This is the equivalent -- of Control-C in a terminal executing python. procedure PyErr_Fetch (EType : out PyObject; Occurrence : out PyObject; Traceback : out PyObject); -- Get the current exception information. -- Occurrence is a tuple, made of the following information: -- (msg, ('input_stream_name', line, column, input_text)) -- where msg is the exception's message, and the second tuple is the -- location where the exception occurred. -- EType is the type of the exception, like "exceptions.SyntaxError". -- -- This calls clears the current exception. If you want to call PyErr_Print -- later on, you will need to call PyErr_Restore with the same parameters -- to restore the current exception. procedure PyErr_NormalizeException (EType : in out PyObject; Occurrence : in out PyObject; Traceback : in out PyObject); -- Normalize a raised exception. This generally needs to be called after -- PyErr_Fetch. -- This ensure that if EType is an class, Occurrence is an instance. procedure PyErr_Restore (EType : PyObject; Occurrence : PyObject; Traceback : PyObject); -- Set the current exception procedure PyErr_Clear; -- Clear the current exception. This must be called at the end of your -- exception handlers, although it is called automatically by PyErr_Print procedure PyErr_BadArgument; -- Set the current exception as a "bad argument" exception. The function -- should also return null to its caller. function PyErr_NewException (Name : String; Base : PyObject := null; Dict : PyObject := null) return PyObject; -- Create a new exception, which can then be raised by: -- - calling PyErr_SetString (Except, "message"); -- - returning null from your subprogram -- Name must be of the form "module.name" procedure PyErr_SetString (Except : PyObject; Msg : String); -- Raise Except, and associate it with a specific message --------- -- Sys -- --------- procedure PySys_SetObject (Name : String; Object : PyObject); -- Set one of the predefined objects in the python interpreter. See the -- module "sys". -- Among these objects are: -- - "stdin", "stdout", "stderr": standard file objects -- - "_stdin", _stdout", "_stderr": initial values for standard files -- - "modules": dictionary of modules -- - "path": module search path -- - "ps1", "ps2": prompts -- - "displayhook": ??? -- - "excepthook": ??? function PySys_GetObject (Name : String) return PyObject; -- Return an object from the sys module, -- Returned object must not be Py_DECREF by the caller. ----------- -- Files -- ----------- function PyFile_WriteString (Text : String; File : PyObject) return Boolean; -- Write a string to an instance of file. You can for instance get such an -- instance by using -- PySys_GetObject ("stdout") -- Return False if the string couldn't be written function PyFile_FromString (File_Name, Mode : String) return PyObject; -- Create an instance of file. -- Python3 removes this function. Use "io.open()" instead. ----------------- -- Class types -- ----------------- function Lookup_Object (Module : String; Name : String) return PyObject; function Lookup_Object (Module : PyObject; Name : String) return PyObject; -- Lookup an object in the module. -- Typical use is -- Obj := Lookup_Class_Object ("__builtin__", "file"); -- null is returned if the class is not found. -- The second version is slightly faster and should be used when you -- already have a handle to the module procedure Add_Method (Class : PyObject; Func : PyMethodDef; Self : PyObject := null; Module : PyObject); -- Add a new method to the class. -- The method is an instance method. -- When the method is called from the python interpreter, its Self argument -- is set to the value of Self. -- Its first argument will always be the instance itself. Therefore the -- first character in the argument to PyArg_ParseTuple should be "O". procedure Add_Static_Method (Class : PyObject; Func : PyMethodDef; Self : PyObject := null; Module : PyObject); -- Return a static version of Method. This method doesn't receive an -- instance or the class as its first parameter. This is similar to C++ or -- Java's static methods. -- If no documentation is set for the method, it will be set to the fully -- qualified name of the method, since otherwise there is no way from the -- GPS shell to get access to the class to which the method belongs. procedure Add_Class_Method (Class : PyObject; Func : PyMethodDef; Module : PyObject); -- Return a class version of Method. -- This is a method that receives the class as implicit first argument, -- just like an instance method receives the instance. -- It can be called either on the class or an instance. If a class method -- is called for a derived class, the derived class object is passed as the -- implied first argument. -- If no documentation is set for the method, it will be set to the fully -- qualified name of the method, since otherwise there is no way from the -- GPS shell to get access to the class to which the method belongs. function Py_IsSubclass (Class : PyObject; Base : PyObject) return Boolean; -- True if Class is a subclass of Base (or Base itself) function PyMethod_Check (Obj : PyObject) return Boolean; -- Whether Obj is a method of a class function PyMethod_Self (Obj : PyObject) return PyObject; -- Return the instance with which the method is bound. This might be null -- if we have an unbound class method (Class.method), or non-null if we -- have a bound class method (the result of self.method) -- Returns a borrowed reference, no need to Py_DECREF function PyMethod_Function (Obj : PyObject) return PyObject; -- Return the function object associated with the method. That is the code -- that is actually executed when the method is called ----------------- -- Descriptors -- ----------------- -- Descriptors are an advanced feature of python, used as the underlying -- capability for bounded methods, properties,... -- Basically, when a field in an instance is a descriptor, its value is -- read from a Getter, instead of directly. Likewise it is set through a -- Setter. type C_Getter is access function (Obj : PyObject; Closure : System.Address) return PyObject; pragma Convention (C, C_Getter); type C_Setter is access function (Obj : PyObject; Prop : PyObject; Closure : System.Address) return Integer; pragma Convention (C, C_Setter); -- Closure is some custom data you have specified in the call to -- Create_GetSetDef function PyDescr_NewGetSet (Typ : PyObject; Name : String; Setter : C_Setter := null; Getter : C_Getter := null; Doc : String := ""; Closure : System.Address := System.Null_Address) return Boolean; -- Register a new property (accessed through setters and getters) in the -- specified Typ. The property is immediately added to the dictionary. -- False is returned if the property could not be added. -- The Closure will be passed as is to Setter and Getter. ------------------------------------ -- Creating and declaring methods -- ------------------------------------ function Create_Method_Def (Name : String; Func : C_Method_Vargs; Doc : String := "") return PyMethodDef; -- Convenience function to create method definitions. -- See the description of the parameters in the declaration of PyMethodDef -- The flags are automatically set to METH_VARGS, which is the appropriate -- type for callbacks of this form. -- The returned value must be freed by the caller. function Create_Method_Def (Name : String; Func : C_Method_Keywords; Doc : String := "") return PyMethodDef; -- Same as above, for methods accepting keywords. -- The returned value must be freed by the caller ------------------------ -- Executing commands -- ------------------------ function PyRun_SimpleString (Cmd : String) return Boolean; -- Executes Cmd in the __main__ module. -- Return True on success, False if an exception occurred (it is your -- responsibility to check the current exception) type Interpreter_State is private; Py_Single_Input : constant Interpreter_State; Py_File_Input : constant Interpreter_State; Py_Eval_Input : constant Interpreter_State; -- The state of the interpreter when evaluating a string. -- - Single_Input: evaluate any command in the interpreter. This will -- print the result (but return None) -- - Eval_Input: evaluate an expression. Evaluates an expression. -- Equivalent to 'eval'. -- - File_Input: evaluate a whole file, and return None. -- Equivalent to 'exec'. function PyRun_String (Str : String; Start : Interpreter_State; Globals : PyObject; Locals : PyObject) return PyObject; -- Execute Python source code from str in the context specified by the -- dictionaries globals and locals. The parameter start specifies the -- start token that should be used to parse the source code. -- -- Returns NULL if an exception occurred, None otherwise. function Py_CompileString (Cmd : String; Name : String; State : Interpreter_State) return PyCodeObject; -- Compile Cmd into a code object. Null is returned if Cmd couldn't be -- compiled, either because of a syntax error or because Cmd is incomplete function PyEval_GetGlobals return PyObject; pragma Import (C, PyEval_GetGlobals, "PyEval_GetGlobals"); -- Return the dictionary for global variables function PyEval_EvalCode (Code : PyCodeObject; Globals : PyObject; Locals : PyObject) return PyObject; -- Evaluate a precompiled code object function PyEval_EvalCodeEx (Code : PyCodeObject; Globals : PyObject; Locals : PyObject; Args : PyTuple := null; Kwds : PyDictObject := null; Defaults : PyTuple := null; Closure : PyObject := null) return PyObject; -- Evaluate a precompiled code object. This is mostly used to execute a -- function (get its code with PyFunction_Get_Code), specifying some of -- the parameters -------------------------------------- -- Evaluating and Tracing execution -- -------------------------------------- -- Python will periodically call two functions that you can register: a -- profile function, called every time a subprogram is called or returns, -- and a trace function called for every instruction. -- These can be used to trace the execution of your program, but also to -- interrupt a parser embedded in your application: -- - register a trace function, and every n calls, check for gtk events -- and call PyErr_SetInterrupt if necessary -- - a profile function would not be called for an infinite loop that -- never calls another subprogram, so is not appropriate for for such -- usage. -- There is still a catch: you will not be able to interrupt a long sleep() -- operation with this method, since the interpret itself is paused. The -- best solution to handle this is to have your own Control-C handler, -- although the user would have to type this in the terminal used to start -- your application. type Why_Trace_Func is private; PyTrace_Call : constant Why_Trace_Func; PyTrace_Exception : constant Why_Trace_Func; PyTrace_Line : constant Why_Trace_Func; PyTrace_Return : constant Why_Trace_Func; PyTrace_C_Call : constant Why_Trace_Func; PyTrace_C_Exception : constant Why_Trace_Func; PyTrace_C_Return : constant Why_Trace_Func; type Py_Trace_Func is access function (User_Arg : PyObject; Frame : PyFrameObject; Why : Why_Trace_Func; Object : PyObject) return Integer; -- Return 0 in case of success, or -1 if an exception is raised. -- Objects's value depends on the type of callback. For PyTrace_Return, -- this is the returned value. For PyTrace_Exception, this is the -- exception. PyTrace_Line is called for all instructions, but only for -- the trace function, not the profile function. procedure PyEval_SetProfile (Proc : Py_Trace_Func; User_Arg : PyObject); -- Register a new profiling function procedure PyEval_SetTrace (Proc : Py_Trace_Func; User_Arg : PyObject); -- Register a new tracing function function PyFrame_GetLineNumber (Frame : PyFrameObject) return Integer; -- Return the line number that frame is currently executing. function PyFrame_Get_Code (Frame : PyFrameObject) return PyCodeObject; -- Return code object associated with the frame. -- With Python prior from 3.9 return a borrowed reference (no need to -- Py_DECREF) -- Starting with Python 3.9 creates a new reference to the code object. function PyCode_Get_Filename (Code : PyCodeObject) return PyObject; -- Return file name of the code object. -- Returns a borrowed reference, no need to Py_DECREF function PyCode_Get_Name (Code : PyCodeObject) return PyObject; -- Return function name of the code object. -- Returns a borrowed reference, no need to Py_DECREF function PyFrame_Get_Back (Frame : PyFrameObject) return PyFrameObject; -- Return previous frame in stack. -- With Python prior from 3.9 return a borrowed reference (no need to -- Py_DECREF) -- Starting with Python 3.9 creates a new reference to the frame object. ------------- -- Threads -- ------------- type PyThreadState_Opaque is limited private; type PyThreadState is access all PyThreadState_Opaque; private type PyObject_Opaque is null record; type PyThreadState_Opaque is null record; type Interpreter_State is new Integer; Py_Single_Input : constant Interpreter_State := 256; Py_File_Input : constant Interpreter_State := 257; Py_Eval_Input : constant Interpreter_State := 258; -- Values are copied from Python.h, and must be synchronized. They will -- probably never change, though, so this should be safe. type Why_Trace_Func is new Integer; PyTrace_Call : constant Why_Trace_Func := 0; PyTrace_Exception : constant Why_Trace_Func := 1; PyTrace_Line : constant Why_Trace_Func := 2; PyTrace_Return : constant Why_Trace_Func := 3; PyTrace_C_Call : constant Why_Trace_Func := 4; PyTrace_C_Exception : constant Why_Trace_Func := 5; PyTrace_C_Return : constant Why_Trace_Func := 6; type C_Callback_Record is new Integer; -- whatever No_MethodDef : constant PyMethodDef := (Interfaces.C.Strings.Null_Ptr, null, 0, Interfaces.C.Strings.Null_Ptr); No_MethodDef_Array : constant PyMethodDef_Array := (1 .. 0 => No_MethodDef); pragma Convention (C, Py_Trace_Func); pragma Import (C, PyDict_New, "PyDict_New"); pragma Import (C, PyEval_SetProfile, "PyEval_SetProfile"); pragma Import (C, PyEval_SetTrace, "PyEval_SetTrace"); pragma Inline (PyImport_AddModule); pragma Inline (PyRun_SimpleString); pragma Inline (PyArg_ParseTuple); pragma Inline (PyString_Check); pragma Inline (PyUnicode_Check); pragma Inline (PyInt_Check); pragma Inline (PyFloat_Check); pragma Import (C, PyModule_GetDict, "PyModule_GetDict"); pragma Import (C, Py_INCREF, "ada_py_incref"); pragma Import (C, Py_DECREF, "ada_py_decref"); pragma Import (C, Py_XINCREF, "ada_py_xincref"); pragma Import (C, Py_XDECREF, "ada_py_xdecref"); pragma Import (C, PyErr_Print, "PyErr_Print"); pragma Import (C, PyObject_Str, "PyObject_Str"); pragma Import (C, PyObject_Call, "PyObject_Call"); pragma Import (C, PyEval_EvalCode, "PyEval_EvalCode"); pragma Import (C, PyEval_EvalCodeEx, "ada_PyEval_EvalCodeEx"); pragma Import (C, PyErr_SetInterrupt, "PyErr_SetInterrupt"); pragma Import (C, PyTuple_New, "PyTuple_New"); pragma Import (C, PyTuple_GetItem, "PyTuple_GetItem"); pragma Import (C, PyTuple_SetItem, "PyTuple_SetItem"); pragma Import (C, Py_None, "ada_py_none"); pragma Import (C, PyErr_Clear, "PyErr_Clear"); pragma Import (C, PyErr_Fetch, "PyErr_Fetch"); pragma Import (C, PyTuple_Size, "PyTuple_Size"); pragma Import (C, PyInt_FromLong, "PyInt_FromLong"); pragma Import (C, PyInt_FromSize_t, "PyInt_FromSize_t"); pragma Import (C, PyInt_AsLong, "PyInt_AsLong"); pragma Import (C, PyFloat_AsDouble, "PyFloat_AsDouble"); pragma Import (C, PyInt_GetMax, "PyInt_GetMax"); pragma Import (C, PyList_New, "PyList_New"); pragma Import (C, PyList_Append, "PyList_Append"); pragma Import (C, PyErr_BadArgument, "PyErr_BadArgument"); pragma Import (C, PyErr_NormalizeException, "PyErr_NormalizeException"); pragma Import (C, PyObject_Dir, "PyObject_Dir"); pragma Import (C, PyObject_Repr, "PyObject_Repr"); pragma Import (C, PyErr_Restore, "PyErr_Restore"); pragma Import (C, PyDict_Size, "PyDict_Size"); pragma Import (C, PyList_GetItem, "PyList_GetItem"); pragma Import (C, PyList_Size, "PyList_Size"); pragma Import (C, PyDict_SetItem, "PyDict_SetItem"); pragma Import (C, PyDict_GetItem, "PyDict_GetItem"); pragma Import (C, Get_Refcount, "ada_pyget_refcount"); pragma Import (C, PyFunction_Get_Code, "ada_pyfunction_get_code"); pragma Import (C, PyFunction_Get_Globals, "ada_pyfunction_get_globals"); pragma Import (C, PyFunction_Get_Closure, "ada_pyfunction_get_closure"); pragma Import (C, PyFunction_Get_Defaults, "ada_pyfunction_get_defaults"); pragma Import (C, PyMethod_Function, "PyMethod_Function"); pragma Import (C, PyMethod_Self, "PyMethod_Self"); pragma Import (C, PyFrame_GetLineNumber, "PyFrame_GetLineNumber"); pragma Import (C, PyFrame_Get_Code, "ada_pyframe_get_code"); pragma Import (C, PyFrame_Get_Back, "ada_pyframe_get_back"); pragma Import (C, PyCode_Get_Filename, "ada_pycode_get_filename"); pragma Import (C, PyCode_Get_Name, "ada_pycode_get_name"); pragma Import (C, Py_TYPE, "__gnatcoll_py_type"); end GNATCOLL.Python; gnatcoll-bindings-25.0.0/python3/gnatcoll-scripts-python.adb000066400000000000000000004352641464374334300241100ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2003-2022, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Characters.Handling; use Ada.Characters.Handling; with Ada.Exceptions; use Ada.Exceptions; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with Ada.Unchecked_Conversion; with Ada.Unchecked_Deallocation; with Interfaces.C.Strings; use Interfaces.C, Interfaces.C.Strings; with GNAT.IO; use GNAT.IO; with GNAT.Strings; use GNAT.Strings; with GNATCOLL.Any_Types.Python; with GNATCOLL.Python.Lifecycle; with GNATCOLL.Python.Errors; with GNATCOLL.Python.Eval; with GNATCOLL.Python.State; with GNATCOLL.Python.Capsule; with GNATCOLL.Scripts.Impl; use GNATCOLL.Scripts, GNATCOLL.Scripts.Impl; with GNATCOLL.Traces; use GNATCOLL.Traces; with System; use System; with System.Storage_Elements; use System.Storage_Elements; package body GNATCOLL.Scripts.Python is package Lifecycle renames GNATCOLL.Python.Lifecycle; package PyErr renames GNATCOLL.Python.Errors; package Eval renames GNATCOLL.Python.Eval; package PyState renames GNATCOLL.Python.State; package PyC renames GNATCOLL.Python.Capsule; Me : constant Trace_Handle := Create ("PYTHON"); Me_Error : constant Trace_Handle := Create ("PYTHON.ERROR", On); Me_Stack : constant Trace_Handle := Create ("PYTHON.TB", Off); Me_Log : constant Trace_Handle := Create ("SCRIPTS.LOG", Off); Me_Crash : constant Trace_Handle := Create ("PYTHON.TRACECRASH", On); Finalized : Boolean := True; -- Whether Python has been finalized (or never initialized). function Ada_Py_Builtin return Interfaces.C.Strings.chars_ptr; pragma Import (C, Ada_Py_Builtin, "ada_py_builtin"); function Ada_Py_Builtins return Interfaces.C.Strings.chars_ptr; pragma Import (C, Ada_Py_Builtins, "ada_py_builtins"); Builtin_Name : constant String := Value (Ada_Py_Builtin); Builtins_Name : constant String := Value (Ada_Py_Builtins); procedure Set_Item (Args : PyObject; T : Integer; Item : PyObject); -- Change the T-th item in Args. -- This increases the refcount of Item procedure Name_Parameters (Data : in out Python_Callback_Data; Params : Param_Array); -- Internal version of Name_Parameters type Property_User_Data_Record is record Script : Python_Scripting; Prop : Property_Descr_Access; end record; type Property_User_Data is access all Property_User_Data_Record; function Convert is new Ada.Unchecked_Conversion (System.Address, Property_User_Data); function Convert is new Ada.Unchecked_Conversion (Property_User_Data, System.Address); -- Subprograms needed to support the user data passed to the Property -- setters and getters procedure Run_Callback (Script : Python_Scripting; Cmd : Module_Command_Function; Command : String; Data : in out Python_Callback_Data'Class; Result : out PyObject); -- Return Cmd and pass (Data, Command) parameters to it. -- This properly handles returned value, exceptions and python errors. -- This also freed the memory used by Data ------------------------ -- Python_Subprograms -- ------------------------ type Python_Subprogram_Record is new Subprogram_Record with record Script : Python_Scripting; Subprogram : PyObject; end record; overriding function Execute (Subprogram : access Python_Subprogram_Record; Args : Callback_Data'Class; Error : not null access Boolean) return Boolean; overriding function Execute (Subprogram : access Python_Subprogram_Record; Args : Callback_Data'Class; Error : not null access Boolean) return String; overriding function Execute (Subprogram : access Python_Subprogram_Record; Args : Callback_Data'Class; Error : not null access Boolean) return Any_Type; overriding function Execute (Subprogram : access Python_Subprogram_Record; Args : Callback_Data'Class; Error : not null access Boolean) return Class_Instance; overriding function Execute (Subprogram : access Python_Subprogram_Record; Args : Callback_Data'Class; Error : not null access Boolean) return GNAT.Strings.String_List; overriding function Execute (Subprogram : access Python_Subprogram_Record; Args : Callback_Data'Class; Error : not null access Boolean) return List_Instance'Class; overriding procedure Free (Subprogram : in out Python_Subprogram_Record); overriding function Get_Name (Subprogram : access Python_Subprogram_Record) return String; overriding function Get_Script (Subprogram : Python_Subprogram_Record) return Scripting_Language; -- See doc from inherited subprograms -------------------------- -- Python_Callback_Data -- -------------------------- procedure Prepare_Value_Key (Data : in out Python_Callback_Data'Class; Key : PyObject; Append : Boolean); -- Internal version of Set_Return_Value_Key --------------------------- -- Python_Class_Instance -- --------------------------- type Python_Class_Instance_Record is new Class_Instance_Record with record Data : PyObject; end record; type Python_Class_Instance is access all Python_Class_Instance_Record'Class; overriding procedure Free (Self : in out Python_Class_Instance_Record); overriding function Get_User_Data (Inst : not null access Python_Class_Instance_Record) return access User_Data_List; overriding function Print_Refcount (Instance : access Python_Class_Instance_Record) return String; overriding function Is_Subclass (Instance : access Python_Class_Instance_Record; Base : String) return Boolean; overriding procedure Set_Property (Instance : access Python_Class_Instance_Record; Name : String; Value : Integer); overriding procedure Set_Property (Instance : access Python_Class_Instance_Record; Name : String; Value : Boolean); overriding procedure Set_Property (Instance : access Python_Class_Instance_Record; Name : String; Value : Float); overriding procedure Set_Property (Instance : access Python_Class_Instance_Record; Name : String; Value : String); overriding function Get_Method (Instance : access Python_Class_Instance_Record; Name : String) return Subprogram_Type; -- See doc from inherited subprogram function Get_CI (Script : Python_Scripting; Object : PyObject) return Class_Instance; -- Wraps the python object into a Class_Instance. -- The refcount of the object is increased by one, owned by Class_Instance. ------------------ -- Handler_Data -- ------------------ type Handler_Data is record Script : Python_Scripting; Cmd : Command_Descr_Access; end record; type Handler_Data_Access is access Handler_Data; -- Information stored with each python function to call the right Ada -- subprogram. function Command_Name (Data : Handler_Data) return String; -- Return the qualified name of the command "command" or "class.command" function Convert is new Ada.Unchecked_Conversion (System.Address, Handler_Data_Access); procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Handler_Data, Handler_Data_Access); procedure Destroy_Handler_Data (Capsule : PyC.PyCapsule); pragma Convention (C, Destroy_Handler_Data); -- Called when the python object associated with Handler is destroyed ------------------------------- -- Class_Instance properties -- ------------------------------- type PyObject_Data_Record is record Props : aliased User_Data_List; end record; type PyObject_Data is access all PyObject_Data_Record; -- Data stored in each PyObject representing a class instance, as a -- __gps_data property. function Convert is new Ada.Unchecked_Conversion (System.Address, PyObject_Data); procedure Unchecked_Free is new Ada.Unchecked_Deallocation (PyObject_Data_Record, PyObject_Data); procedure On_PyObject_Data_Destroy (Capsule : PyC.PyCapsule); pragma Convention (C, On_PyObject_Data_Destroy); -- Called when the __gps_data property is destroyed. ---------------------- -- Interpreter_View -- ---------------------- function First_Level (Self : PyC.PyCapsule; Args, Kw : PyObject) return PyObject; pragma Convention (C, First_Level); -- First level handler for all functions exported to python. This function -- is in charge of dispatching to the actual Ada subprogram. procedure Setup_Return_Value (Data : in out Python_Callback_Data'Class); -- Mark Data as containing a return value, and free the previous value if -- there is any function First_Level_Getter (Obj : PyObject; Closure : System.Address) return PyObject; pragma Convention (C, First_Level_Getter); -- Handles getters for descriptor objects function First_Level_Setter (Obj, Value : PyObject; Closure : System.Address) return Integer; pragma Convention (C, First_Level_Setter); -- Handles setters for descriptor objects procedure Trace_Dump (Name : String; Obj : PyObject); pragma Unreferenced (Trace_Dump); -- Print debug info for Obj function Refcount_Msg (Obj : PyObject) return Interfaces.C.Strings.chars_ptr; pragma Import (C, Refcount_Msg, "ada_py_refcount_msg"); -- Print a debug message to trace the refcounting on Obj function Run_Command (Script : access Python_Scripting_Record'Class; Command : String; Console : Virtual_Console := null; Show_Command : Boolean := False; Hide_Output : Boolean := False; Hide_Exceptions : Boolean := False; Errors : access Boolean) return String; -- Same as above, but also return the output of the command procedure Python_Global_Command_Handler (Data : in out Callback_Data'Class; Command : String); -- Handles all commands pre-defined in this module procedure Log_Python_Exception; -- Log the current exception to a trace_handle ------------------------ -- Internals Nth_Arg -- ------------------------ function Nth_Arg (Data : Python_Callback_Data; N : Positive; Success : access Boolean) return String; function Nth_Arg (Data : Python_Callback_Data; N : Positive; Success : access Boolean) return Unbounded_String; function Nth_Arg (Data : Python_Callback_Data; N : Positive; Success : access Boolean) return Integer; function Nth_Arg (Data : Python_Callback_Data; N : Positive; Success : access Boolean) return Float; function Nth_Arg (Data : Python_Callback_Data; N : Positive; Success : access Boolean) return Boolean; function Nth_Arg (Data : Python_Callback_Data; N : Positive; Success : access Boolean) return Subprogram_Type; function Nth_Arg (Data : Python_Callback_Data; N : Positive; Class : Class_Type; Allow_Null : Boolean; Success : access Boolean) return Class_Instance; -- These functions are called by the overridden Nth_Arg functions. They try -- to return the parameter at the location N. If no parameter is found, -- Success is false, true otherwise. It's the responsibility of the -- enclosing Nth_Arg to either raise a No_Such_Parameter exception or to -- return a default value. ------------- -- Modules -- ------------- function Lookup_Module (Self : not null access Python_Scripting_Record'Class; Name : String) return PyObject; -- Return the module object. function Lookup_Object (Self : not null access Python_Scripting_Record'Class; Qualified_Name : String) return PyObject; -- Lookup an object from its fully qualified name (module.module.name). -- If there is no module specified, the object is looked for in the default -- module, or the builtins. ------------------ -- Dictionaries -- ------------------ type Python_Dictionary_Instance is new Dictionary_Instance with record Script : Python_Scripting; Dict : PyObject; end record; function Iterator (Self : Python_Dictionary_Instance) return Dictionary_Iterator'Class; -- Returns iterator for given dictionary function Has_Key (Self : Python_Dictionary_Instance; Key : String) return Boolean; function Has_Key (Self : Python_Dictionary_Instance; Key : Integer) return Boolean; function Has_Key (Self : Python_Dictionary_Instance; Key : Float) return Boolean; function Has_Key (Self : Python_Dictionary_Instance; Key : Boolean) return Boolean; -- Returns True when dictionary has value for given key function Value (Self : Python_Dictionary_Instance; Key : String) return String; function Value (Self : Python_Dictionary_Instance; Key : Integer) return String; function Value (Self : Python_Dictionary_Instance; Key : Float) return String; function Value (Self : Python_Dictionary_Instance; Key : Boolean) return String; function Value (Self : Python_Dictionary_Instance; Key : String) return Integer; function Value (Self : Python_Dictionary_Instance; Key : Integer) return Integer; function Value (Self : Python_Dictionary_Instance; Key : Float) return Integer; function Value (Self : Python_Dictionary_Instance; Key : Boolean) return Integer; function Value (Self : Python_Dictionary_Instance; Key : String) return Float; function Value (Self : Python_Dictionary_Instance; Key : Integer) return Float; function Value (Self : Python_Dictionary_Instance; Key : Float) return Float; function Value (Self : Python_Dictionary_Instance; Key : Boolean) return Float; function Value (Self : Python_Dictionary_Instance; Key : String) return Boolean; function Value (Self : Python_Dictionary_Instance; Key : Integer) return Boolean; function Value (Self : Python_Dictionary_Instance; Key : Float) return Boolean; function Value (Self : Python_Dictionary_Instance; Key : Boolean) return Boolean; -- Returns value of given key type Python_Dictionary_Iterator is new Dictionary_Iterator with record Script : Python_Scripting; Dict : PyObject; Position : Integer := 0; Key : PyObject; Value : PyObject; end record; function Next (Self : not null access Python_Dictionary_Iterator) return Boolean; -- Moves iterator to next pair in dictionary. Returns False when where is -- no more pairs available. function Key (Self : Python_Dictionary_Iterator) return String; function Key (Self : Python_Dictionary_Iterator) return Integer; function Key (Self : Python_Dictionary_Iterator) return Float; function Key (Self : Python_Dictionary_Iterator) return Boolean; -- Returns value of current pair in dictionary function Value (Self : Python_Dictionary_Iterator) return String; function Value (Self : Python_Dictionary_Iterator) return Integer; function Value (Self : Python_Dictionary_Iterator) return Float; function Value (Self : Python_Dictionary_Iterator) return Boolean; -- Returns value of current pair in dictionary function Conditional_To (Condition : Boolean; Object : PyObject; Name : String) return String; function Conditional_To (Condition : Boolean; Object : PyObject; Name : String) return Integer; function Conditional_To (Condition : Boolean; Object : PyObject; Name : String) return Float; function Conditional_To (Condition : Boolean; Script : Scripting_Language; Object : PyObject) return Boolean; -- Converts Python's value when Condition is true function Internal_To (Object : PyObject; Name : String) return String; function Internal_To (Object : PyObject; Name : String) return Integer; function Internal_To (Object : PyObject; Name : String) return Float; function Internal_To (Script : Scripting_Language; Object : PyObject) return Boolean; -- Converts Python's value ---------------- -- Tracebacks -- ---------------- function Trace_Python_Code (User_Arg : GNATCOLL.Python.PyObject; Frame : GNATCOLL.Python.PyFrameObject; Why : GNATCOLL.Python.Why_Trace_Func; Object : GNATCOLL.Python.PyObject) return Integer with Convention => C; -- Trace callback routine Last_Call_Frame : PyFrameObject := null; -- Global variable to save frame object of the last call function Error_Message_With_Stack return String; -- Returns error message with Python stack when available -------------------- -- Block_Commands -- -------------------- procedure Block_Commands (Script : access Python_Scripting_Record; Block : Boolean) is begin Script.Blocked := Block; end Block_Commands; ---------------- -- Trace_Dump -- ---------------- procedure Trace_Dump (Name : String; Obj : PyObject) is Lock : PyState.Ada_GIL_Lock with Unreferenced; S : PyObject; begin if Obj = null then Put_Line (Name & "="); else -- Special handling here, since for a string PyObject_Str returns -- the string itself, thus impacting the refcounting S := PyObject_Str (Obj); if S = Obj then Py_DECREF (Obj); -- Preserve original refcount end if; Put_Line (Name & "=""" & PyString_AsString (S) & '"' & ASCII.LF & " refcount=" & Value (Refcount_Msg (Obj))); if S /= Obj then Py_DECREF (S); end if; -- Other possible debug info: -- repr = PyString_AsString (PyObject_Repr (Obj)) -- methods = PyString_AsString (PyObject_Str (PyObject_Dir (Obj))) end if; end Trace_Dump; ------------------ -- Command_Name -- ------------------ function Command_Name (Data : Handler_Data) return String is begin if Data.Cmd.Class = No_Class then return Data.Cmd.Command; else return Get_Name (Data.Cmd.Class) & "." & Data.Cmd.Command; end if; end Command_Name; ------------- -- Destroy -- ------------- procedure Destroy (Script : access Python_Scripting_Record) is Ignored : Boolean; begin if not Finalized then Trace (Me, "Finalizing python"); Finalized := True; Set_Default_Console (Script, null); Free (Script.Buffer); Ignored := Lifecycle.Py_Finalize; end if; end Destroy; ---------------------------- -- Command_Line_Treatment -- ---------------------------- overriding function Command_Line_Treatment (Script : access Python_Scripting_Record) return Command_Line_Mode is pragma Unreferenced (Script); begin return Raw_String; end Command_Line_Treatment; -------------------------------------- -- Register_Python_Module_Scripting -- -------------------------------------- function Register_Python_Module_Scripting (Repo : access Scripts.Scripts_Repository_Record'Class; Module : String) return GNATCOLL.Python.PyObject is Script : Python_Scripting; begin return Result : constant GNATCOLL.Python.PyObject := Py_InitModule (Module & ASCII.NUL) do Script := new Python_Scripting_Record; Script.Repo := Scripts_Repository (Repo); Repo.Register_Scripting_Language (Script); Finalized := False; Script.Module := Result; end return; end Register_Python_Module_Scripting; ------------------------------- -- Register_Python_Scripting -- ------------------------------- procedure Register_Python_Scripting (Repo : access Scripts.Scripts_Repository_Record'Class; Module : String; Program_Name : String := "python"; Python_Home : String := "") is Script : Python_Scripting; Ignored : Integer; pragma Unreferenced (Ignored); function Initialize_Py_And_Module (Program, Module : String) return PyObject; pragma Import (C, Initialize_Py_And_Module, "ada_py_initialize_and_module"); Main_Module : PyObject; begin Script := new Python_Scripting_Record; Script.Repo := Scripts_Repository (Repo); Register_Scripting_Language (Repo, Script); -- Set the program name and python home if Python_Home /= "" then Lifecycle.Py_SetPythonHome (Python_Home); end if; Script.Module := Initialize_Py_And_Module (Program_Name & ASCII.NUL, Module & ASCII.NUL); if Script.Module = null then raise Program_Error with "Could not import module " & Module; end if; Finalized := False; declare Lock : PyState.Ada_GIL_Lock with Unreferenced; begin if Active (Me_Stack) and then not PyRun_SimpleString ("import traceback") then raise Program_Error with "Could not import traceback.py"; end if; Main_Module := PyImport_AddModule ("__main__"); if Main_Module = null then raise Program_Error with "Could not import module __main__"; end if; Script.Globals := PyModule_GetDict (Main_Module); Script.Buffer := new String'(""); Script.Builtin := PyImport_ImportModule (Builtin_Name); Script.Exception_Unexpected := PyErr_NewException (Module & ".Unexpected_Exception", null, null); Ignored := PyModule_AddObject (Script.Module, "Unexpected_Exception" & ASCII.NUL, Script.Exception_Unexpected); Script.Exception_Misc := PyErr_NewException (Module & ".Exception", null, null); Ignored := PyModule_AddObject (Script.Module, "Exception" & ASCII.NUL, Script.Exception_Misc); Script.Exception_Missing_Args := PyErr_NewException (Module & ".Missing_Arguments", null, null); Ignored := PyModule_AddObject (Script.Module, "Missing_Arguments" & ASCII.NUL, Script.Exception_Missing_Args); Script.Exception_Invalid_Arg := PyErr_NewException (Module & ".Invalid_Argument", null, null); Ignored := PyModule_AddObject (Script.Module, "Invalid_Argument" & ASCII.NUL, Script.Exception_Invalid_Arg); -- PyGTK prints its error messages using sys.argv, which doesn't -- exist in non-interactive mode. We therefore define it here if not PyRun_SimpleString ("sys.argv=['" & Module & "']") then Trace (Me_Error, "Could not initialize sys.argv"); end if; -- This function is required for support of the Python menu -- (F120-025), so that we can execute python commands in the context -- of the global interpreter instead of the current context -- (for the menu, that would be python_support.py, and thus would -- have no impact on the interpreter itself) Register_Command (Repo, Command => "exec_in_console", Handler => Python_Global_Command_Handler'Access, Minimum_Args => 1, Maximum_Args => 1, Language => Python_Name); if Active (Me_Crash) then PyEval_SetTrace (Trace_Python_Code'Access, null); end if; end; end Register_Python_Scripting; ----------------------------------- -- Python_Global_Command_Handler -- ----------------------------------- procedure Python_Global_Command_Handler (Data : in out Callback_Data'Class; Command : String) is Result : PyObject; Errors : aliased Boolean; begin if Command = "exec_in_console" then Result := Run_Command (Python_Scripting (Get_Script (Data)), Command => Nth_Arg (Data, 1), Need_Output => False, Show_Command => True, Errors => Errors'Unchecked_Access); Py_XDECREF (Result); end if; end Python_Global_Command_Handler; -------------------------- -- Destroy_Handler_Data -- -------------------------- procedure Destroy_Handler_Data (Capsule : PyC.PyCapsule) is H : Handler_Data_Access := Convert (PyC.PyCapsule_GetPointer (Capsule)); begin Unchecked_Free (H); end Destroy_Handler_Data; ---------- -- Free -- ---------- procedure Free (Data : in out Python_Callback_Data) is Lock : PyState.Ada_GIL_Lock with Unreferenced; begin if Data.Args /= null then Py_DECREF (Data.Args); end if; if Data.Kw /= null then Py_DECREF (Data.Kw); end if; if Data.Return_Value /= null then Py_DECREF (Data.Return_Value); Data.Return_Value := null; end if; if Data.Return_Dict /= null then Py_DECREF (Data.Return_Dict); Data.Return_Dict := null; end if; end Free; -------------- -- Set_Item -- -------------- procedure Set_Item (Args : PyObject; T : Integer; Item : PyObject) is Lock : PyState.Ada_GIL_Lock with Unreferenced; N : Integer; pragma Unreferenced (N); begin -- Special case tuples, since they are immutable through -- PyObject_SetItem if PyTuple_Check (Args) then Py_INCREF (Item); PyTuple_SetItem (Args, T, Item); -- Doesn't modify refcount -- Also special case lists, since we want to append if the index is -- too big elsif PyList_Check (Args) then if T < PyList_Size (Args) then PyObject_SetItem (Args, T, Item); else N := PyList_Append (Args, Item); end if; else PyObject_SetItem (Args, T, Item); end if; end Set_Item; ----------- -- Clone -- ----------- function Clone (Data : Python_Callback_Data) return Callback_Data'Class is Lock : PyState.Ada_GIL_Lock with Unreferenced; D : Python_Callback_Data := Data; Item : PyObject; Size : Integer; begin if D.Args /= null then Size := PyObject_Size (D.Args); D.Args := PyTuple_New (Size); for T in 0 .. Size - 1 loop Item := PyObject_GetItem (Data.Args, T); Set_Item (D.Args, T, Item); Py_DECREF (Item); end loop; end if; if D.Kw /= null then Py_INCREF (D.Kw); end if; D.Return_Value := null; D.Return_Dict := null; return D; end Clone; ------------ -- Create -- ------------ function Create (Script : access Python_Scripting_Record; Arguments_Count : Natural) return Callback_Data'Class is Lock : GNATCOLL.Python.State.Ada_GIL_Lock with Unreferenced; Callback : constant Python_Callback_Data := (Callback_Data with Script => Python_Scripting (Script), Args => PyTuple_New (Arguments_Count), Kw => null, Return_Value => null, Return_Dict => null, Has_Return_Value => False, Return_As_List => False, First_Arg_Is_Self => False); begin return Callback; end Create; ----------------- -- Set_Nth_Arg -- ----------------- procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : PyObject) is Lock : PyState.Ada_GIL_Lock with Unreferenced; begin Set_Item (Data.Args, N - 1, Value); Py_DECREF (Value); end Set_Nth_Arg; ----------------- -- Set_Nth_Arg -- ----------------- procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : Subprogram_Type) is Lock : PyState.Ada_GIL_Lock with Unreferenced; Subp : constant PyObject := Python_Subprogram_Record (Value.all).Subprogram; begin Set_Item (Data.Args, N - 1, Subp); Py_DECREF (Subp); end Set_Nth_Arg; ----------------- -- Set_Nth_Arg -- ----------------- procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : String) is Lock : PyState.Ada_GIL_Lock with Unreferenced; Item : constant PyObject := PyString_FromString (Value); begin Set_Item (Data.Args, N - 1, Item); Py_DECREF (Item); end Set_Nth_Arg; ----------------- -- Set_Nth_Arg -- ----------------- procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : Integer) is Lock : PyState.Ada_GIL_Lock with Unreferenced; Item : constant PyObject := PyInt_FromLong (Interfaces.C.long (Value)); begin Set_Item (Data.Args, N - 1, Item); Py_DECREF (Item); end Set_Nth_Arg; ----------------- -- Set_Nth_Arg -- ----------------- procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : Float) is Lock : PyState.Ada_GIL_Lock with Unreferenced; Item : constant PyObject := PyFloat_FromDouble (Interfaces.C.double (Value)); begin Set_Item (Data.Args, N - 1, Item); Py_DECREF (Item); end Set_Nth_Arg; ----------------- -- Set_Nth_Arg -- ----------------- procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : Boolean) is Lock : PyState.Ada_GIL_Lock with Unreferenced; Item : constant PyObject := PyInt_FromLong (Boolean'Pos (Value)); begin Set_Item (Data.Args, N - 1, Item); Py_DECREF (Item); end Set_Nth_Arg; ----------------- -- Set_Nth_Arg -- ----------------- procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : Class_Instance) is Lock : PyState.Ada_GIL_Lock with Unreferenced; Inst : PyObject; begin if Value = No_Class_Instance then Set_Item (Data.Args, N - 1, Py_None); -- Increments refcount else Inst := Python_Class_Instance (Get_CIR (Value)).Data; Set_Item (Data.Args, N - 1, Inst); -- Increments refcount end if; end Set_Nth_Arg; ----------------- -- Set_Nth_Arg -- ----------------- procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : List_Instance) is Lock : PyState.Ada_GIL_Lock with Unreferenced; V : constant PyObject := Python_Callback_Data (Value).Args; begin Set_Item (Data.Args, N - 1, V); -- Increments refcount end Set_Nth_Arg; ----------------- -- First_Level -- ----------------- function First_Level (Self : Capsule.PyCapsule; Args, Kw : PyObject) return PyObject is -- Args and Kw could both be null, as called from PyCFunction_Call Lock : PyState.Ada_GIL_Lock with Unreferenced; Handler : Handler_Data_Access; Size : Integer := 0; Callback : Python_Callback_Data; First_Arg_Is_Self : Boolean; Result : PyObject; begin Handler := Convert (Capsule.PyCapsule_GetPointer (Self)); if Finalized and then Handler.Cmd.Command /= Destructor_Method then PyErr_SetString (Handler.Script.Exception_Unexpected, "Application was already finalized"); return null; end if; if Active (Me_Log) then Trace (Me_Log, "First_Level: " & Handler.Cmd.Command); end if; if Active (Me_Stack) then declare Module : constant PyObject := PyImport_ImportModule ("traceback"); Newline, List, Join : PyObject; begin if Module /= null then List := PyObject_CallMethod (Module, "format_stack"); if List /= null then Newline := PyString_FromString (""); Join := PyObject_CallMethod (Newline, "join", List); Trace (Me_Stack, "Exec " & Command_Name (Handler.all) & ASCII.LF & PyString_AsString (Join)); Py_DECREF (Newline); Py_DECREF (List); Py_DECREF (Join); end if; end if; exception when E : others => Trace (Me_Stack, E); end; end if; if Args /= null then Size := PyObject_Size (Args); end if; if Kw /= null then declare S : constant Integer := PyDict_Size (Kw); begin if S < 0 then raise Program_Error with "Incorrect dictionary when calling function " & Handler.Cmd.Command; end if; Size := S + Size; end; end if; First_Arg_Is_Self := Handler.Cmd.Class /= No_Class and then not Handler.Cmd.Static_Method; if First_Arg_Is_Self then Size := Size - 1; -- First param is always the instance end if; -- Special case for constructors: -- when we were using old-style classes, New_Instance was not calling -- __init__. With new-style classes, however, __init__ is already called -- when we call the metatype(). In particular, this means that the -- profile of New_Instance should allow passing custom parameters, -- otherwise the call to __init__ fails. -- So for now we simply allow a call to the constructor with no -- parameter, which does nothing. -- This is not very elegant, since from python's point of view, this -- relies on the user calling New_Instance and immediately initializing -- the Class_Instance as done in the Constructor_Method handler. if Handler.Script.Ignore_Constructor and then Handler.Cmd.Command = Constructor_Method then Py_INCREF (Py_None); return Py_None; end if; -- Check number of arguments if Handler.Cmd.Minimum_Args > Size or else Size > Handler.Cmd.Maximum_Args then if Handler.Cmd.Minimum_Args > Size then PyErr_SetString (Handler.Script.Exception_Missing_Args, "Wrong number of parameters for " & Handler.Cmd.Command & ", expecting at least" & Handler.Cmd.Minimum_Args'Img & ", received" & Size'Img); else PyErr_SetString (Handler.Script.Exception_Missing_Args, "Wrong number of parameters for " & Handler.Cmd.Command & ", expecting at most" & Handler.Cmd.Maximum_Args'Img & ", received" & Size'Img); end if; return null; end if; Callback.Args := Args; Py_XINCREF (Callback.Args); Callback.Kw := Kw; Py_XINCREF (Callback.Kw); Callback.Return_Value := null; Callback.Return_Dict := null; Callback.Script := Handler.Script; Callback.First_Arg_Is_Self := First_Arg_Is_Self; if Handler.Cmd.Params /= null then Name_Parameters (Callback, Handler.Cmd.Params.all); end if; Run_Callback (Handler.Script, Handler.Cmd.Handler, Handler.Cmd.Command, Callback, Result); return Result; end First_Level; ------------------ -- Run_Callback -- ------------------ procedure Run_Callback (Script : Python_Scripting; Cmd : Module_Command_Function; Command : String; Data : in out Python_Callback_Data'Class; Result : out PyObject) is Lock : PyState.Ada_GIL_Lock with Unreferenced; begin -- Return_Value will be set to null in case of error Data.Return_Value := Py_None; Py_INCREF (Py_None); Cmd.all (Data, Command); if Data.Return_Dict /= null then Result := Data.Return_Dict; else Result := Data.Return_Value; -- might be null for an exception end if; Py_XINCREF (Result); Free (Data); exception when E : Invalid_Parameter => if not Data.Has_Return_Value or else Data.Return_Value /= null then PyErr_SetString (Script.Exception_Invalid_Arg, Exception_Message (E)); end if; Free (Data); Result := null; when E : others => if not Data.Has_Return_Value or else Data.Return_Value /= null then PyErr_SetString (Script.Exception_Unexpected, "unexpected internal exception " & Exception_Information (E)); end if; Free (Data); Result := null; end Run_Callback; ------------------------ -- First_Level_Getter -- ------------------------ function First_Level_Getter (Obj : PyObject; Closure : System.Address) return PyObject is Lock : PyState.Ada_GIL_Lock with Unreferenced; Prop : constant Property_User_Data := Convert (Closure); Callback : Python_Callback_Data; Args : PyObject; Result : PyObject; begin if Active (Me_Log) then Trace (Me_Log, "First_Level_Getter " & Prop.Prop.Name); end if; Args := PyTuple_New (1); Py_INCREF (Obj); PyTuple_SetItem (Args, 0, Obj); -- don't increase refcount of Obj Callback := (Script => Prop.Script, Args => Args, -- Now owned by Callback Kw => null, Return_Value => null, Return_Dict => null, Has_Return_Value => False, Return_As_List => False, First_Arg_Is_Self => False); Run_Callback (Prop.Script, Prop.Prop.Getter, Prop.Prop.Name, Callback, Result); -- Run_Callback frees Callback, which decref Args return Result; end First_Level_Getter; ------------------------ -- First_Level_Setter -- ------------------------ function First_Level_Setter (Obj, Value : PyObject; Closure : System.Address) return Integer is Lock : PyState.Ada_GIL_Lock with Unreferenced; Prop : constant Property_User_Data := Convert (Closure); Callback : Python_Callback_Data; Args : PyObject; Result : PyObject; begin if Active (Me_Log) then Trace (Me_Log, "First_Level_Setter " & Prop.Prop.Name); end if; Args := PyTuple_New (2); Py_INCREF (Obj); PyTuple_SetItem (Args, 0, Obj); -- don't increase refcount of Obj Py_INCREF (Value); PyTuple_SetItem (Args, 1, Value); -- don't increase refcount of Value Callback := (Script => Prop.Script, Args => Args, -- Now owned by Callback Kw => null, Return_Value => null, Return_Dict => null, Has_Return_Value => False, Return_As_List => False, First_Arg_Is_Self => False); Run_Callback (Prop.Script, Prop.Prop.Setter, Prop.Prop.Name, Callback, Result); -- Run_Callback frees Callback, which decref Args if Result = null then return -1; else Py_DECREF (Result); return 0; end if; end First_Level_Setter; ----------------------- -- Register_Property -- ----------------------- overriding procedure Register_Property (Script : access Python_Scripting_Record; Prop : Property_Descr_Access) is Klass : PyObject; Ignored : Boolean; pragma Unreferenced (Ignored); Setter : C_Setter := First_Level_Setter'Access; Getter : C_Getter := First_Level_Getter'Access; H : constant Property_User_Data := new Property_User_Data_Record' (Script => Python_Scripting (Script), Prop => Prop); -- ??? Memory leak. We do not know when H is no longer needed begin if Prop.Setter = null then Setter := null; end if; if Prop.Getter = null then Getter := null; end if; Klass := Lookup_Object (Script, Prop.Class.Qualified_Name.all); Ignored := PyDescr_NewGetSet (Typ => Klass, Name => Prop.Name, Setter => Setter, Getter => Getter, Closure => Convert (H)); end Register_Property; ---------------------- -- Register_Command -- ---------------------- overriding procedure Register_Command (Script : access Python_Scripting_Record; Cmd : Command_Descr_Access) is H : constant Handler_Data_Access := new Handler_Data' (Cmd => Cmd, Script => Python_Scripting (Script)); User_Data : constant PyObject := Capsule.PyCapsule_New (H.all'Address, Destroy_Handler_Data'Access); Klass : PyObject; Def : PyMethodDef; begin if Cmd.Class = No_Class then Add_Function (Module => Script.Module, Func => Create_Method_Def (Cmd.Command, First_Level'Access), Self => User_Data); else if Cmd.Command = Constructor_Method then Def := Create_Method_Def ("__init__", First_Level'Access); elsif Cmd.Command = Addition_Method then Def := Create_Method_Def ("__add__", First_Level'Access); elsif Cmd.Command = Substraction_Method then Def := Create_Method_Def ("__sub__", First_Level'Access); elsif Cmd.Command = Comparison_Method then Def := Create_Method_Def ("__cmp__", First_Level'Access); elsif Cmd.Command = Equal_Method then Def := Create_Method_Def ("__eq__", First_Level'Access); elsif Cmd.Command = Destructor_Method then Def := Create_Method_Def ("__del__", First_Level'Access); else Def := Create_Method_Def (Cmd.Command, First_Level'Access); end if; Klass := Lookup_Object (Script, Cmd.Class.Qualified_Name.all); if Klass = null then Trace (Me_Error, "Class not found " & Cmd.Class.Qualified_Name.all); elsif Cmd.Static_Method then Add_Static_Method (Class => Klass, Func => Def, Self => User_Data, Module => Script.Module); else Add_Method (Class => Klass, Func => Def, Self => User_Data, Module => Script.Module); end if; end if; end Register_Command; ------------------- -- Lookup_Module -- ------------------- function Lookup_Module (Self : not null access Python_Scripting_Record'Class; Name : String) return PyObject is Lock : PyState.Ada_GIL_Lock with Unreferenced; M, Tmp : PyObject := null; First : Natural; begin if Name = "@" then return Self.Module; end if; First := Name'First; for N in Name'First .. Name'Last + 1 loop if N > Name'Last or else Name (N) = '.' then if Name (First .. N - 1) = "@" then M := Self.Module; else if Name (Name'First .. Name'First + 1) = "@." then Tmp := PyImport_AddModule (PyModule_Getname (Self.Module) & '.' & Name (Name'First + 2 .. N - 1)); else Tmp := PyImport_AddModule (Name (Name'First .. N - 1)); end if; if M /= null then declare Name : constant PyObject := PyObject_GetAttrString (M, "__name__"); begin PyDict_SetItemString (PyModule_GetDict (Tmp), "__module__", Name); Py_DECREF (Name); end; Py_INCREF (Tmp); if PyModule_AddObject (M, Name (First .. N - 1), Tmp) /= 0 then Trace (Me_Error, "Could not register submodule " & Name (Name'First .. N - 1)); return null; end if; end if; M := Tmp; end if; First := N + 1; end if; end loop; return M; end Lookup_Module; ------------------- -- Lookup_Object -- ------------------- function Lookup_Object (Self : not null access Python_Scripting_Record'Class; Qualified_Name : String) return PyObject is M : PyObject; begin for N in reverse Qualified_Name'Range loop if Qualified_Name (N) = '.' then M := Lookup_Module (Self, Qualified_Name (Qualified_Name'First .. N - 1)); return Lookup_Object (M, Qualified_Name (N + 1 .. Qualified_Name'Last)); end if; end loop; M := Lookup_Object (Self.Module, Qualified_Name); if M = null then M := Lookup_Object (Self.Builtin, Qualified_Name); end if; return M; end Lookup_Object; -------------------- -- Register_Class -- -------------------- overriding procedure Register_Class (Script : access Python_Scripting_Record; Name : String; Base : Class_Type := No_Class; Module : Module_Type := Default_Module) is Dict : constant PyDictObject := PyDict_New; Class : PyObject; Ignored : Integer; Bases : PyObject := null; S : Interfaces.C.Strings.chars_ptr; pragma Unreferenced (Ignored); M : constant PyObject := Lookup_Module (Script, To_String (Module.Name)); begin declare Name : constant PyObject := PyObject_GetAttrString (M, "__name__"); begin PyDict_SetItemString (Dict, "__module__", Name); Py_DECREF (Name); end; if Base /= No_Class then Bases := Create_Tuple ((1 => Lookup_Object (Script, Base.Qualified_Name.all))); end if; Class := Type_New (Name => Name, Bases => Bases, Dict => Dict); if Class = null then PyErr_Print; raise Program_Error with "Could not register class " & Name; end if; S := New_String (Name); Ignored := PyModule_AddObject (M, S, Class); Py_XDECREF (Bases); Py_XDECREF (Dict); Free (S); end Register_Class; --------------- -- Interrupt -- --------------- function Interrupt (Script : access Python_Scripting_Record) return Boolean is begin if Script.In_Process then PyErr_SetInterrupt; return True; else return False; end if; end Interrupt; -------------- -- Complete -- -------------- procedure Complete (Script : access Python_Scripting_Record; Input : String; Completions : out String_Lists.List) is Start : Natural := Input'First - 1; Last : Natural := Input'Last + 1; Obj, Item : PyObject; Errors : aliased Boolean; begin Completions := String_Lists.Empty_List; for N in reverse Input'Range loop if Input (N) = ' ' or else Input (N) = ASCII.HT then Start := N; exit; elsif Input (N) = '.' and then Last > Input'Last then Last := N; end if; end loop; if Start < Input'Last then Obj := Run_Command (Script, Builtins_Name & ".dir(" & Input (Start + 1 .. Last - 1) & ")", Need_Output => True, Hide_Output => True, Hide_Exceptions => True, Errors => Errors'Unchecked_Access); if Obj /= null then for Index in 0 .. PyList_Size (Obj) - 1 loop Item := PyList_GetItem (Obj, Index); declare S : constant String := PyString_AsString (Item); begin if S'First + Input'Last - Last - 1 <= S'Last and then (Last >= Input'Last or else Input (Last + 1 .. Input'Last) = S (S'First .. S'First + Input'Last - Last - 1)) then String_Lists.Append (Completions, Input (Input'First .. Last - 1) & '.' & S); end if; end; end loop; Py_DECREF (Obj); end if; end if; end Complete; ---------------- -- Get_Prompt -- ---------------- overriding function Get_Prompt (Script : access Python_Scripting_Record) return String is Ps : PyObject; begin if Script.Use_Secondary_Prompt then Ps := PySys_GetObject ("ps2"); if Ps = null then return "... "; end if; else Ps := PySys_GetObject ("ps1"); if Ps = null then return ">>> "; end if; end if; return PyString_AsString (Ps); end Get_Prompt; -------------------- -- Display_Prompt -- -------------------- procedure Display_Prompt (Script : access Python_Scripting_Record; Console : Virtual_Console := null) is begin Insert_Prompt (Script, Console, Get_Prompt (Scripting_Language (Script))); end Display_Prompt; ----------------- -- Run_Command -- ----------------- function Run_Command (Script : access Python_Scripting_Record'Class; Command : String; Console : Virtual_Console := null; Show_Command : Boolean := False; Hide_Output : Boolean := False; Hide_Exceptions : Boolean := False; Errors : access Boolean) return String is Lock : PyState.Ada_GIL_Lock with Unreferenced; Result : PyObject; Str : PyObject; begin Result := Run_Command (Script, Command, Console => Console, Need_Output => True, Show_Command => Show_Command, Hide_Output => Hide_Output, Hide_Exceptions => Hide_Exceptions, Errors => Errors); if Result /= null and then not Errors.all then Str := PyObject_Str (Result); if Str = null then Py_DECREF (Result); return "Error calling __repr__ on the result of the script"; end if; declare S : constant String := PyString_AsString (Str); begin Py_DECREF (Result); Py_DECREF (Str); if Active (Me_Log) then Trace (Me_Log, "output is: " & S); end if; return S; end; else Py_XDECREF (Result); return ""; end if; end Run_Command; -------------------------- -- Log_Python_Exception -- -------------------------- procedure Log_Python_Exception is Lock : PyState.Ada_GIL_Lock with Unreferenced; Typ, Occurrence, Traceback, S : PyObject; begin if Active (Me_Error) then PyErr_Fetch (Typ, Occurrence, Traceback); PyErr_NormalizeException (Typ, Occurrence, Traceback); S := PyObject_Repr (Occurrence); if S /= null then Trace (Me_Error, "Exception " & PyString_AsString (S)); Py_DECREF (S); end if; PyErr_Restore (Typ, Occurrence, Traceback); end if; end Log_Python_Exception; ----------------- -- Run_Command -- ----------------- function Run_Command (Script : access Python_Scripting_Record'Class; Command : String; Need_Output : Boolean; Console : Virtual_Console := null; Show_Command : Boolean := False; Hide_Output : Boolean := False; Hide_Exceptions : Boolean := False; Errors : access Boolean) return PyObject is Lock : PyState.Ada_GIL_Lock with Unreferenced; Result : PyObject := null; Code : PyCodeObject; Indented_Input : constant Boolean := Command'Length > 0 and then (Command (Command'First) = ASCII.HT or else Command (Command'First) = ' '); Cmd : constant String := Script.Buffer.all & Command & ASCII.LF; Typ, Occurrence, Traceback, S : PyObject; Default_Console_Refed : Boolean := False; Default_Console : constant Virtual_Console := Get_Default_Console (Script); State : Interpreter_State; begin if Active (Me_Log) then Trace (Me_Log, "command: " & Script.Buffer.all & Command); end if; Errors.all := False; if Finalized or else Cmd = "" & ASCII.LF then if not Hide_Output then Display_Prompt (Script); end if; return null; end if; if Show_Command and not Hide_Output then Insert_Text (Script, Console, Command & ASCII.LF); end if; -- The following code will not work correctly in multitasking mode if -- each thread is redirecting to a different console. One might argue -- this is up to the user to fix. if Console /= null then if Default_Console /= null then Default_Console_Refed := True; Ref (Default_Console); end if; Set_Default_Console (Script, Console); end if; -- If we want to have sys.displayhook called, we should use -- as the filename, otherwise will ensure this is not -- an interactive session. -- For interactive code, python generates addition opcode PRINT_EXPR -- which will call displayhook. -- -- We cannot use Py_Eval_Input, although it would properly return the -- result of evaluating the expression, but it would not support multi -- line input, in particular function defintion. -- So we need to use Py_Single_Input, but then the result of evaluating -- the code is always None. if Need_Output then State := Py_Eval_Input; else State := Py_Single_Input; end if; if Hide_Output then Code := Py_CompileString (Cmd, "", State); else Code := Py_CompileString (Cmd, "", State); end if; -- If code compiled just fine if Code /= null and then not Indented_Input then Script.Use_Secondary_Prompt := False; Free (Script.Buffer); Script.Buffer := new String'(""); if Get_Default_Console (Script) /= null then Grab_Events (Get_Default_Console (Script), True); -- No exception handler needed because PyEval_EvalCode cannot -- raise an exception. Result := PyEval_EvalCode (Code, Script.Globals, Script.Globals); Grab_Events (Get_Default_Console (Script), False); else Result := PyEval_EvalCode (Code, Script.Globals, Script.Globals); end if; Py_XDECREF (PyObject (Code)); if Result = null then if Active (Me_Error) then PyErr_Fetch (Typ, Occurrence, Traceback); PyErr_NormalizeException (Typ, Occurrence, Traceback); S := PyObject_Repr (Occurrence); if S /= null then Trace (Me_Error, "Exception " & PyString_AsString (S)); Py_DECREF (S); else Trace (Me_Error, "Python raised an exception with no __repr__"); end if; -- Do not DECREF Typ, Occurrence or Traceback after this PyErr_Restore (Typ, Occurrence, Traceback); end if; if not Hide_Exceptions then PyErr_Print; else PyErr_Clear; end if; Errors.all := True; end if; -- Do we have compilation error because input was incomplete ? elsif not Hide_Output then Script.Use_Secondary_Prompt := Indented_Input; if not Script.Use_Secondary_Prompt then if PyErr.PyErr_Occurred /= null then PyErr_Fetch (Typ, Occurrence, Traceback); PyErr_NormalizeException (Typ, Occurrence, Traceback); if PyTuple_Check (Occurrence) then -- Old style exceptions S := PyTuple_GetItem (Occurrence, 0); else -- New style: occurrence is an instance -- S is null if the exception is not a syntax_error S := PyObject_GetAttrString (Occurrence, "msg"); end if; PyErr_Restore (Typ, Occurrence, Traceback); if S = null then Script.Use_Secondary_Prompt := False; else declare Msg : constant String := PyString_AsString (S); begin Py_DECREF (S); -- Second message appears when typing: -- >>> if 1: -- ... pass -- ... else: if Msg = "unexpected EOF while parsing" then Script.Use_Secondary_Prompt := Command'Length > 0 and then Command (Command'Last) = ':'; elsif Msg = "expected an indented block" then Script.Use_Secondary_Prompt := Command'Length /= 0 and then Command (Command'Last) /= ASCII.LF; else Log_Python_Exception; end if; end; end if; if not Script.Use_Secondary_Prompt then PyErr_Print; Errors.all := True; else PyErr_Clear; end if; end if; else PyErr_Clear; end if; Free (Script.Buffer); if Script.Use_Secondary_Prompt then Script.Buffer := new String'(Cmd); else Script.Buffer := new String'(""); end if; else if Active (Me_Error) then PyErr_Fetch (Typ, Occurrence, Traceback); PyErr_NormalizeException (Typ, Occurrence, Traceback); S := PyObject_Repr (Occurrence); if S /= null then Trace (Me_Error, "Exception " & PyString_AsString (S)); Py_DECREF (S); end if; PyErr_Restore (Typ, Occurrence, Traceback); end if; PyErr_Print; end if; if not Hide_Output then Display_Prompt (Script); end if; if Console /= null then Set_Default_Console (Script, Default_Console); if Default_Console_Refed then Unref (Default_Console); end if; end if; return Result; exception when E : others => Trace (Me_Error, E); Errors.all := True; if Default_Console_Refed then Unref (Default_Console); end if; return Result; end Run_Command; --------------------- -- Execute_Command -- --------------------- procedure Execute_Command (Script : access Python_Scripting_Record; CL : Arg_List; Console : Virtual_Console := null; Hide_Output : Boolean := False; Show_Command : Boolean := True; Errors : out Boolean) is E : aliased Boolean; Result : PyObject; begin if Script.Blocked then Errors := True; Insert_Error (Script, Console, "A command is already executing"); else declare Lock : PyState.Ada_GIL_Lock with Unreferenced; begin Result := Run_Command (Script, Get_Command (CL), Console => Console, Need_Output => False, Hide_Output => Hide_Output, Show_Command => Show_Command, Errors => E'Unchecked_Access); Py_XDECREF (Result); Errors := E; end; end if; end Execute_Command; --------------------- -- Execute_Command -- --------------------- function Execute_Command (Script : access Python_Scripting_Record; CL : Arg_List; Console : Virtual_Console := null; Hide_Output : Boolean := False; Show_Command : Boolean := True; Errors : access Boolean) return String is pragma Unreferenced (Show_Command); begin if Script.Blocked then Errors.all := True; Insert_Error (Script, Console, "A command is already executing"); return ""; else return Run_Command (Script, Get_Command (CL), Console => Console, Hide_Output => Hide_Output, Errors => Errors); end if; end Execute_Command; --------------------- -- Execute_Command -- --------------------- function Execute_Command (Script : access Python_Scripting_Record; CL : Arg_List; Console : Virtual_Console := null; Hide_Output : Boolean := False; Errors : access Boolean) return Boolean is Obj : PyObject; Result : Boolean; begin if Script.Blocked then Errors.all := True; Insert_Error (Script, Console, "A command is already executing"); return False; else declare Lock : PyState.Ada_GIL_Lock with Unreferenced; begin Obj := Run_Command (Script, Get_Command (CL), Need_Output => True, Console => Console, Hide_Output => Hide_Output, Errors => Errors); Result := Obj /= null and then ((PyInt_Check (Obj) and then PyInt_AsLong (Obj) = 1) or else (PyBool_Check (Obj) and then PyBool_Is_True (Obj)) or else (PyString_Check (Obj) and then PyString_AsString (Obj) = "true") or else (PyUnicode_Check (Obj) and then Unicode_AsString (Obj) = "true")); Py_XDECREF (Obj); end; return Result; end if; end Execute_Command; --------------------- -- Execute_Command -- --------------------- function Execute_Command (Script : access Python_Scripting_Record; Command : String; Args : Callback_Data'Class) return Boolean is Obj : PyObject; Errors : aliased Boolean; begin if Script.Blocked then return False; else declare Lock : PyState.Ada_GIL_Lock with Unreferenced; begin Obj := Run_Command (Script, Command => Command, Need_Output => True, Console => null, Errors => Errors'Unchecked_Access); end; if Obj /= null and then PyFunction_Check (Obj) then return Execute_Command (Script, Obj, Args, Errors'Access); else return False; end if; end if; end Execute_Command; --------------------- -- Execute_Command -- --------------------- function Execute_Command (Script : access Python_Scripting_Record'Class; Command : PyObject; Args : Callback_Data'Class; Error : access Boolean) return PyObject is Lock : PyState.Ada_GIL_Lock with Unreferenced; Obj : PyObject; Old, Args2, Item : PyObject; Size : Integer; begin Error.all := False; if Command = null then Trace (Me_Error, "Trying to execute 'null'"); return null; end if; if Active (Me_Log) then Obj := PyObject_Repr (Command); if Obj /= null then Trace (Me_Log, "Execute " & PyString_AsString (Obj)); Py_DECREF (Obj); end if; end if; if Script.Blocked then Error.all := True; Trace (Me_Error, "A python command is already executing"); return null; end if; -- If we are calling a bound method whose self is the same as the -- first parameter in Args, we remove the first parameter to avoid -- a duplicate. This allows registering callbacks as: -- class MyClass(object): -- def my_callback(self, arg1): -- pass -- def __init__(self): -- register_callback(self, self.my_callback) -- register_callback(self, MyClass.my_callback) -- If Ada calls the registered callback by passing the instance as -- the first parameter in the Callback_Data, both the calls above -- have the same effect when we remove the duplication. Otherwise, -- the first one will result in an error since my_callback will be -- called with three arguments (self, self, arg1). -- Note that the second call does not provide dynamic dispatching when -- MyClass is subclassed and my_callback overridden. Old := Python_Callback_Data (Args).Args; Size := PyTuple_Size (Old); if PyMethod_Check (Command) and then PyMethod_Self (Command) /= null and then Size > 0 and then PyMethod_Self (Command) = PyTuple_GetItem (Old, 0) then if Size = 1 then Args2 := Py_None; Py_INCREF (Args2); else Args2 := PyTuple_New (Size => Size - 1); for T in 1 .. Size - 1 loop -- Remove arg 0 Item := PyTuple_GetItem (Old, T); -- same refcount Py_INCREF (Item); PyTuple_SetItem (Args2, T - 1, Item); -- same refcount end loop; end if; else Args2 := Old; Py_INCREF (Args2); end if; Obj := PyObject_Call (Command, Args2, Python_Callback_Data (Args).Kw); Py_DECREF (Args2); if Obj = null then Error.all := True; Trace (Me_Error, "Calling object raised an exception"); Log_Python_Exception; PyErr_Print; end if; return Obj; exception when E : others => Trace (Me_Error, E, Error_Message_With_Stack); raise; end Execute_Command; --------------------- -- Execute_Command -- --------------------- function Execute_Command (Script : access Python_Scripting_Record'Class; Command : PyObject; Args : Callback_Data'Class; Error : access Boolean) return String is Lock : PyState.Ada_GIL_Lock with Unreferenced; Obj : constant PyObject := Execute_Command (Script, Command, Args, Error); begin if Obj /= null and then PyString_Check (Obj) then declare Str : constant String := PyString_AsString (Obj); begin Py_DECREF (Obj); return Str; end; elsif Obj /= null and then PyUnicode_Check (Obj) then declare Str : constant String := Unicode_AsString (Obj, "utf-8"); begin Py_DECREF (Obj); return Str; end; else if Obj /= null then Py_DECREF (Obj); else Error.all := True; end if; return ""; end if; end Execute_Command; --------------------- -- Execute_Command -- --------------------- function Execute_Command (Script : access Python_Scripting_Record'Class; Command : PyObject; Args : Callback_Data'Class; Error : access Boolean) return Any_Type is Obj : constant PyObject := Execute_Command (Script, Command, Args, Error); begin if Obj /= null then declare Any : constant Any_Type := GNATCOLL.Any_Types.Python.From_PyObject (Obj); begin Py_DECREF (Obj); return Any; end; else return Empty_Any_Type; end if; end Execute_Command; --------------------- -- Execute_Command -- --------------------- function Execute_Command (Script : access Python_Scripting_Record'Class; Command : PyObject; Args : Callback_Data'Class; Error : access Boolean) return Boolean is Lock : PyState.Ada_GIL_Lock with Unreferenced; Obj : constant PyObject := Execute_Command (Script, Command, Args, Error); Result : Boolean; begin if Obj = null then return False; else Result := ((PyInt_Check (Obj) and then PyInt_AsLong (Obj) = 1) or else (PyBool_Check (Obj) and then PyBool_Is_True (Obj)) or else (PyString_Check (Obj) and then PyString_AsString (Obj) = "true") or else (PyUnicode_Check (Obj) and then Unicode_AsString (Obj) = "true")); Py_DECREF (Obj); return Result; end if; end Execute_Command; ------------------ -- Execute_File -- ------------------ procedure Execute_File (Script : access Python_Scripting_Record; Filename : String; Console : Virtual_Console := null; Hide_Output : Boolean := False; Show_Command : Boolean := True; Errors : out Boolean) is begin Script.Current_File := To_Unbounded_String (Filename); -- Before executing a Python script, add its directory to sys.path. -- This is to mimic the behavior of the command-line shell, and -- allow the loaded script to "import" scripts in the same directory. declare D : constant String := +Create (+Filename).Dir_Name; -- Use Virtual_File as a reliable way to get the directory L : Natural := D'Last; begin -- Strip the ending '\' if any. if D /= "" and then D (L) = '\' then L := L - 1; end if; Execute_Command (Script, Create ("import sys;sys.path.insert(0, r'" & D (D'First .. L) & "')"), Console => null, Hide_Output => True, Show_Command => False, Errors => Errors); end; -- The call to compile is only necessary to get an error message -- pointing back to Filename Execute_Command (Script, Create ("exec(compile(open(r'" & Filename & "').read(),r'" & Filename & "','exec'))"), Console, Hide_Output, Show_Command, Errors); Script.Current_File := Null_Unbounded_String; end Execute_File; -------------- -- Get_Name -- -------------- function Get_Name (Script : access Python_Scripting_Record) return String is pragma Unreferenced (Script); begin return Python_Name; end Get_Name; ---------------- -- Get_Script -- ---------------- function Get_Script (Data : Python_Callback_Data) return Scripting_Language is begin return Scripting_Language (Data.Script); end Get_Script; -------------------- -- Get_Repository -- -------------------- function Get_Repository (Script : access Python_Scripting_Record) return Scripts_Repository is begin return Script.Repo; end Get_Repository; -------------------- -- Current_Script -- -------------------- function Current_Script (Script : access Python_Scripting_Record) return String is begin if Script.Current_File = Null_Unbounded_String then return ""; else return To_String (Script.Current_File); end if; end Current_Script; ------------------------- -- Number_Of_Arguments -- ------------------------- function Number_Of_Arguments (Data : Python_Callback_Data) return Natural is begin if Data.Kw /= null then return PyDict_Size (Data.Kw) + PyObject_Size (Data.Args); else return PyObject_Size (Data.Args); end if; end Number_Of_Arguments; --------------------- -- Name_Parameters -- --------------------- procedure Name_Parameters (Data : in out Python_Callback_Data; Params : Param_Array) is Lock : PyState.Ada_GIL_Lock with Unreferenced; First : Integer := 0; Old_Args : constant PyObject := Data.Args; Item : PyObject; Nargs : Natural := 0; -- Number of entries in Data.Args Nkeywords : Integer; -- Number of unhandled entries in Data.Kw begin if Data.Kw = null then return; end if; Nkeywords := PyDict_Size (Data.Kw); if Data.Args /= null then Nargs := PyObject_Size (Data.Args); end if; -- Modify Data.Args in place, so we need to resize it appropriately. -- Then, through a single loop, we fill it. if Data.First_Arg_Is_Self then First := 1; end if; Data.Args := PyTuple_New (Params'Length + First); if First > 0 then -- Copy "self" if Old_Args /= null then Item := PyObject_GetItem (Old_Args, 0); Py_DECREF (Item); else Item := PyDict_GetItemString (Data.Kw, "self"); if Item = null then First := 0; -- Unbound method ? end if; end if; if Item /= null then Py_INCREF (Item); PyTuple_SetItem (Data.Args, 0, Item); end if; end if; for N in Params'Range loop -- Do we have a corresponding keyword parameter ? Item := PyDict_GetItemString (Data.Kw, Params (N).Name.all); -- Item is a burrowed reference => need manual increase Py_XINCREF (Item); if Item /= null then Nkeywords := Nkeywords - 1; if N - Params'First + First < Nargs then Set_Error_Msg (Data, "Parameter cannot be both positional (" & Image (N - Params'First + 1 + First, 0) & Nargs'Img & Params'First'Img & ") and named: " & Params (N).Name.all); Py_DECREF (Old_Args); raise Invalid_Parameter; end if; elsif N - Params'First + First < Nargs then -- Get_Item is already incrementing the refcount Item := PyObject_GetItem (Old_Args, N - Params'First + First); else Item := Py_None; Py_INCREF (Item); end if; PyTuple_SetItem (Data.Args, N - Params'First + First, Item); end loop; Py_DECREF (Old_Args); -- Are there unused keyword arguments ? if Nkeywords > 0 then declare Pos : Integer := 0; Key, Value : PyObject; begin loop PyDict_Next (Data.Kw, Pos, Key, Value); exit when Pos = 1; declare K : constant String := PyString_AsString (Key); Found : Boolean := False; begin for N in Params'Range loop if Params (N).Name.all = K then Found := True; exit; end if; end loop; if not Found then Set_Error_Msg (Data, "Invalid keyword parameter: " & K); raise Invalid_Parameter with "Invalid keyword parameter " & K; end if; end; end loop; end; end if; -- Get rid of the old arguments Py_DECREF (Data.Kw); Data.Kw := null; end Name_Parameters; --------------------- -- Name_Parameters -- --------------------- procedure Name_Parameters (Data : in out Python_Callback_Data; Names : Cst_Argument_List) is function Convert is new Ada.Unchecked_Conversion (Cst_String_Access, GNAT.Strings.String_Access); Params : Param_Array (Names'Range); begin for N in Names'Range loop -- The conversion here is safe: Name_Parameters does not modify the -- string, nor does it try to free it Params (N) := (Name => Convert (Names (N)), Optional => True); end loop; Name_Parameters (Data, Params); end Name_Parameters; --------------- -- Get_Param -- --------------- function Get_Param (Data : Python_Callback_Data'Class; N : Positive) return PyObject is Obj : PyObject := null; begin if Data.Args /= null and then N <= PyObject_Size (Data.Args) then Obj := PyObject_GetItem (Data.Args, N - 1); end if; if Obj = null and then Data.Kw /= null then -- We haven't called Name_Parameters PyErr_SetString (Data.Script.Exception_Misc, "Keyword parameters not supported"); raise Invalid_Parameter; end if; if Obj = null or else Obj = Py_None then raise No_Such_Parameter with N'Img; end if; Py_DECREF (Obj); -- Return a borrowed reference return Obj; end Get_Param; --------------- -- Get_Param -- --------------- procedure Get_Param (Data : Python_Callback_Data'Class; N : Positive; Result : out PyObject; Success : out Boolean) is begin Result := null; if Data.Args /= null and then N <= PyObject_Size (Data.Args) then Result := PyObject_GetItem (Data.Args, N - 1); Py_DECREF (Result); -- We want to return a borrowed reference end if; if Result = null and then Data.Kw /= null then -- We haven't called Name_Parameters PyErr_SetString (Data.Script.Exception_Misc, "Keyword parameters not supported"); raise Invalid_Parameter; end if; Success := Result /= null and then Result /= Py_None; end Get_Param; ------------- -- Nth_Arg -- ------------- overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive) return List_Instance'Class is Lock : PyState.Ada_GIL_Lock with Unreferenced; Item : PyObject; Success : Boolean; List : Python_Callback_Data; Iter : PyObject; begin List.Script := Data.Script; List.First_Arg_Is_Self := False; Get_Param (Data, N, Item, Success); if not Success then List.Args := PyTuple_New (0); -- An empty list else Iter := PyObject_GetIter (Item); if Iter = null then raise Invalid_Parameter with "Parameter" & Integer'Image (N) & " should be iterable"; end if; if PyDict_Check (Item) then raise Invalid_Parameter with "Parameter" & Integer'Image (N) & " should not be dictionary"; end if; if PyAnySet_Check (Item) then raise Invalid_Parameter with "Parameter" & Integer'Image (N) & " should not be set"; end if; Py_DECREF (Iter); List.Args := Item; -- Item is a borrowed reference ? Py_INCREF (Item); -- so we just increase the refcount end if; return List; end Nth_Arg; ------------- -- Nth_Arg -- ------------- overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive) return Dictionary_Instance'Class is Lock : PyState.Ada_GIL_Lock with Unreferenced; Item : PyObject; Success : Boolean; Dictionary : Python_Dictionary_Instance; begin Dictionary.Script := Data.Script; Get_Param (Data, N, Item, Success); if not Success then Dictionary.Dict := PyDict_New; -- An empty dictionary else if not PyDict_Check (Item) then Raise_Exception (Invalid_Parameter'Identity, "Parameter" & Integer'Image (N) & " should be dictionary"); end if; Dictionary.Dict := Item; -- Item is a borrowed reference ? Py_INCREF (Item); -- so we just increase the refcount end if; return Dictionary; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive; Success : access Boolean) return String is Item : PyObject; begin Get_Param (Data, N, Item, Success.all); if not Success.all then return ""; end if; if PyString_Check (Item) then return PyString_AsString (Item); elsif PyUnicode_Check (Item) then return Unicode_AsString (Item, "utf-8"); else raise Invalid_Parameter with "Parameter" & Integer'Image (N) & " should be a string or unicode"; end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive; Success : access Boolean) return Unbounded_String is Item : PyObject; begin Get_Param (Data, N, Item, Success.all); if not Success.all then return Null_Unbounded_String; end if; return To_Unbounded_String (String'(Nth_Arg (Data, N, Success))); end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive; Success : access Boolean) return Integer is Item : PyObject; begin Get_Param (Data, N, Item, Success.all); if not Success.all then return 0; end if; if not PyInt_Check (Item) then raise Invalid_Parameter with "Parameter" & Integer'Image (N) & " should be an integer"; else return Integer (PyInt_AsLong (Item)); end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive; Success : access Boolean) return Float is Item : PyObject; begin Get_Param (Data, N, Item, Success.all); if not Success.all then return 0.0; end if; if not PyFloat_Check (Item) then if PyInt_Check (Item) then return Float (PyInt_AsLong (Item)); else raise Invalid_Parameter with "Parameter" & Integer'Image (N) & " should be a float"; end if; else return Float (PyFloat_AsDouble (Item)); end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive; Success : access Boolean) return Boolean is Item : PyObject; begin Get_Param (Data, N, Item, Success.all); if not Success.all then return False; end if; -- For backward compatibility, accept these as "False" values. -- Don't check for unicode here, which was never supported anyway. if PyString_Check (Item) and then (To_Lower (PyString_AsString (Item)) = "false" or else PyString_AsString (Item) = "0") then Insert_Text (Get_Script (Data), null, "Warning: using string 'false' instead of" & " boolean False is obsolescent"); return False; else -- Use standard python behavior return PyObject_IsTrue (Item); end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive; Success : access Boolean) return Subprogram_Type is Lock : PyState.Ada_GIL_Lock with Unreferenced; Item : PyObject; begin Get_Param (Data, N, Item, Success.all); if not Success.all then return null; end if; if Item /= null and then (PyFunction_Check (Item) or else PyMethod_Check (Item)) then Py_INCREF (Item); return new Python_Subprogram_Record' (Subprogram_Record with Script => Python_Scripting (Get_Script (Data)), Subprogram => Item); else raise Invalid_Parameter; end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive; Class : Class_Type; Allow_Null : Boolean; Success : access Boolean) return Class_Instance is Lock : PyState.Ada_GIL_Lock with Unreferenced; Item : PyObject; C : PyObject; Item_Class : PyObject; begin if Class /= Any_Class then C := Lookup_Object (Data.Script, Class.Qualified_Name.all); end if; Get_Param (Data, N, Item, Success.all); -- Item is a borrowed reference if not Success.all then return No_Class_Instance; end if; if Class /= Any_Class and then not PyObject_IsInstance (Item, C) then raise Invalid_Parameter with "Parameter" & Integer'Image (N) & " should be an instance of " & Get_Name (Class); end if; Item_Class := PyObject_GetAttrString (Item, "__class__"); -- Item_Class must be DECREF'd if Item_Class = null then raise Invalid_Parameter with "Parameter" & Integer'Image (N) & " should be an instance of " & Get_Name (Class) & " but has no __class__"; end if; Py_DECREF (Item_Class); return Get_CI (Python_Scripting (Get_Script (Data)), Item); exception when No_Such_Parameter => if Allow_Null then return No_Class_Instance; else raise; end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive) return String is Success : aliased Boolean; Result : constant String := Nth_Arg (Data, N, Success'Access); begin if not Success then raise No_Such_Parameter with N'Img; else return Result; end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive) return Unbounded_String is Success : aliased Boolean; Result : constant Unbounded_String := Nth_Arg (Data, N, Success'Access); begin if not Success then raise No_Such_Parameter with N'Img; else return Result; end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive) return Integer is Success : aliased Boolean; Result : constant Integer := Nth_Arg (Data, N, Success'Access); begin if not Success then raise No_Such_Parameter with N'Img; else return Result; end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive) return Float is Success : aliased Boolean; Result : constant Float := Nth_Arg (Data, N, Success'Access); begin if not Success then raise No_Such_Parameter with N'Img; else return Result; end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive) return Boolean is Success : aliased Boolean; Result : constant Boolean := Nth_Arg (Data, N, Success'Access); begin if not Success then raise No_Such_Parameter with N'Img; else return Result; end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive) return Subprogram_Type is Success : aliased Boolean; Result : constant Subprogram_Type := Nth_Arg (Data, N, Success'Access); begin if not Success then raise No_Such_Parameter with N'Img; else return Result; end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive; Class : Class_Type; Allow_Null : Boolean := False) return Class_Instance is Success : aliased Boolean; Result : constant Class_Instance := Nth_Arg (Data, N, Class, Allow_Null, Success'Access); begin if not Success then if Allow_Null then return No_Class_Instance; else raise No_Such_Parameter with N'Img; end if; else return Result; end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive; Default : String) return String is Success : aliased Boolean; Result : constant String := Nth_Arg (Data, N, Success'Access); begin if not Success then return Default; else return Result; end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive; Default : Integer) return Integer is Success : aliased Boolean; Result : constant Integer := Nth_Arg (Data, N, Success'Access); begin if not Success then return Default; else return Result; end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive; Default : Boolean) return Boolean is Success : aliased Boolean; Result : constant Boolean := Nth_Arg (Data, N, Success'Access); begin if not Success then return Default; else return Result; end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive; Class : Class_Type := Any_Class; Default : Class_Instance; Allow_Null : Boolean := False) return Class_Instance is Success : aliased Boolean; Result : constant Class_Instance := Nth_Arg (Data, N, Class, Allow_Null, Success'Access); begin if not Success then return Default; else return Result; end if; end Nth_Arg; ------------- -- Nth_Arg -- ------------- function Nth_Arg (Data : Python_Callback_Data; N : Positive; Default : Subprogram_Type) return Subprogram_Type is Success : aliased Boolean; Result : constant Subprogram_Type := Nth_Arg (Data, N, Success'Access); begin if not Success then return Default; else return Result; end if; end Nth_Arg; ------------------- -- Get_User_Data -- ------------------- overriding function Get_User_Data (Inst : not null access Python_Class_Instance_Record) return access User_Data_List is Item : PyObject := null; Data : PyObject; Tmp : PyObject_Data; Tmp_Addr : System.Address; begin if Lifecycle.Is_Finalized then return null; end if; declare Lock : PyState.Ada_GIL_Lock with Unreferenced; begin if PyObject_HasAttrString (Inst.Data, "__gps_data") then Item := PyObject_GetAttrString (Inst.Data, "__gps_data"); Tmp_Addr := PyC.PyCapsule_GetPointer (Item); Tmp := Convert (Tmp_Addr); return Tmp.Props'Access; else PyErr_Clear; -- error about "no such attribute" Tmp := new PyObject_Data_Record; Data := PyC.PyCapsule_New (Tmp.all'Address, On_PyObject_Data_Destroy'Access); if PyObject_SetAttrString (Inst.Data, "__gps_data", Data) /= 0 then Trace (Me, "Error creating __gps_data"); PyErr_Clear; Py_DECREF (Data); Unchecked_Free (Tmp); return null; end if; Py_DECREF (Data); return Tmp.Props'Access; end if; end; end Get_User_Data; ------------------------------ -- On_PyObject_Data_Destroy -- ------------------------------ procedure On_PyObject_Data_Destroy (Capsule : PyC.PyCapsule) is D : PyObject_Data := Convert (PyC.PyCapsule_GetPointer (Capsule)); begin Free_User_Data_List (D.Props); Unchecked_Free (D); end On_PyObject_Data_Destroy; --------------------------------- -- Unregister_Python_Scripting -- --------------------------------- procedure Unregister_Python_Scripting (Repo : access Scripts.Scripts_Repository_Record'Class) is Script : constant Scripting_Language := Lookup_Scripting_Language (Repo, Python_Name); begin if Script /= null then Destroy (Script); end if; end Unregister_Python_Scripting; ------------ -- Get_CI -- ------------ function Get_CI (Script : Python_Scripting; Object : PyObject) return Class_Instance is CI : Python_Class_Instance; Lock : PyState.Ada_GIL_Lock with Unreferenced; begin PyErr_Clear; -- If there was no instance, avoid a python exception later CI := new Python_Class_Instance_Record; CI.Script := Script; CI.Data := Object; -- adopts the object Py_INCREF (Object); -- the class_instance needs to own one ref (decref'ed in Free) return R : Class_Instance do CI_Pointers.Set (R.Ref, CI); end return; end Get_CI; ---------- -- Free -- ---------- overriding procedure Free (Self : in out Python_Class_Instance_Record) is begin if not Finalized then declare Lock : PyState.Ada_GIL_Lock with Unreferenced; begin Py_XDECREF (Self.Data); end; end if; end Free; ------------------ -- Get_PyObject -- ------------------ function Get_PyObject (Instance : Class_Instance) return PyObject is begin return Python_Class_Instance (Get_CIR (Instance)).Data; end Get_PyObject; ----------------- -- Is_Subclass -- ----------------- function Is_Subclass (Instance : access Python_Class_Instance_Record; Base : String) return Boolean is C, B : PyObject; Res : Boolean; begin if Instance.Data = null then raise Program_Error; end if; C := PyObject_GetAttrString (Instance.Data, "__class__"); B := Lookup_Object (Python_Scripting (Instance.Script), Base); Res := Py_IsSubclass (C, Base => B); Py_DECREF (C); return Res; end Is_Subclass; ------------------------ -- Setup_Return_Value -- ------------------------ procedure Setup_Return_Value (Data : in out Python_Callback_Data'Class) is begin Py_XDECREF (Data.Return_Value); Data.Has_Return_Value := True; Data.Return_As_List := False; Data.Return_Value := null; end Setup_Return_Value; ------------------- -- Set_Error_Msg -- ------------------- procedure Set_Error_Msg (Data : in out Python_Callback_Data; Msg : String) is begin Setup_Return_Value (Data); if Msg /= "" then PyErr_SetString (Data.Script.Exception_Misc, Msg); end if; end Set_Error_Msg; ----------------------- -- Prepare_Value_Key -- ----------------------- procedure Prepare_Value_Key (Data : in out Python_Callback_Data'Class; Key : PyObject; Append : Boolean) is Lock : PyState.Ada_GIL_Lock with Unreferenced; Obj, List : PyObject; Tmp : Integer; pragma Unreferenced (Tmp); Created_List : Boolean := False; begin if Data.Return_Dict = null then Data.Return_Dict := PyDict_New; end if; if Append then Obj := PyDict_GetItem (Data.Return_Dict, Key); if Obj /= null then if PyList_Check (Obj) then List := Obj; else List := PyList_New; Tmp := PyList_Append (List, Obj); Created_List := True; end if; Tmp := PyList_Append (List, Data.Return_Value); else List := Data.Return_Value; end if; else List := Data.Return_Value; end if; Tmp := PyDict_SetItem (Data.Return_Dict, Key, List); if Created_List then Py_XDECREF (Key); Py_DECREF (List); -- The only reference is now owned by the dictionary end if; -- Return_Value was either added to the value or directly to the -- dictionary. In both cases, its refcount was increased by one. Py_DECREF (Data.Return_Value); Data.Return_Value := Py_None; Py_INCREF (Data.Return_Value); Data.Return_As_List := False; end Prepare_Value_Key; -------------------------- -- Set_Return_Value_Key -- -------------------------- procedure Set_Return_Value_Key (Data : in out Python_Callback_Data; Key : Integer; Append : Boolean := False) is Lock : PyState.Ada_GIL_Lock with Unreferenced; K : constant PyObject := PyInt_FromLong (long (Key)); begin Prepare_Value_Key (Data, K, Append); Py_DECREF (K); end Set_Return_Value_Key; -------------------------- -- Set_Return_Value_Key -- -------------------------- procedure Set_Return_Value_Key (Data : in out Python_Callback_Data; Key : String; Append : Boolean := False) is Lock : PyState.Ada_GIL_Lock with Unreferenced; K : constant PyObject := PyString_FromString (Key); begin Prepare_Value_Key (Data, K, Append); Py_DECREF (K); end Set_Return_Value_Key; -------------------------- -- Set_Return_Value_Key -- -------------------------- procedure Set_Return_Value_Key (Data : in out Python_Callback_Data; Key : Class_Instance; Append : Boolean := False) is K : constant PyObject := Python_Class_Instance (Get_CIR (Key)).Data; begin Prepare_Value_Key (Data, K, Append); -- Do not decrease the reference counting here (even though the key has -- now one more reference owned by Data.Return_Dict), since a -- Class_Instance is refcounted as well, and will automatically decrease -- the reference counting when no longer in use -- Py_DECREF (K); end Set_Return_Value_Key; ------------------------------ -- Set_Return_Value_As_List -- ------------------------------ procedure Set_Return_Value_As_List (Data : in out Python_Callback_Data; Size : Natural := 0; Class : Class_Type := No_Class) is pragma Unreferenced (Size); Lock : PyState.Ada_GIL_Lock with Unreferenced; begin Setup_Return_Value (Data); Data.Return_As_List := True; Data.Has_Return_Value := True; if Class = No_Class then Data.Return_Value := PyList_New; else declare C : constant Class_Instance := New_Instance (Data.Script, Class); begin if C = No_Class_Instance then raise Program_Error; end if; Data.Return_Value := Python_Class_Instance (Get_CIR (C)).Data; Py_INCREF (Data.Return_Value); end; end if; end Set_Return_Value_As_List; ---------------------- -- Set_Return_Value -- ---------------------- procedure Set_Return_Value (Data : in out Python_Callback_Data; Value : PyObject) is Num : Integer; pragma Unreferenced (Num); Lock : PyState.Ada_GIL_Lock with Unreferenced; begin if Data.Return_As_List then Num := PyList_Append (Data.Return_Value, Value); else Setup_Return_Value (Data); Data.Return_Value := Value; Py_INCREF (Value); end if; end Set_Return_Value; ---------------------- -- Set_Return_Value -- ---------------------- procedure Set_Return_Value (Data : in out Python_Callback_Data; Value : Integer) is Lock : PyState.Ada_GIL_Lock with Unreferenced; Val : constant PyObject := PyInt_FromLong (long (Value)); begin Set_Return_Value (Data, Val); Py_DECREF (Val); end Set_Return_Value; ------------------------------ -- Set_Address_Return_Value -- ------------------------------ overriding procedure Set_Address_Return_Value (Data : in out Python_Callback_Data; Value : System.Address) is Lock : PyState.Ada_GIL_Lock with Unreferenced; Val : constant PyObject := PyInt_FromSize_t (size_t (To_Integer (Value))); begin Set_Return_Value (Data, Val); Py_DECREF (Val); end Set_Address_Return_Value; ---------------------- -- Set_Return_Value -- ---------------------- procedure Set_Return_Value (Data : in out Python_Callback_Data; Value : Float) is Lock : PyState.Ada_GIL_Lock with Unreferenced; Val : constant PyObject := PyFloat_FromDouble (double (Value)); begin Set_Return_Value (Data, Val); Py_DECREF (Val); end Set_Return_Value; ---------------------- -- Set_Return_Value -- ---------------------- procedure Set_Return_Value (Data : in out Python_Callback_Data; Value : String) is Lock : PyState.Ada_GIL_Lock with Unreferenced; Val : constant PyObject := PyString_FromString (Value); begin Set_Return_Value (Data, Val); Py_DECREF (Val); end Set_Return_Value; ---------------------- -- Set_Return_Value -- ---------------------- procedure Set_Return_Value (Data : in out Python_Callback_Data; Value : Boolean) is Lock : PyState.Ada_GIL_Lock with Unreferenced; Val : constant PyObject := PyBool_FromBoolean (Value); begin Set_Return_Value (Data, Val); Py_DECREF (Val); end Set_Return_Value; ---------------------- -- Set_Return_Value -- ---------------------- procedure Set_Return_Value (Data : in out Python_Callback_Data; Value : Class_Instance) is Lock : PyState.Ada_GIL_Lock with Unreferenced; V : constant Python_Class_Instance := Python_Class_Instance (Get_CIR (Value)); Obj : PyObject; Num : Integer; pragma Unreferenced (Num); begin if V /= null then Obj := V.Data; if Active (Me) then Assert (Me, V.Data /= null, "A Class_Instance has no PyObject"); end if; else Obj := Py_None; end if; if Data.Return_As_List then Num := PyList_Append (Data.Return_Value, Obj); else Py_INCREF (Obj); Setup_Return_Value (Data); Data.Return_Value := Obj; end if; end Set_Return_Value; ---------------------- -- Set_Return_Value -- ---------------------- procedure Set_Return_Value (Data : in out Python_Callback_Data; Value : List_Instance) is Lock : PyState.Ada_GIL_Lock with Unreferenced; V : constant PyObject := Python_Callback_Data (Value).Args; Num : Integer; pragma Unreferenced (Num); begin if Data.Return_As_List then Num := PyList_Append (Data.Return_Value, V); else Py_INCREF (V); Setup_Return_Value (Data); Data.Return_Value := V; end if; end Set_Return_Value; -------------- -- New_List -- -------------- overriding function New_List (Script : access Python_Scripting_Record; Class : Class_Type := No_Class) return List_Instance'Class is List : Python_Callback_Data; Lock : PyState.Ada_GIL_Lock with Unreferenced; begin List.Script := Python_Scripting (Script); List.First_Arg_Is_Self := False; if Class = No_Class then List.Args := PyList_New; else declare C : constant Class_Instance := New_Instance (Script, Class); begin if C = No_Class_Instance then raise Program_Error; end if; List.Args := Python_Class_Instance (Get_CIR (C)).Data; Py_INCREF (List.Args); end; end if; return List; end New_List; ------------------ -- New_Instance -- ------------------ function New_Instance (Script : access Python_Scripting_Record; Class : Class_Type) return Class_Instance is Klass : constant PyObject := Lookup_Object (Script, Class.Qualified_Name.all); Inst : Class_Instance; Obj : PyObject; Args : PyObject; begin if Klass = null then return No_Class_Instance; end if; -- Creating a new instance is equivalent to calling its metaclass. This -- is true for both new-style classes and old-style classes (for which -- the tp_call slot is set to PyInstance_New. -- Here, we are in fact calling Class.__new__ (cls, *args, **kwargs). -- After allocating memory, this in turns automatically tp_init in the -- type definition, which in the case of GNATCOLL cases is often set to -- slot_tp_init. The latter in turn calls __init__ -- -- ??? This API does not permit passing extra parameters to the call declare Lock : PyState.Ada_GIL_Lock with Unreferenced; begin Args := PyTuple_New (0); Script.Ignore_Constructor := True; Obj := PyObject_Call (Object => Klass, Args => Args, Kw => null); -- Py_None, which is not a valid dictionary Script.Ignore_Constructor := False; Py_DECREF (Args); if Obj = null then if Active (Me) then Trace (Me, "Could not create instance"); PyErr_Print; -- debugging only end if; return No_Class_Instance; end if; if Active (Me) then Assert (Me, Get_Refcount (Obj) = 1, "Object's refcount should be 1, got " & Get_Refcount (Obj)'Img, Raise_Exception => False); end if; Inst := Get_CI (Python_Scripting (Script), Obj); -- incr refcount Py_DECREF (Obj); -- The PyObject should have a single reference in the end, owned by -- the class instance itself. if Active (Me) then Assert (Me, Get_Refcount (Python_Class_Instance (Get_CIR (Inst)).Data) = 1, "New_Instance should own a single refcount of PyObject, got " & Print_Refcount (Get_CIR (Inst)), Raise_Exception => False); end if; end; return Inst; exception when others => Script.Ignore_Constructor := False; raise; end New_Instance; ---------------- -- Get_Method -- ---------------- overriding function Get_Method (Instance : access Python_Class_Instance_Record; Name : String) return Subprogram_Type is Inst : constant PyObject := Instance.Data; Lock : PyState.Ada_GIL_Lock with Unreferenced; Res : Subprogram_Type := null; begin declare Subp : constant PyObject := PyObject_GetAttrString (Inst, Name => Name); begin if Subp = null then -- Clear the raised python exception PyErr_Clear; else Res := new Python_Subprogram_Record' (Script => Python_Scripting (Instance.Script), Subprogram => Subp); end if; end; return Res; end Get_Method; -------------------- -- Print_Refcount -- -------------------- function Print_Refcount (Instance : access Python_Class_Instance_Record) return String is begin if Instance.Data /= null then return Print_Refcount (Class_Instance_Record (Instance.all)'Access) & " Py=" & Value (Refcount_Msg (Instance.Data)); else return Print_Refcount (Class_Instance_Record (Instance.all)'Access) & " Py="; end if; end Print_Refcount; ------------- -- Execute -- ------------- overriding function Execute (Subprogram : access Python_Subprogram_Record; Args : Callback_Data'Class; Error : not null access Boolean) return Boolean is begin return Execute_Command (Script => Subprogram.Script, Command => Subprogram.Subprogram, Args => Args, Error => Error); end Execute; ------------- -- Execute -- ------------- overriding function Execute (Subprogram : access Python_Subprogram_Record; Args : Callback_Data'Class; Error : not null access Boolean) return String is begin return Execute_Command (Script => Subprogram.Script, Command => Subprogram.Subprogram, Args => Args, Error => Error); end Execute; ------------- -- Execute -- ------------- overriding function Execute (Subprogram : access Python_Subprogram_Record; Args : Callback_Data'Class; Error : not null access Boolean) return Class_Instance is Obj : PyObject; Inst : Class_Instance; begin Obj := Execute_Command (Script => Subprogram.Script, Command => Subprogram.Subprogram, Args => Args, Error => Error); if Obj = null then return No_Class_Instance; else Inst := Get_CI (Subprogram.Script, Obj); Py_DECREF (Obj); return Inst; end if; end Execute; ------------- -- Execute -- ------------- overriding function Execute (Subprogram : access Python_Subprogram_Record; Args : Callback_Data'Class; Error : not null access Boolean) return List_Instance'Class is Obj : PyObject; List : Python_Callback_Data; begin Obj := Execute_Command (Script => Subprogram.Script, Command => Subprogram.Subprogram, Args => Args, Error => Error); List.Script := Subprogram.Script; List.First_Arg_Is_Self := False; List.Args := Obj; -- now owns the reference to Obj return List; end Execute; ------------- -- Execute -- ------------- overriding function Execute (Subprogram : access Python_Subprogram_Record; Args : Callback_Data'Class; Error : not null access Boolean) return Any_Type is begin return Execute_Command (Script => Subprogram.Script, Command => Subprogram.Subprogram, Args => Args, Error => Error); end Execute; ------------- -- Execute -- ------------- function Execute (Subprogram : access Python_Subprogram_Record; Args : Callback_Data'Class; Error : not null access Boolean) return GNAT.Strings.String_List is Lock : PyState.Ada_GIL_Lock with Unreferenced; Obj : constant PyObject := Execute_Command (Script => Subprogram.Script, Command => Subprogram.Subprogram, Args => Args, Error => Error); begin if Obj = null then return (1 .. 0 => null); elsif Obj = Py_None then Py_DECREF (Obj); return (1 .. 0 => null); elsif PyString_Check (Obj) then declare Str : constant String := PyString_AsString (Obj); begin Py_DECREF (Obj); return (1 .. 1 => new String'(Str)); end; elsif PyUnicode_Check (Obj) then declare Str : constant String := Unicode_AsString (Obj); begin Py_DECREF (Obj); return (1 .. 1 => new String'(Str)); end; elsif PyList_Check (Obj) then declare Result : GNAT.Strings.String_List (1 .. PyList_Size (Obj)); Item : PyObject; begin for J in 0 .. PyList_Size (Obj) - 1 loop Item := PyList_GetItem (Obj, J); if PyString_Check (Item) then Result (J + 1) := new String'(PyString_AsString (Item)); elsif PyUnicode_Check (Item) then Result (J + 1) := new String'(Unicode_AsString (Item)); end if; end loop; Py_DECREF (Obj); return Result; end; end if; Py_DECREF (Obj); return (1 .. 0 => null); end Execute; ---------- -- Free -- ---------- procedure Free (Subprogram : in out Python_Subprogram_Record) is begin if not Finalized then declare Lock : PyState.Ada_GIL_Lock with Unreferenced; begin Py_DECREF (Subprogram.Subprogram); end; end if; end Free; -------------- -- Get_Name -- -------------- function Get_Name (Subprogram : access Python_Subprogram_Record) return String is Lock : PyState.Ada_GIL_Lock with Unreferenced; S : constant PyObject := PyObject_Str (Subprogram.Subprogram); Name : constant String := PyString_AsString (S); begin Py_DECREF (S); return Name; end Get_Name; ---------------- -- Get_Script -- ---------------- function Get_Script (Subprogram : Python_Subprogram_Record) return Scripting_Language is begin return Scripting_Language (Subprogram.Script); end Get_Script; ------------------------- -- Set_Default_Console -- ------------------------- procedure Set_Default_Console (Script : access Python_Scripting_Record; Console : Virtual_Console) is Inst : Class_Instance; Cons : PyObject := Py_None; Errors : aliased Boolean; begin Set_Default_Console (Scripting_Language_Record (Script.all)'Access, Console); if Console /= null and then Get_Console_Class (Get_Repository (Script)) /= No_Class then Inst := Get_Instance (Script, Console); if Inst = No_Class_Instance then Inst := New_Instance (Script, Get_Console_Class (Get_Repository (Script))); Set_Data (Inst, Console => Console); end if; Cons := Python_Class_Instance (Get_CIR (Inst)).Data; PyDict_SetItemString (PyModule_GetDict (PyImport_ImportModule ("sys")), "stdout", Cons); PyDict_SetItemString (PyModule_GetDict (PyImport_ImportModule ("sys")), "stderr", Cons); PyDict_SetItemString (PyModule_GetDict (PyImport_ImportModule ("sys")), "stdin", Cons); else Cons := Run_Command (Script, "sys.stdout, sys.stdin, sys.stderr = " & "sys.__stdout__, sys.__stdin__, sys.__stderr__", Hide_Output => True, Need_Output => False, Errors => Errors'Access); Py_XDECREF (Cons); end if; end Set_Default_Console; ------------------ -- Set_Property -- ------------------ overriding procedure Set_Property (Instance : access Python_Class_Instance_Record; Name : String; Value : Integer) is Lock : PyState.Ada_GIL_Lock with Unreferenced; Val : PyObject; Result : Integer; pragma Unreferenced (Result); begin Val := PyInt_FromLong (long (Value)); Result := PyObject_GenericSetAttrString (Instance.Data, Name, Val); Py_DECREF (Val); end Set_Property; overriding procedure Set_Property (Instance : access Python_Class_Instance_Record; Name : String; Value : Float) is Lock : PyState.Ada_GIL_Lock with Unreferenced; Val : PyObject; Result : Integer; pragma Unreferenced (Result); begin Val := PyFloat_FromDouble (double (Value)); Result := PyObject_GenericSetAttrString (Instance.Data, Name, Val); Py_DECREF (Val); end Set_Property; overriding procedure Set_Property (Instance : access Python_Class_Instance_Record; Name : String; Value : Boolean) is Lock : PyState.Ada_GIL_Lock with Unreferenced; Val : PyObject; Result : Integer; pragma Unreferenced (Result); begin Val := PyBool_FromBoolean (Value); Result := PyObject_GenericSetAttrString (Instance.Data, Name, Val); Py_DECREF (Val); end Set_Property; overriding procedure Set_Property (Instance : access Python_Class_Instance_Record; Name : String; Value : String) is Lock : PyState.Ada_GIL_Lock with Unreferenced; Val : PyObject; Result : Integer; pragma Unreferenced (Result); begin Val := PyString_FromString (Value); Result := PyObject_GenericSetAttrString (Instance.Data, Name, Val); Py_DECREF (Val); end Set_Property; -------------------- -- Load_Directory -- -------------------- overriding procedure Load_Directory (Script : access Python_Scripting_Record; Directory : GNATCOLL.VFS.Virtual_File; To_Load : Script_Loader := Load_All'Access) is Files : File_Array_Access; Path : constant String := +Directory.Full_Name (True); Last : Integer := Path'Last; Errors : Boolean; begin if not Directory.Is_Directory then return; end if; Trace (Me, "Load python files from " & Path); -- Add the directory to the default python search path. -- Python requires no trailing dir separator (at least on Windows) if Is_Directory_Separator (Path (Last)) then Last := Last - 1; end if; Execute_Command (Script, Create ("sys.path=[r'" & Path (Path'First .. Last) & "']+sys.path"), Show_Command => False, Hide_Output => True, Errors => Errors); -- ??? Should also check for python modules (ie subdirectories that -- contain a __init__.py file Files := Directory.Read_Dir; -- Sort the files, to make the load order more stable than the -- filesystem order. Sort (Files.all); for J in Files'Range loop if Equal (Files (J).File_Extension, ".py") then if To_Load (Files (J)) then Trace (Me, "Load " & Files (J).Display_Full_Name); Execute_Command (Script, Create ("import " & (+Base_Name (Files (J), ".py"))), Show_Command => False, Hide_Output => True, Errors => Errors); end if; elsif Is_Regular_File (Create_From_Dir (Files (J), "__init__.py")) and then To_Load (Files (J)) then Trace (Me, "Load " & (+Base_Dir_Name (Files (J))) & "/"); Execute_Command (Script, Create ("import " & (+Base_Dir_Name (Files (J)))), Show_Command => False, Hide_Output => True, Errors => Errors); end if; end loop; Unchecked_Free (Files); end Load_Directory; ------------------------ -- Execute_Expression -- ------------------------ overriding procedure Execute_Expression (Result : in out Python_Callback_Data; Expression : String; Hide_Output : Boolean := True) is Script : constant Python_Scripting := Python_Scripting (Get_Script (Result)); Res : PyObject; Errors : aliased Boolean; begin if Script.Blocked then Set_Error_Msg (Result, "A command is already executing"); else Res := Run_Command (Script, Command => Expression, Hide_Output => Hide_Output, Hide_Exceptions => Hide_Output, Need_Output => True, Errors => Errors'Access); Setup_Return_Value (Result); if Errors then Py_XDECREF (Res); PyErr_Clear; raise Error_In_Command with "Error in '" & Expression & "()'"; else Result.Return_Value := Res; -- Adopts a reference end if; end if; end Execute_Expression; --------------------- -- Execute_Command -- --------------------- overriding procedure Execute_Command (Args : in out Python_Callback_Data; Command : String; Hide_Output : Boolean := True) is Script : constant Python_Scripting := Python_Scripting (Get_Script (Args)); Func : PyObject; Errors : aliased Boolean; Result : PyObject; begin if Script.Blocked then Set_Error_Msg (Args, "A command is already executing"); else declare Lock : PyState.Ada_GIL_Lock with Unreferenced; begin -- Fetch a handle on the function to execute. What we want to -- execute is: -- func = module.function_name -- func(args) Func := Run_Command (Script, Command => Command, Hide_Output => Hide_Output, Need_Output => True, Errors => Errors'Access); if Func /= null and then PyCallable_Check (Func) then Setup_Return_Value (Args); Result := Execute_Command (Script, Func, Args, Errors'Access); Py_DECREF (Func); if Errors then Py_XDECREF (Result); PyErr_Clear; raise Error_In_Command with "Error in '" & Command & "()'"; else Args.Return_Value := Result; -- Adopts a reference end if; else raise Error_In_Command with Command & " is not a function"; end if; end; end if; end Execute_Command; ------------------ -- Return_Value -- ------------------ overriding function Return_Value (Data : Python_Callback_Data) return String is begin if Data.Return_Value = null then raise Invalid_Parameter with "Returned value is null (a python exception ?)"; elsif PyString_Check (Data.Return_Value) then return PyString_AsString (Data.Return_Value); elsif PyUnicode_Check (Data.Return_Value) then return Unicode_AsString (Data.Return_Value); else raise Invalid_Parameter with "Returned value is not a string"; end if; end Return_Value; ------------------ -- Return_Value -- ------------------ overriding function Return_Value (Data : Python_Callback_Data) return Integer is begin if not PyInt_Check (Data.Return_Value) then raise Invalid_Parameter with "Returned value is not an integer"; else return Integer (PyInt_AsLong (Data.Return_Value)); end if; end Return_Value; ------------------ -- Return_Value -- ------------------ overriding function Return_Value (Data : Python_Callback_Data) return Float is begin if not PyFloat_Check (Data.Return_Value) then raise Invalid_Parameter with "Returned value is not a float"; else return Float (PyFloat_AsDouble (Data.Return_Value)); end if; end Return_Value; ------------------ -- Return_Value -- ------------------ overriding function Return_Value (Data : Python_Callback_Data) return Boolean is begin return PyObject_IsTrue (Data.Return_Value); end Return_Value; ------------------ -- Return_Value -- ------------------ overriding function Return_Value (Data : Python_Callback_Data) return Class_Instance is begin if Data.Return_Value = Py_None then return No_Class_Instance; else return Get_CI (Python_Scripting (Get_Script (Data)), Data.Return_Value); end if; end Return_Value; ------------------ -- Return_Value -- ------------------ overriding function Return_Value (Data : Python_Callback_Data) return List_Instance'Class is List : Python_Callback_Data; Iter : PyObject; Lock : PyState.Ada_GIL_Lock with Unreferenced; begin List.Script := Data.Script; List.First_Arg_Is_Self := False; Iter := PyObject_GetIter (Data.Return_Value); if Iter = null then raise Invalid_Parameter with "Return value is not an iterable"; end if; Py_DECREF (Iter); List.Args := Data.Return_Value; Py_INCREF (List.Args); return List; end Return_Value; -------------- -- Iterator -- -------------- function Iterator (Self : Python_Dictionary_Instance) return Dictionary_Iterator'Class is begin return Python_Dictionary_Iterator' (Script => Self.Script, Dict => Self.Dict, Position => 0, Key => null, Value => null); end Iterator; ---------- -- Next -- ---------- function Next (Self : not null access Python_Dictionary_Iterator) return Boolean is begin if Self.Position /= -1 then PyDict_Next (Self.Dict, Self.Position, Self.Key, Self.Value); end if; return Self.Position /= -1; end Next; ------------- -- Has_Key -- ------------- function Has_Key (Self : Python_Dictionary_Instance; Key : String) return Boolean is Lock : PyState.Ada_GIL_Lock with Unreferenced; K : constant PyObject := PyString_FromString (Key); begin return Result : constant Boolean := PyDict_Contains (Self.Dict, K) do Py_DECREF (K); end return; end Has_Key; ------------- -- Has_Key -- ------------- function Has_Key (Self : Python_Dictionary_Instance; Key : Integer) return Boolean is Lock : PyState.Ada_GIL_Lock with Unreferenced; K : constant PyObject := PyInt_FromLong (Interfaces.C.long (Key)); begin return Result : constant Boolean := PyDict_Contains (Self.Dict, K) do Py_DECREF (K); end return; end Has_Key; ------------- -- Has_Key -- ------------- function Has_Key (Self : Python_Dictionary_Instance; Key : Float) return Boolean is Lock : PyState.Ada_GIL_Lock with Unreferenced; K : constant PyObject := PyFloat_FromDouble (Interfaces.C.double (Key)); begin return Result : constant Boolean := PyDict_Contains (Self.Dict, K) do Py_DECREF (K); end return; end Has_Key; ------------- -- Has_Key -- ------------- function Has_Key (Self : Python_Dictionary_Instance; Key : Boolean) return Boolean is Lock : PyState.Ada_GIL_Lock with Unreferenced; K : constant PyObject := PyBool_FromBoolean (Key); begin return Result : constant Boolean := PyDict_Contains (Self.Dict, K) do Py_DECREF (K); end return; end Has_Key; -------------------- -- Conditional_To -- -------------------- function Conditional_To (Condition : Boolean; Object : PyObject; Name : String) return String is begin if not Condition or else Object = null or else Object = Py_None then return ""; end if; if PyString_Check (Object) then return PyString_AsString (Object); elsif PyUnicode_Check (Object) then return Unicode_AsString (Object, "utf-8"); else raise Invalid_Parameter with Name & " should be a string or unicode"; end if; end Conditional_To; -------------------- -- Conditional_To -- -------------------- function Conditional_To (Condition : Boolean; Object : PyObject; Name : String) return Integer is begin if not Condition or else Object = null or else Object = Py_None then return 0; end if; if PyInt_Check (Object) then return Integer (PyInt_AsLong (Object)); else raise Invalid_Parameter with Name & " should be an integer"; end if; end Conditional_To; -------------------- -- Conditional_To -- -------------------- function Conditional_To (Condition : Boolean; Object : PyObject; Name : String) return Float is begin if not Condition or else Object = null or else Object = Py_None then return 0.0; end if; if not PyFloat_Check (Object) then if PyInt_Check (Object) then return Float (PyInt_AsLong (Object)); else raise Invalid_Parameter with Name & " should be a float"; end if; else return Float (PyFloat_AsDouble (Object)); end if; end Conditional_To; -------------------- -- Conditional_To -- -------------------- function Conditional_To (Condition : Boolean; Script : Scripting_Language; Object : PyObject) return Boolean is begin if not Condition or else Object = null or else Object = Py_None then return False; end if; -- For backward compatibility, accept these as "False" values. -- Don't check for unicode here, which was never supported anyway. if PyString_Check (Object) and then (To_Lower (PyString_AsString (Object)) = "false" or else PyString_AsString (Object) = "0") then Insert_Text (Script, null, "Warning: using string 'false' instead of" & " boolean False is obsolescent"); return False; else -- Use standard python behavior return PyObject_IsTrue (Object); end if; end Conditional_To; ----------------- -- Internal_To -- ----------------- function Internal_To (Object : PyObject; Name : String) return String is begin return Conditional_To (True, Object, Name); end Internal_To; ----------------- -- Internal_To -- ----------------- function Internal_To (Object : PyObject; Name : String) return Integer is begin return Conditional_To (True, Object, Name); end Internal_To; ----------------- -- Internal_To -- ----------------- function Internal_To (Object : PyObject; Name : String) return Float is begin return Conditional_To (True, Object, Name); end Internal_To; ----------------- -- Internal_To -- ----------------- function Internal_To (Script : Scripting_Language; Object : PyObject) return Boolean is begin return Conditional_To (True, Script, Object); end Internal_To; --------- -- Key -- --------- function Key (Self : Python_Dictionary_Iterator) return String is begin return Conditional_To (Self.Position /= -1, Self.Key, "Key"); end Key; --------- -- Key -- --------- function Key (Self : Python_Dictionary_Iterator) return Integer is begin return Conditional_To (Self.Position /= -1, Self.Key, "Key"); end Key; --------- -- Key -- --------- function Key (Self : Python_Dictionary_Iterator) return Float is begin return Conditional_To (Self.Position /= -1, Self.Key, "Key"); end Key; --------- -- Key -- --------- function Key (Self : Python_Dictionary_Iterator) return Boolean is begin return Conditional_To (Self.Position /= -1, Scripting_Language (Self.Script), Self.Key); end Key; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : String) return String is Lock : PyState.Ada_GIL_Lock with Unreferenced; K : constant PyObject := PyUnicode_FromString (Key); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (V, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : Integer) return String is Lock : PyState.Ada_GIL_Lock with Unreferenced; K : constant PyObject := PyInt_FromLong (Interfaces.C.long (Key)); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (V, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : Float) return String is Lock : PyState.Ada_GIL_Lock with Unreferenced; K : constant PyObject := PyFloat_FromDouble (Interfaces.C.double (Key)); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (V, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : Boolean) return String is Lock : PyState.Ada_GIL_Lock with Unreferenced; K : constant PyObject := PyBool_FromBoolean (Key); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (V, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : String) return Integer is Lock : PyState.Ada_GIL_Lock with Unreferenced; K : constant PyObject := PyUnicode_FromString (Key); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (V, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : Integer) return Integer is Lock : PyState.Ada_GIL_Lock with Unreferenced; K : constant PyObject := PyInt_FromLong (Interfaces.C.long (Key)); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (V, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : Float) return Integer is Lock : PyState.Ada_GIL_Lock with Unreferenced; K : constant PyObject := PyFloat_FromDouble (Interfaces.C.double (Key)); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (V, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : Boolean) return Integer is Lock : PyState.Ada_GIL_Lock with Unreferenced; K : constant PyObject := PyBool_FromBoolean (Key); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (V, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : String) return Float is Lock : PyState.Ada_GIL_Lock with Unreferenced; K : constant PyObject := PyUnicode_FromString (Key); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (V, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : Integer) return Float is Lock : PyState.Ada_GIL_Lock with Unreferenced; K : constant PyObject := PyInt_FromLong (Interfaces.C.long (Key)); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (V, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : Float) return Float is Lock : PyState.Ada_GIL_Lock with Unreferenced; K : constant PyObject := PyFloat_FromDouble (Interfaces.C.double (Key)); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (V, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : Boolean) return Float is Lock : PyState.Ada_GIL_Lock with Unreferenced; K : constant PyObject := PyBool_FromBoolean (Key); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (V, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : String) return Boolean is Lock : PyState.Ada_GIL_Lock with Unreferenced; K : constant PyObject := PyUnicode_FromString (Key); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (Scripting_Language (Self.Script), V); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : Integer) return Boolean is Lock : PyState.Ada_GIL_Lock with Unreferenced; K : constant PyObject := PyInt_FromLong (Interfaces.C.long (Key)); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (Scripting_Language (Self.Script), V); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : Float) return Boolean is Lock : PyState.Ada_GIL_Lock with Unreferenced; K : constant PyObject := PyFloat_FromDouble (Interfaces.C.double (Key)); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (Scripting_Language (Self.Script), V); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Instance; Key : Boolean) return Boolean is Lock : PyState.Ada_GIL_Lock with Unreferenced; K : constant PyObject := PyBool_FromBoolean (Key); V : constant PyObject := PyDict_GetItem (Self.Dict, K); begin Py_DECREF (K); return Internal_To (Scripting_Language (Self.Script), V); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Iterator) return String is begin return Conditional_To (Self.Position /= -1, Self.Value, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Iterator) return Integer is begin return Conditional_To (Self.Position /= -1, Self.Value, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Iterator) return Float is begin return Conditional_To (Self.Position /= -1, Self.Value, "Value"); end Value; ----------- -- Value -- ----------- function Value (Self : Python_Dictionary_Iterator) return Boolean is begin return Conditional_To (Self.Position /= -1, Scripting_Language (Self.Script), Self.Value); end Value; ------------------------- -- Begin_Allow_Threads -- ------------------------- function Begin_Allow_Threads return PyThreadState is begin return Eval.PyEval_SaveThread; end Begin_Allow_Threads; ------------------------- -- Begin_Allow_Threads -- ------------------------- procedure Begin_Allow_Threads is State : PyThreadState; pragma Unreferenced (State); begin State := Begin_Allow_Threads; end Begin_Allow_Threads; ----------------------- -- End_Allow_Threads -- ----------------------- procedure End_Allow_Threads (State : PyThreadState) is begin Eval.PyEval_RestoreThread (State); end End_Allow_Threads; --------------------------- -- Get_This_Thread_State -- --------------------------- function Get_This_Thread_State return PyThreadState is function PyGILState_GetThisThreadState return PyThreadState; pragma Import (C, PyGILState_GetThisThreadState, "ada_PyGILState_GetThisThreadState"); begin return PyGILState_GetThisThreadState; end Get_This_Thread_State; ------------------------- -- Ensure_Thread_State -- ------------------------- procedure Ensure_Thread_State is Ignored : PyState.PyGILState_STATE; pragma Unreferenced (Ignored); begin Ignored := PyState.PyGILState_Ensure; end Ensure_Thread_State; ---------------------- -- Python_Backtrace -- ---------------------- function Python_Backtrace return String is F : PyFrameObject := Last_Call_Frame; Aux : Ada.Strings.Unbounded.Unbounded_String; begin if F /= null then while F /= null loop declare Image : String := Integer'Image (PyFrame_GetLineNumber (F)); begin Image (Image'First) := ':'; Append (Aux, " " & PyString_AsString (PyCode_Get_Filename (PyFrame_Get_Code (F))) & Image & ASCII.LF); end; F := PyFrame_Get_Back (F); end loop; end if; return To_String (Aux); end Python_Backtrace; ------------------------------ -- Error_Message_With_Stack -- ------------------------------ function Error_Message_With_Stack return String is Aux : Ada.Strings.Unbounded.Unbounded_String; begin if Last_Call_Frame /= null then Append (Aux, "Unexpected exception: Python execution stack" & ASCII.LF); Append (Aux, Python_Backtrace); return To_String (Aux); else return "Unexpected exception: "; end if; end Error_Message_With_Stack; ----------------------- -- Trace_Python_Code -- ----------------------- function Trace_Python_Code (User_Arg : GNATCOLL.Python.PyObject; Frame : GNATCOLL.Python.PyFrameObject; Why : GNATCOLL.Python.Why_Trace_Func; Object : GNATCOLL.Python.PyObject) return Integer is pragma Unreferenced (User_Arg); pragma Unreferenced (Object); Lock : PyState.Ada_GIL_Lock with Unreferenced; begin if Why in PyTrace_Call | PyTrace_C_Call then if Last_Call_Frame /= null then Py_DECREF (PyObject (Last_Call_Frame)); end if; Last_Call_Frame := Frame; Py_INCREF (PyObject (Last_Call_Frame)); end if; return 0; end Trace_Python_Code; end GNATCOLL.Scripts.Python; gnatcoll-bindings-25.0.0/python3/gnatcoll-scripts-python.ads000066400000000000000000000513751464374334300241260ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2003-2022, 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 Ada_05; with Ada.Strings.Unbounded; with GNATCOLL.Python; use GNATCOLL.Python; with System; package GNATCOLL.Scripts.Python is Python_Name : constant String := "python"; procedure Register_Python_Scripting (Repo : access Scripts.Scripts_Repository_Record'Class; Module : String; Program_Name : String := "python"; Python_Home : String := ""); -- All commands and classes will be added in the specified module. -- -- Program_Name should be the name of the program registering Python -- scripting. The interpreter will resove run-time libraries relative to -- this executable. -- -- If Python_Home is non-empty, it will be used as home, and libraries will -- be searched for in /lib/python function Register_Python_Module_Scripting (Repo : access Scripts.Scripts_Repository_Record'Class; Module : String) return GNATCOLL.Python.PyObject; -- Create Python module with given name and return created object. It -- is intended to be used to export Python modules, and not by ordinary -- applications. procedure Unregister_Python_Scripting (Repo : access Scripts.Scripts_Repository_Record'Class); -- Mark the python scripting language as no longer valid. This should be -- called before your application exits, to prevent unwanted storage_error -- in the finalization of the application (since some class_instances might -- be automatically finalized after python itself was destroyed, otherwise) type Python_Scripting_Record is new Scripting_Language_Record with private; type Python_Scripting is access all Python_Scripting_Record'Class; pragma No_Strict_Aliasing (Python_Scripting); type Python_Callback_Data is new Callback_Data with private; function Get_Param (Data : Python_Callback_Data'Class; N : Positive) return PyObject; procedure Get_Param (Data : Python_Callback_Data'Class; N : Positive; Result : out PyObject; Success : out Boolean); -- Return the N-th command line parameter, taking into account the keywords -- if any. -- The returned value is a borrowed reference and must not be DECREF'd procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : PyObject); -- Sets the N-th command line parameter using a low-level PyObject. procedure Set_Return_Value (Data : in out Python_Callback_Data; Value : PyObject); -- Sets the return value using a low-level PyObject. -- The refcounting of Value is increased. function Run_Command (Script : access Python_Scripting_Record'Class; Command : String; Need_Output : Boolean; Console : Virtual_Console := null; Show_Command : Boolean := False; Hide_Output : Boolean := False; Hide_Exceptions : Boolean := False; Errors : access Boolean) return PyObject; -- Execute a command in the interpreter, and send its output to the -- console. Return its return value (which doesn't need to be Py_DECREF, -- since it is a borrowed reference). -- If Hide_Output is True, then nothing is printed on the console. If the -- command is incomplete and would require extra input (a secondary prompt -- in interactive mode), then it is not executed. -- Errors is set to True if there was an error executing the command or -- if the input was incomplete. -- -- If Need_Output is True, the result of Command will be returned -- (otherwise Py_None is returned). However, this also restricts what -- commands can be executed, since only expressions can be called (ie not -- function definitions or import statements, for instance). function Get_PyObject (Instance : Class_Instance) return PyObject; -- Returns the low level PyObject enclosed in a Python Class_Instance. -- You need to be absolutely sure that Instance is a Python Instance. -------------------------- -- Multitasking support -- -------------------------- -- Python itself is not task-safe. It uses a Global Interpreter Lock to -- make sure that a single thread is accessing it at any one time. However, -- to simulate parallelism, it will automatically release and re-acquire -- the lock every 100 or so opcode instructions, thus giving a chance to -- run to other threads. -- -- This has several implications on multitasking Ada programs that want to -- access python: -- - the tasks that do not need to access python do not need anything -- special and can be left as is. -- - other tasks must create a python-specific data structure associated -- with the task. This is done by Ensure_Thread_State below. -- -- In addition, whenever you want to access python, you need to first -- acquire the Global Interpreter Lock (which can conveniently be done -- through Ensure_Thread_Safe). You should then release it when you are -- done manipulating python data structures, through a call to -- Begin_Allow_Threads. As such, a typical Ada program would look like: -- -- Register_Python_Scripting (...); -- Begin_Allow_Threads; -- -- and then in all tasks that access python: -- -- Ensure_Thread_State; -- ... python commands -- Begin_Allow_Threads; -- -- Input-Output and multi-tasking -- ------------------------------ -- -- In a multi-tasking application, it is recommended that you always call -- the various Execute_Command subprograms with Hide_Output=>False. -- Otherwise, there might be some confusion where a thread disabled the -- output (which is done by redirecting sys.stdout) but the next one -- puts its back, and thus the output of the first thread is visible in -- the end. This also seems to avoid some errors in the python interpreter -- itself. function Begin_Allow_Threads return PyThreadState; procedure Begin_Allow_Threads; -- Allow other python threads to run (for instance because we are blocked -- in a system call or in a section of code that doesn't need to execute -- python commands). This also releases the Global Interpreter Lock. procedure End_Allow_Threads (State : PyThreadState); -- Acquires the Global Interpreter Lock, and make State the current -- python thread. It must correspond to the current system thread. function Get_This_Thread_State return PyThreadState; -- Return the python thread state corresponding to the current -- system thread (hopefully this is also the current python thread, -- but there is no guarantee) procedure Ensure_Thread_State; -- Make sure that the current system thread has an equivalent python -- thread state. This should be called for all tasks created in Ada and -- that need to access python commands. -- This also makes sure that the current python thread state matches the -- system thread (so basically lets python know that a different thread -- is running). -- Finally, this acquires the Global Interpreter Lock (it runs the -- equivalent of End_Allow_Threads) function Python_Backtrace return String; -- Return current traceback of execution of the Python code. private ---------------------- -- Python_scripting -- ---------------------- type Python_Scripting_Record is new Scripting_Language_Record with record Repo : Scripts_Repository; Blocked : Boolean := False; Module : PyObject; Builtin : PyObject; Exception_Misc : PyObject; Exception_Missing_Args : PyObject; Exception_Invalid_Arg : PyObject; Exception_Unexpected : PyObject; Globals : PyObject; -- The global symbols for the python interpreter Use_Secondary_Prompt : Boolean := False; -- Which type of prompt should be displayed Buffer : GNAT.Strings.String_Access; -- Buffer for the command, to be added in front of any command before -- executing. This is used for multi-line input. Ignore_Constructor : Boolean := False; -- Whether we are creating a new instance of a class. -- This is used to disable the call to __init__ (for backward -- compatibility and because we wouldn't know how to pass extra -- arguments to New_Instance). In_Process : Boolean := False; -- True while we are processing a command. This is used to control the -- behavior of control-c: either interrupt, or copy. Current_File : Ada.Strings.Unbounded.Unbounded_String; -- The script we are currently executing end record; overriding function Command_Line_Treatment (Script : access Python_Scripting_Record) return Command_Line_Mode; overriding procedure Destroy (Script : access Python_Scripting_Record); overriding procedure Block_Commands (Script : access Python_Scripting_Record; Block : Boolean); overriding procedure Register_Command (Script : access Python_Scripting_Record; Cmd : Command_Descr_Access); overriding procedure Register_Property (Script : access Python_Scripting_Record; Prop : Property_Descr_Access); overriding procedure Register_Class (Script : access Python_Scripting_Record; Name : String; Base : Class_Type := No_Class; Module : Module_Type := Default_Module); overriding function Create (Script : access Python_Scripting_Record; Arguments_Count : Natural) return Callback_Data'Class; overriding function New_Instance (Script : access Python_Scripting_Record; Class : Class_Type) return Class_Instance; overriding procedure Execute_Command (Script : access Python_Scripting_Record; CL : Arg_List; Console : Virtual_Console := null; Hide_Output : Boolean := False; Show_Command : Boolean := True; Errors : out Boolean); overriding function Execute_Command (Script : access Python_Scripting_Record; CL : Arg_List; Console : Virtual_Console := null; Hide_Output : Boolean := False; Show_Command : Boolean := True; Errors : access Boolean) return String; overriding function Execute_Command (Script : access Python_Scripting_Record; CL : Arg_List; Console : Virtual_Console := null; Hide_Output : Boolean := False; Errors : access Boolean) return Boolean; overriding function Execute_Command (Script : access Python_Scripting_Record; Command : String; Args : Callback_Data'Class) return Boolean; function Execute_Command (Script : access Python_Scripting_Record'Class; Command : PyObject; Args : Callback_Data'Class; Error : access Boolean) return String; function Execute_Command (Script : access Python_Scripting_Record'Class; Command : PyObject; Args : Callback_Data'Class; Error : access Boolean) return Any_Type; function Execute_Command (Script : access Python_Scripting_Record'Class; Command : PyObject; Args : Callback_Data'Class; Error : access Boolean) return PyObject; -- Need to unref the returned value function Execute_Command (Script : access Python_Scripting_Record'Class; Command : PyObject; Args : Callback_Data'Class; Error : access Boolean) return Boolean; overriding procedure Load_Directory (Script : access Python_Scripting_Record; Directory : GNATCOLL.VFS.Virtual_File; To_Load : Script_Loader := Load_All'Access); overriding procedure Execute_File (Script : access Python_Scripting_Record; Filename : String; Console : Virtual_Console := null; Hide_Output : Boolean := False; Show_Command : Boolean := True; Errors : out Boolean); overriding function Get_Name (Script : access Python_Scripting_Record) return String; overriding function Get_Repository (Script : access Python_Scripting_Record) return Scripts_Repository; overriding function Current_Script (Script : access Python_Scripting_Record) return String; overriding procedure Set_Default_Console (Script : access Python_Scripting_Record; Console : Virtual_Console); overriding procedure Display_Prompt (Script : access Python_Scripting_Record; Console : Virtual_Console := null); overriding function Get_Prompt (Script : access Python_Scripting_Record) return String; overriding function Interrupt (Script : access Python_Scripting_Record) return Boolean; overriding procedure Complete (Script : access Python_Scripting_Record; Input : String; Completions : out String_Lists.List); overriding function New_List (Script : access Python_Scripting_Record; Class : Class_Type := No_Class) return List_Instance'Class; -- See doc from inherited subprograms type Python_Callback_Data is new Callback_Data with record Script : Python_Scripting; Args, Kw : PyObject; -- Args is a tuple, a list, or any iterable. -- These are the arguments passed by python. If Name_Parameters was -- called, these are modified in place: Kw is reset to null, and its -- contents merged into Args. Args is resized appropriately (to the -- number of arguments passed to Name_Parameters). This cannot be used -- for functions with a variable number of parameters. Return_Value : PyObject; Return_Dict : PyObject; Has_Return_Value : Boolean := False; Return_As_List : Boolean := False; First_Arg_Is_Self : Boolean; -- True if the first argument is "self", ie we are calling a method end record; overriding function Clone (Data : Python_Callback_Data) return Callback_Data'Class; overriding function Get_Script (Data : Python_Callback_Data) return Scripting_Language; overriding function Number_Of_Arguments (Data : Python_Callback_Data) return Natural; overriding procedure Name_Parameters (Data : in out Python_Callback_Data; Names : Cst_Argument_List); overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive) return String; overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive) return Unbounded_String; overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive) return Integer; overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive) return Float; overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive) return Boolean; overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive) return Subprogram_Type; overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive; Class : Class_Type; Allow_Null : Boolean := False) return Class_Instance; overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive; Default : String) return String; overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive; Default : Integer) return Integer; overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive; Default : Boolean) return Boolean; overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive; Class : Class_Type := Any_Class; Default : Class_Instance; Allow_Null : Boolean := False) return Class_Instance; overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive; Default : Subprogram_Type) return Subprogram_Type; overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive) return List_Instance'Class; overriding function Nth_Arg (Data : Python_Callback_Data; N : Positive) return Dictionary_Instance'Class; overriding procedure Set_Error_Msg (Data : in out Python_Callback_Data; Msg : String); overriding procedure Set_Return_Value_As_List (Data : in out Python_Callback_Data; Size : Natural := 0; Class : Class_Type := No_Class); overriding procedure Set_Return_Value (Data : in out Python_Callback_Data; Value : Integer); overriding procedure Set_Return_Value (Data : in out Python_Callback_Data; Value : Float); overriding procedure Set_Return_Value (Data : in out Python_Callback_Data; Value : String); overriding procedure Set_Return_Value (Data : in out Python_Callback_Data; Value : Boolean); overriding procedure Set_Return_Value (Data : in out Python_Callback_Data; Value : Class_Instance); overriding procedure Set_Return_Value (Data : in out Python_Callback_Data; Value : List_Instance); overriding procedure Set_Address_Return_Value (Data : in out Python_Callback_Data; Value : System.Address); overriding procedure Set_Return_Value_Key (Data : in out Python_Callback_Data; Key : String; Append : Boolean := False); overriding procedure Set_Return_Value_Key (Data : in out Python_Callback_Data; Key : Integer; Append : Boolean := False); overriding procedure Set_Return_Value_Key (Data : in out Python_Callback_Data; Key : Class_Instance; Append : Boolean := False); overriding procedure Free (Data : in out Python_Callback_Data); overriding procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : String); overriding procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : Integer); overriding procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : Float); overriding procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : Boolean); overriding procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : Class_Instance); overriding procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : List_Instance); overriding procedure Set_Nth_Arg (Data : in out Python_Callback_Data; N : Positive; Value : Subprogram_Type); overriding procedure Execute_Command (Args : in out Python_Callback_Data; Command : String; Hide_Output : Boolean := True); overriding function Return_Value (Data : Python_Callback_Data) return String; overriding function Return_Value (Data : Python_Callback_Data) return Integer; overriding function Return_Value (Data : Python_Callback_Data) return Float; overriding function Return_Value (Data : Python_Callback_Data) return Boolean; overriding function Return_Value (Data : Python_Callback_Data) return Class_Instance; overriding function Return_Value (Data : Python_Callback_Data) return List_Instance'Class; overriding procedure Execute_Expression (Result : in out Python_Callback_Data; Expression : String; Hide_Output : Boolean := True); -- See doc from inherited subprogram end GNATCOLL.Scripts.Python; gnatcoll-bindings-25.0.0/python3/gnatcoll_python.gpr000066400000000000000000000110551464374334300225330ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2015-2020, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with "gnatcoll_core"; library project GnatColl_Python is Version := External ("GNATCOLL_VERSION", "0.0"); Name := "gnatcoll_python3"; type Build_Type is ("DEBUG", "PROD"); Build : Build_Type := External ("GNATCOLL_BUILD_MODE", External ("BUILD", "PROD")); type Library_Type_Type is ("relocatable", "static", "static-pic"); Library_Type : Library_Type_Type := External ("LIBRARY_TYPE", "static"); Python_CFLAGS := External_As_List ("GNATCOLL_PYTHON_CFLAGS", " "); Python_Libs := External_As_List ("GNATCOLL_PYTHON_LIBS", " "); Python_Static_Lib := External("GNATCOLL_PYTHON_STATIC_LIB", ""); Libpython_Kind := External("GNATCOLL_LIBPYTHON_KIND", "shared"); for Source_Dirs use ("."); for Library_Kind use Library_Type; for Object_Dir use "obj/" & Project'Library_Kind; for Library_Dir use "lib/" & Project'Library_Kind; for Library_Name use Name; for Languages use ("Ada", "C"); case Library_Type is when "relocatable" => for Library_Version use "lib" & Name & Gnatcoll_Core.So_Ext & "." & Version; for Leading_Library_Options use External_As_List ("LDFLAGS", " "); case Libpython_Kind is when "shared" => for Library_Options use Python_Libs; end case; when others => null; end case; package Compiler is case Build is when "DEBUG" => for Switches ("Ada") use ("-g", "-O0", "-gnata", "-gnatVa", "-gnatQ", "-gnaty", "-gnateE", "-gnatwaCJe", "-fstack-check"); for Switches ("C") use ("-g", "-Wunreachable-code") & Python_CFLAGS; when "PROD" => -- Do not use -gnatwe for production mode for Switches ("Ada") use ("-O2", "-gnatn", "-gnatwaCJ"); for Switches ("C") use ("-O2", "-Wunreachable-code") & Python_CFLAGS; end case; for Switches ("Ada") use Compiler'Switches ("Ada") & External_As_List ("ADAFLAGS", " "); for Switches ("C") use Compiler'Switches ("C") & External_As_List ("CFLAGS", " ") & External_As_List ("CPPFLAGS", " "); end Compiler; package Binder is case Build is when "DEBUG" => for Switches ("Ada") use ("-E"); when "PROD" => null; end case; end Binder; package Builder is case Build is when "DEBUG" => for Global_Configuration_Pragmas use "../gnat_debug.adc"; when "PROD" => null; end case; end Builder; package Linker is case Libpython_Kind is when "shared" => for Linker_Options use Python_Libs; when others => for Linker_Options use (Python_Static_Lib) & Python_Libs; end case; end Linker; package Ide is for VCS_Kind use "Git"; end Ide; end GnatColl_Python; gnatcoll-bindings-25.0.0/python3/python_support.c000066400000000000000000000505521464374334300221030ustar00rootroot00000000000000/*---------------------------------------------------------------------------- -- G N A T C O L L -- -- -- -- Copyright (C) 2003-2022, 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 this software; see file -- -- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- -- of the license. -- ----------------------------------------------------------------------------*/ /* Force a value for the macro. It will only work for gcc, but otherwise * we cannot use the mingwin python with gcc on Windows*/ #define PY_LONG_LONG long long #include #include /* PyCodeObject definition in older versions*/ #include /* PyFrameObject definition */ #include /* On Windows and if we have HAVE_DECLSPEC_DLL defined remove the __declspec(dllexport) attribute from PyMODINIT_FUNC. Having such attribute to flag symbols to export from a DLL means that *only* those symbols are exported. */ #if _WIN32 #ifdef HAVE_DECLSPEC_DLL #undef PyMODINIT_FUNC #define PyMODINIT_FUNC PyObject* #endif #endif #undef DEBUG /* #define DEBUG */ #ifndef PyDescr_TYPE #define PyDescr_TYPE(x) (((PyDescrObject *)(x))->d_type) #define PyDescr_NAME(x) (((PyDescrObject *)(x))->d_name) #endif /***************************************************************************** * Modules *****************************************************************************/ PyMODINIT_FUNC ada_Py_InitModule4 (char *name, PyMethodDef *methods, char *doc, PyObject *self) { struct PyModuleDef def = { PyModuleDef_HEAD_INIT, name, /* m_name */ doc, /* m_doc */ -1, /* m_size */ methods, /* m_methods */ NULL, /* m_reload */ NULL, /* m_traverse */ NULL, /* m_clear */ NULL}; /* m_free */ struct PyModuleDef* module = (struct PyModuleDef*) malloc(sizeof(struct PyModuleDef)); PyObject* mod; memcpy(module, &def, sizeof(struct PyModuleDef)); mod = PyModule_Create(module); return mod; } // The definition of the module the user is creating via GNATCOLL. // There is a single such module, so it is simpler to declare the // variable as static rather than use calls to malloc(). static PyMethodDef user_methods[] = { {NULL, NULL} /* Sentinel */ }; static struct PyModuleDef user_module = { PyModuleDef_HEAD_INIT, NULL, /* m_name */ NULL, /* m_doc */ -1, /* m_size */ user_methods, /* m_methods */ NULL, /* m_reload */ NULL, /* m_traverse */ NULL, /* m_clear */ NULL /* m_free */ }; static char* user_module_name; PyMODINIT_FUNC init_user_module(void) { //struct PyModuleDef* module = (struct PyModuleDef*)malloc(sizeof(def)); //memcpy(module, &def, sizeof(struct PyModuleDef)); return PyModule_Create(&user_module); }; // To hide the output, we also need to rewrite displayhook. // Otherwise, calling a python function from Ada will print its // output to stdout (even though we have redirected sys.stdout ?) // So we make sure that nothing is ever printed. We cannot do this // systematically though, since in interactive mode (consoles...) // we still want the usual python behavior. PyObject* ada_py_initialize_and_module(char* program_name, char* name) { PyObject* module; PyObject* imported; user_module_name = strdup(name); user_module.m_name = user_module_name; Py_SetProgramName (Py_DecodeLocale (program_name, NULL)); PyStatus status; PyPreConfig preconfig; PyPreConfig_InitPythonConfig(&preconfig); preconfig.utf8_mode = 1; status = Py_PreInitialize(&preconfig); if (PyStatus_Exception(status)) { Py_ExitStatusException(status); } PyImport_AppendInittab(user_module_name, init_user_module); Py_InitializeEx(0); // Initialize the prompt if needed PyObject* prompt = PySys_GetObject ("ps1"); if (prompt == NULL) { prompt = PyUnicode_FromString (">>> "); PySys_SetObject ("ps1", prompt); Py_DECREF (prompt); } prompt = PySys_GetObject ("ps2"); if (prompt == NULL) { prompt = PyUnicode_FromString ("... "); PySys_SetObject ("ps2", prompt); Py_DECREF (prompt); } // Make the user's module visible to scripts. We cannot use // PyImport_ImportModule, which imports the module but doesn't add // it to the global dictionary and as such it is not visible to // user scripts. imported = PyImport_ImportModule(name); if (imported == NULL) { printf ("Could not import module %s", name); return NULL; } // Import 'sys', which is needed for instance in Set_Default_Console // to get access to the default value PyRun_SimpleString("import sys\n"); char* command = (char*)malloc(9 + strlen(name)); strcpy (command, "import "); strcat (command, name); strcat (command, "\n"); PyRun_SimpleString(command); free (command); return imported; }; /************************************************************************ * Methods * To implement methods, we have the following requirements: * - we need to support the notion of bound methods in python (where self * is set automatically by python to the instance that calls the method). * - we need to pass data back to Ada, that was set when the method was * declared. This data describes how the method is implemented in Ada. * The implementation is based on Python descriptors. However, none of the * predefined descriptors provides support for passing data back to Ada. * So we define our own descriptor, heavily based on the predefined one. * * From python, when you do a.foo(), the following occurs behind the scene: * - retrieves "A.foo", as a PyAdaMethodDescrObject * - since this is a descriptor, calls .__get__() to get the function * to execute. In practice, this calls adamethod_descr_get which * creates a bound method through PyMethod_New (bound to 'a') * - call that object. The implementation of classobject.c::method_call * adds self, ie 'a', as the first argument in the tuple of arguments, * then executes the wrapped function. Here, the wrapped function is * a PyCFunction that was created when the method was registered * initially, and that always calls back Ada but always passes the * same 'self' argument (the data Ada itself provided). ************************************************************************/ typedef struct { PyDescr_COMMON; PyObject *cfunc; // An instance of PyCFunction, bound with the // data that Ada needs, in the form of a PyCapsule. } PyAdaMethodDescrObject; PyTypeObject PyAdaMethodDescr_Type; int adamethod_descr_initialized = 0; static PyObject *adamethod_descr_call(PyAdaMethodDescrObject *descr, PyObject *arg, PyObject *kw) { return PyObject_Call((PyObject *)descr->cfunc, arg, kw);; } // Implementation of the __get__ descriptor method. The code is heavily // copied from descrobject.c::method_get. static PyObject * adamethod_descr_get (PyAdaMethodDescrObject *descr, PyObject *obj, PyObject *type) { PyObject *res; if (obj == NULL) { Py_INCREF(descr); return (PyObject*) descr; } if (!PyObject_TypeCheck(obj, PyDescr_TYPE(descr))) { PyErr_Format(PyExc_TypeError, "descriptor '%V' for '%s' objects " "doesn't apply to '%s' object", PyDescr_NAME(descr), "?", PyDescr_TYPE(descr)->tp_name, Py_TYPE(obj)->tp_name); return NULL; } return PyMethod_New (descr->cfunc, obj); } // Creates a new AdaMethod instance. 'method' is the description of the Ada // function to call, and 'data' is a PyCapsule that is passed to Ada as 'self'. PyObject * PyDescr_NewAdaMethod(PyTypeObject *type, PyObject* cfunc, const char* name) { if (!adamethod_descr_initialized) { adamethod_descr_initialized = 1; memcpy (&PyAdaMethodDescr_Type, &PyMethodDescr_Type, sizeof (PyTypeObject)); PyAdaMethodDescr_Type.tp_basicsize = sizeof(PyAdaMethodDescrObject); // cfunc is hidden inside the new descriptor use tp_descr_get and tp_call // to internally dispatch and call cfunc PyAdaMethodDescr_Type.tp_descr_get = (descrgetfunc)adamethod_descr_get; PyAdaMethodDescr_Type.tp_call = (ternaryfunc)adamethod_descr_call; PyAdaMethodDescr_Type.tp_flags = Py_TPFLAGS_DEFAULT && !(Py_TPFLAGS_HAVE_VECTORCALL); PyAdaMethodDescr_Type.tp_vectorcall = NULL; } PyAdaMethodDescrObject *descr = (PyAdaMethodDescrObject*) PyType_GenericAlloc (&PyAdaMethodDescr_Type, 0); if (descr != NULL) { Py_XINCREF(type); PyDescr_TYPE(descr) = type; PyDescr_NAME(descr) = PyUnicode_InternFromString(name); if (PyDescr_NAME(descr) == NULL) { Py_DECREF(descr); descr = NULL; } } if (descr != NULL) { descr->cfunc = cfunc; } return (PyObject *)descr; } // Adds a new method to the class 'class'. // 'module' is the module to which the class belongs, and is used to set // the __module__ attribute of the new method. // 'def' described the C function that will be called when the function is // executed in python. // 'data' is data to pass from C->Python->C (generally wrapped in a PyCapsule). // It will be pass as the "Self" argument to First_Level. void ada_py_add_method (PyMethodDef* def, PyObject* data, PyObject* class, PyObject* module) { PyObject* cfunc = PyCFunction_NewEx (def, data, PyUnicode_FromString (PyModule_GetName (module))); PyObject* method = PyDescr_NewAdaMethod ((PyTypeObject*)class, cfunc, def->ml_name); PyObject_SetAttrString (class, def->ml_name, method); Py_DECREF (method); }; /*****************************************************************************/ int ada_pyget_refcount (PyObject* obj) { return Py_REFCNT(obj); } char* ada_py_refcount_msg (PyObject* obj) { static char msg[200]; if (obj) { snprintf (msg, 199, "%p (%s, rc=%ld)", obj, Py_TYPE(obj)->tp_name, Py_REFCNT(obj)); } else { msg[0] = '\0'; } return msg; } void ada_py_print_refcount(PyObject* obj, char* msg) { if (obj) printf ("DEBUG %s %s\n", msg, ada_py_refcount_msg (obj)); } void ada_py_incref (PyObject* obj) { Py_INCREF (obj); #ifdef DEBUG ada_py_print_refcount (obj, "after incref"); #endif } void ada_py_decref (PyObject* obj) { #ifdef DEBUG ada_py_print_refcount (obj, "before decref"); #endif Py_DECREF (obj); } void ada_py_xincref (PyObject* obj) { Py_XINCREF (obj); #ifdef DEBUG ada_py_print_refcount (obj, "after xincref"); #endif } void ada_py_xdecref (PyObject* obj) { #ifdef DEBUG ada_py_print_refcount (obj, "before xdecref"); #endif Py_XDECREF (obj); } PyTypeObject* __gnatcoll_py_type(PyObject *obj) { return (PyTypeObject*) (Py_TYPE (obj)); } int ada_pybasestring_check (PyObject* obj) { return PyUnicode_Check (obj); } int ada_pystring_check (PyObject* obj) { return PyUnicode_Check (obj); } PyObject* ada_PyUnicode_AsEncodedString (PyObject *unicode, const char *encoding, const char *errors) { // A macro in python2. return PyUnicode_AsEncodedString (unicode, encoding, errors); } PyObject* ada_PyUnicode_FromString (const char *u) { // A macro in python2. return PyUnicode_FromString (u); } int ada_pyunicode_check (PyObject* obj) { return PyUnicode_Check (obj); } int ada_pyint_check (PyObject* obj) { // Not available anymore. return PyLong_Check (obj); } // May be a macro. PyAPI_FUNC(int) ada_pylong_check (PyObject* obj) { return PyLong_Check (obj); } int ada_pyfloat_check (PyObject* obj) { return PyFloat_Check (obj); } int ada_pybool_check (PyObject* obj) { #ifdef PyBool_Check return PyBool_Check (obj); #else return 0; #endif } int ada_pybool_is_true (PyObject* obj) { return PyObject_IsTrue (obj); } int ada_pydict_check (PyObject* obj) { return PyDict_Check (obj); } int ada_pyanyset_check (PyObject* obj) { return PyAnySet_Check (obj); } int ada_pyfunction_check (PyObject* obj) { return PyFunction_Check (obj); } PyObject* ada_pyfunction_get_globals (PyObject* obj) { return PyFunction_GET_GLOBALS (obj); } PyObject* ada_pyfunction_get_code (PyObject* obj) { return PyFunction_GET_CODE (obj); } PyObject* ada_pyfunction_get_closure (PyObject* obj) { return PyFunction_GET_CLOSURE (obj); } PyObject* ada_pyfunction_get_defaults (PyObject* obj) { return PyFunction_GET_DEFAULTS (obj); } PyObject* ada_PyEval_EvalCodeEx (PyCodeObject *co, PyObject *globals, PyObject *locals, PyObject *args, PyObject *kwds, PyObject *defs, PyObject *closure) { /* Code copied from funcobject.c::function_call() */ PyObject **k, **d; PyObject* result; PyObject* kwtuple; int nk, nd; if (defs != NULL && PyTuple_Check(defs)) { d = &PyTuple_GET_ITEM((PyTupleObject *)defs, 0); nd = PyTuple_Size(defs); } else { d = NULL; nd = 0; } if (kwds != NULL && PyDict_Check(kwds)) { int i = 0; Py_ssize_t pos = 0; nk = PyDict_Size(kwds); kwtuple = PyTuple_New(2*nk); if (kwtuple == NULL) return NULL; k = &PyTuple_GET_ITEM(kwtuple, 0); pos = i = 0; while (PyDict_Next(kwds, &pos, &k[i], &k[i+1])) { Py_INCREF(k[i]); Py_INCREF(k[i+1]); i += 2; } nk = i/2; } else { k = NULL; nk = 0; } result = (PyObject*) PyEval_EvalCodeEx ((PyObject*) co, globals, locals, &PyTuple_GET_ITEM (args, 0) /* args */, PyTuple_Size (args) /* argc*/, k /* kwds */, nk /* kwdc */, d /* defs */, nd /* defcount */, NULL, /* kwdefs */ closure /* closure */); Py_XDECREF (kwtuple); return result; } int ada_pycobject_check (PyObject* obj) { return PyCapsule_CheckExact (obj); } int ada_pytuple_check (PyObject* obj) { return PyTuple_Check (obj); } int ada_pylist_check (PyObject* obj) { return PyList_Check (obj); } int ada_pyiter_check (PyObject* obj) { return PyIter_Check (obj); } int ada_pymethod_check (PyObject* obj) { return PyMethod_Check (obj); } char* ada_tp_name (PyTypeObject* obj) { return (char *)obj->tp_name; } PyObject* ada_py_none () { return Py_None; } PyObject* ada_py_false() { return Py_False; } PyObject* ada_py_true() { return Py_True; } PyObject * ada_py_object_callmethod (PyObject *o, char *m) { return PyObject_CallMethod (o, m, ""); } PyObject * ada_py_object_callmethod_obj (PyObject *o, char *m, PyObject *arg) { return PyObject_CallMethod (o, m, "(O)", arg); } PyObject * ada_py_object_callmethod_int (PyObject *o, char *m, int arg) { return PyObject_CallMethod (o, m, "(i)", arg); } int ada_py_arg_parsetuple_ptr (PyObject *o, char *fmt, void *arg1) { return PyArg_ParseTuple (o, fmt, arg1); } int ada_py_arg_parsetuple_ptr2 (PyObject *o, char *fmt, void *arg1, void *arg2) { return PyArg_ParseTuple (o, fmt, arg1, arg2); } int ada_py_arg_parsetuple_ptr3 (PyObject *o, char *fmt, void *arg1, void * arg2, void *arg3) { return PyArg_ParseTuple (o, fmt, arg1, arg2, arg3); } int ada_py_arg_parsetuple_ptr4 (PyObject *o, char *fmt, void *arg1, void * arg2, void *arg3, void *arg4) { return PyArg_ParseTuple (o, fmt, arg1, arg2, arg3, arg4); } int ada_py_arg_parsetuple_ptr5 (PyObject *o, char *fmt, void *arg1, void * arg2, void *arg3, void *arg4, void *arg5) { return PyArg_ParseTuple (o, fmt, arg1, arg2, arg3, arg4, arg5); } extern int gnat_argc; extern char **gnat_argv; int __gnatcoll_py_main () { wchar_t *w_gnat_argv[gnat_argc]; int result; for (int i=0; iname = name; descr->get = get; descr->set = set; descr->doc = doc; descr->closure = closure; prop = PyDescr_NewGetSet (type, descr); if (prop == NULL) { return 0; } else { PyDict_SetItemString(type->tp_dict, name, prop); Py_DECREF (prop); return 1; } } PyThreadState* ada_PyGILState_GetThisThreadState() { #ifdef WITH_THREAD return PyGILState_GetThisThreadState(); #else return NULL; #endif } int ada_PyGILState_Ensure() { if (Py_IsInitialized ()) { #ifdef WITH_THREAD return (int)PyGILState_Ensure(); #else return 0; #endif } return 0; } void ada_PyGILState_Release(PyGILState_STATE state) { #ifdef WITH_THREAD if (Py_IsInitialized ()) { PyGILState_Release((PyGILState_STATE)state); } #endif } int ada_is_subclass (PyObject* class, PyObject* base) { if (!class || !base) { return -1; } else { return PyObject_IsSubclass (class, base); } } const char* ada_py_builtin() { return "builtins"; } const char* ada_py_builtins() { return "__builtins__"; } /* Result value must be freed */ PyAPI_FUNC(const char *) ada_PyString_AsString(PyObject * val) { PyObject* utf8 = PyUnicode_AsUTF8String(val); char* tmp = PyBytes_AsString (utf8); char* str = strdup (tmp); Py_XDECREF(utf8); return str; }; PyAPI_FUNC(PyObject *) PyInt_FromLong(long val) { return PyLong_FromLong(val); }; PyAPI_FUNC(PyObject *) PyInt_FromSize_t(size_t val) { return PyLong_FromSize_t(val); }; PyAPI_FUNC(long) PyInt_AsLong(PyObject * val) { return PyLong_AsLong(val); }; PyAPI_FUNC(PyObject *) PyString_FromStringAndSize( const char *val, Py_ssize_t s) { return PyUnicode_FromStringAndSize(val, s); }; PyAPI_FUNC(PyObject *) PyFile_FromString (const char *file_name, const char *mode) { PyObject * io = PyImport_ImportModule ("io"); if (io == NULL) { return NULL; } return PyObject_CallMethod (io, "open", "ss", file_name, mode); } PyCodeObject* ada_pyframe_get_code (PyFrameObject* obj) { #if PY_MAJOR_VERSION > 3 || (PY_MAJOR_VERSION == 3 && PY_MINOR_VERSION > 8) return PyFrame_GetCode(obj); #else return obj->f_code; #endif } PyFrameObject* ada_pyframe_get_back (PyFrameObject* obj) { #if PY_MAJOR_VERSION > 3 || (PY_MAJOR_VERSION == 3 && PY_MINOR_VERSION > 8) return PyFrame_GetBack(obj); #else return obj->f_back; #endif } PyObject* ada_pycode_get_filename (PyCodeObject* obj) { return obj->co_filename; } PyObject* ada_pycode_get_name (PyCodeObject* obj) { return obj->co_name; } gnatcoll-bindings-25.0.0/python3/setup.py000077500000000000000000000230001464374334300203230ustar00rootroot00000000000000#!/usr/bin/env python import logging import sys import re import os import json import shutil sys.path.append(os.path.dirname(os.path.dirname(os.path.abspath(__file__)))) from setup_support import SetupApp, Config PYTHON_DATA_SCRIPT = """ import json from sysconfig import get_config_vars, get_path, get_path_names if "platinclude" in get_path_names(): plat_include_key = "platinclude" else: plat_include_key = "include" result = {'config_vars': get_config_vars(), 'python_inc': get_path("include"), 'python_inc_plat': get_path(plat_include_key), 'prefix': get_path("data")} print(json.dumps(result)) """ def fetch_python_config(config): logging.info("Fetch Python information...") python_output = config.run( config.data["python_exec"], "-c", PYTHON_DATA_SCRIPT, grab=True ) python_data = json.loads(python_output) config_vars = python_data["config_vars"] python_version = config_vars["VERSION"] python_ldversion = config_vars.get("LDVERSION", python_version) logging.info(" %-24s %s", "Python version:", python_version) # Current python location current_prefix = python_data["prefix"] # Fetch prefix during the build process. Some paths of interest might # still reference a location used during the Python build process. build_prefix = ( [sys.prefix] + re.findall(r"'--prefix=([^']+)'", config_vars.get("CONFIG_ARGS", "")) )[-1] def relocate(path): if os.path.isabs(path): rel_path = os.path.relpath(path, build_prefix) if not rel_path.startswith(os.pardir): # If the input path is relative to the original build # directory, replace build prefix by the current one. return os.path.join(current_prefix, rel_path) else: # Otherwise, return it unchanged return path else: # The input path is relative so assume it's relative to the current # python prefix. return os.path.join(current_prefix, path) # Retrieve cflags, and linker flags static_dir = relocate(config_vars.get("LIBPL", "libs")) logging.info(" %-24s %s", "Static dir", static_dir) shared_dir = relocate(config_vars.get("LIBDIR", ".")) logging.info(" %-24s %s", "Shared dir", shared_dir) # Add first relocated include dirs followed by non-relocated version. # Indeed, when using venv and maybe virtualenv, includes are not copied. cflags = "-I" + relocate(python_data["python_inc"]) if python_data["python_inc"] != python_data["python_inc_plat"]: cflags += " -I" + relocate(python_data["python_inc_plat"]) cflags += " -I" + python_data["python_inc_plat"] cflags += " -I" + python_data["python_inc"] logging.info(" %-24s %s", "CFLAGS", cflags) if python_version.startswith("3"): # In python 3.x MODLIBS seems to drag in too many libraries python_libs = [ config_vars[v] for v in ("LIBS", "SYSLIBS") if v in config_vars and config_vars[v] ] else: python_libs = [ config_vars[v] for v in ("LIBS", "SYSLIBS", "MODLIBS") if v in config_vars and config_vars[v] ] python_libs = " ".join(python_libs) python_shared_libs = "-L%s -lpython%s %s" % ( shared_dir, python_ldversion, python_libs, ) python_static_libs = python_libs libpython_a = os.path.join( static_dir, config_vars.get("LIBRARY", "libpython%s.a" % python_version) ) if os.path.isfile(libpython_a): config.set_data("GNATCOLL_PYTHON_STATIC_LIB", libpython_a, sub="gprbuild") else: logging.info("static python library not found") if sys.platform.startswith("linux"): # On Linux platform, even when linking with the static libpython, # symbols not used by the application itself should be exported so # that shared library present in Python can use the Python C API. python_static_libs += " -export-dynamic" python_shared_libs += " -export-dynamic" logging.info(" %-24s %s", "Shared linker flags", python_shared_libs) logging.info(" %-24s %s", "Static linker flags", python_static_libs) # User does not have the choice between linking with static libpython # and shared libpython. If --enable-shared or --enable-framework was # passed to Python's configure during Python build, then we should # link with the shared libpython, otherwise with the static one. # Indeed otherwise some C modules might not work as expected or even # crash. On Windows always link with shared version of libpython # (if the static is present, this is just an indirection to the shared) if ( "--enable-shared" in config_vars.get("CONFIG_ARGS", "") or "--enable-framework" in config_vars.get("CONFIG_ARGS", "") or sys.platform.startswith("win") ): logging.info("Force link to shared python library") config.set_data("GNATCOLL_PYTHON_LIBS", python_shared_libs, sub="gprbuild") config.set_data("GNATCOLL_LIBPYTHON_KIND", "shared", sub="gprbuild") else: logging.info("Force link to static python library") config.set_data("GNATCOLL_PYTHON_LIBS", python_static_libs, sub="gprbuild") config.set_data("GNATCOLL_LIBPYTHON_KIND", "static", sub="gprbuild") config.set_data("GNATCOLL_PYTHON_CFLAGS", cflags, sub="gprbuild") class GNATCollPython(SetupApp): name = "gnatcoll_python" project = "gnatcoll_python.gpr" description = "GNATColl Python bindings" def create(self): super(GNATCollPython, self).create() self.build_cmd.add_argument( "--python-exec", help="set python executable location", metavar="PATH", default=sys.executable, ) self.build_cmd.add_argument( "--debug", help="build project in debug mode", action="store_true", default=False, ) def update_config(self, config, args): # Fetch python information config.set_data("python_exec", args.python_exec) fetch_python_config(config) logging.info( "%-26s %s", "Libraries kind", ", ".join(config.data["library_types"]) ) # Set library version with open( os.path.join(config.source_dir, "..", "version_information"), "r" ) as fd: version = fd.read().strip() config.set_data("GNATCOLL_VERSION", version, sub="gprbuild") logging.info("%-26s %s", "Version", version) # Set build mode config.set_data("BUILD", "DEBUG" if args.debug else "PROD", sub="gprbuild") logging.info("%-26s %s", "Build mode", config.data["gprbuild"]["BUILD"]) # Set GNATCOLL_OS if "darwin" in config.data["canonical_target"]: gnatcoll_os = "osx" elif "windows" in config.data["canonical_target"]: gnatcoll_os = "windows" else: # Assume this is an Unix system gnatcoll_os = "unix" config.set_data("GNATCOLL_OS", gnatcoll_os, sub="gprbuild") def variants(self, config, cmd): result = [] for library_type in config.data["library_types"]: gpr_vars = { "LIBRARY_TYPE": library_type, "XMLADA_BUILD": library_type, "GPR_BUILD": library_type, } if cmd == "install": result.append( ( ["--build-name=%s" % library_type, "--build-var=LIBRARY_TYPE"], gpr_vars, ) ) else: result.append(([], gpr_vars)) return result def install(self, args): config = Config() has_static_python = "GNATCOLL_PYTHON_STATIC_LIB" in config.data["gprbuild"] if not has_static_python: super(GNATCollPython, self).install(args) else: python_la = config.data["gprbuild"]["GNATCOLL_PYTHON_STATIC_LIB"] prefix = args.prefix if prefix is None: prefix = config.data["prefix"] rel_target = os.path.join( "..", "..", "lib", "gnatcoll_python.static", os.path.basename(python_la) ) abs_target = os.path.join( prefix, "lib", "gnatcoll_python.static", os.path.basename(python_la) ) shutil.copy(config.json_cache, config.json_cache + ".backup") try: # Temporary change the configuration to set a relative path to the # static Python library. config.set_data( "GNATCOLL_PYTHON_STATIC_LIB", rel_target, sub="gprbuild" ) config.save_data() # Perform the installation super(GNATCollPython, self).install(args) # Copy over the libpython*.a logging.info("Copy static libpython into target lib") if not os.path.isdir(os.path.dirname(abs_target)): os.mkdir(abs_target) result = shutil.copy(python_la, abs_target) logging.info(f"Python static lib in {result}") finally: # Restore the configuration cache shutil.copy(config.json_cache + ".backup", config.json_cache) os.unlink(config.json_cache + ".backup") if __name__ == "__main__": app = GNATCollPython() sys.exit(app.run()) gnatcoll-bindings-25.0.0/python3/tests/000077500000000000000000000000001464374334300177555ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/python3/tests/support/000077500000000000000000000000001464374334300214715ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/python3/tests/support/test.gpr000066400000000000000000000007331464374334300231650ustar00rootroot00000000000000with "gnatcoll_python"; project Test is Test_Sources := External("TEST_SOURCES", ""); Support_Sources := External("SUPPORT_SOURCES", ""); for Source_Dirs use (Test_Sources, Support_Sources); for Main use ("test.adb"); for Languages use ("Ada"); for Object_Dir use "obj"; package Compiler is for Default_Switches ("Ada") use ("-g", "-gnata", "-gnatVa", "-gnatQ", "-gnato", "-gnatwe", "-Wall", "-fstack-check"); end Compiler; end Test; gnatcoll-bindings-25.0.0/python3/tests/support/test_assert.adb000066400000000000000000000140171464374334300245040ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2018-2019, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with Ada.Strings.UTF_Encoding.Wide_Strings; with Ada.Calendar.Conversions; use Ada.Calendar.Conversions; with Ada.Calendar.Formatting; use Ada.Calendar.Formatting; package body Test_Assert is package IO renames Ada.Text_IO; package UTF renames Ada.Strings.UTF_Encoding.Wide_Strings; procedure Put_Indented (Indent_Columns : Natural; Lines : String); -- Put Lines on the standard output. This also indents all but the first -- line with Indent_Column spaces. ------------ -- Assert -- ------------ procedure Assert (Success : Boolean; Msg : String := ""; Location : String := SI.Source_Location) is begin -- Start with an indicator about test status so that it is easy to -- quickly spot failing tests. if Success then IO.Put ("OK "); else IO.Put ("FAIL"); Final_Status := 1; end if; -- Then tell where the failure happened, and add the given message (if -- any). IO.Put (" " & Location); if Msg'Length > 0 then IO.Put (" " & Msg); end if; IO.New_Line; Assert_Count := Assert_Count + 1; end Assert; ------------------ -- Put_Indented -- ------------------ procedure Put_Indented (Indent_Columns : Natural; Lines : String) is Starting_Line : Boolean := False; begin for C of Lines loop if C = ASCII.LF then Starting_Line := True; elsif Starting_Line then Starting_Line := False; IO.Put ((1 .. Indent_Columns => ' ')); end if; IO.Put (C); end loop; end Put_Indented; ------------ -- Assert -- ------------ procedure Assert (Left, Right : String; Msg : String := ""; Location : String := SI.Source_Location) is Success : constant Boolean := Left = Right; Expected_Prefix : constant String := "expected: "; Got_Prefix : constant String := "got: "; Indent : constant Natural := Expected_Prefix'Length; begin Assert (Success, Msg, Location); if not Success then if Right'Length > 0 then IO.Put (Expected_Prefix); Put_Indented (Indent, Right); IO.New_Line; else IO.Put_Line ("expected empty string"); end if; if Left'Length > 0 then IO.Put (Got_Prefix); Put_Indented (Indent, Left); IO.New_Line; else IO.Put_Line ("got empty string"); end if; end if; end Assert; ------------ -- Assert -- ------------ procedure Assert (Left : Wide_String; Right : UTF8.UTF_8_String; Msg : String := ""; Location : String := SI.Source_Location) is UTF_Left : constant UTF8.UTF_8_String := UTF.Encode (Left); begin Assert (UTF_Left, Right, Msg, Location); end Assert; ------------ -- Assert -- ------------ procedure Assert (Left : Integer; Right : Integer; Msg : String := ""; Location : String := SI.Source_Location) is Success : constant Boolean := Left = Right; begin Assert (Success, Msg, Location); if not Success then IO.Put_Line ("expected: " & Right'Img); IO.Put_Line ("got: " & Left'Img); end if; end Assert; --------------------- -- Assert_Inferior -- --------------------- procedure Assert_Inferior (Left : Time; Right : Time; Msg : String := ""; Location : String := SI.Source_Location) is Success : constant Boolean := Left < Right; begin Assert (Success, Msg, Location); if not Success then IO.Put_Line ("left: " & Image (Left) & " (" & To_Unix_Nano_Time (Left)'Img & ")"); IO.Put_Line ("right: " & Image (Right) & " (" & To_Unix_Nano_Time (Right)'Img & ")"); end if; end Assert_Inferior; ------------ -- Report -- ------------ function Report return Natural is begin if Final_Status = 0 then IO.Put_Line ("<=== TEST PASSED ===>"); else IO.Put_Line ("<=== TEST FAILED ===>"); end if; return Final_Status; end Report; end Test_Assert; gnatcoll-bindings-25.0.0/python3/tests/support/test_assert.ads000066400000000000000000000103271464374334300245250ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2018-2019, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ -- Helper package to implement tests that comply with the expectations -- of the default test driver. with Ada.Strings.UTF_Encoding; with Ada.Calendar; use Ada.Calendar; with GNAT.Source_Info; with GNATCOLL.VFS; package Test_Assert is package SI renames GNAT.Source_Info; package VFS renames GNATCOLL.VFS; package UTF8 renames Ada.Strings.UTF_Encoding; Final_Status : Natural := 0; procedure Assert (Success : Boolean; Msg : String := ""; Location : String := SI.Source_Location); -- If Success is True then test case is considered PASSED, otherwise -- the test status is FAILED and Final_Status set to 1. procedure Assert (Left, Right : String; Msg : String := ""; Location : String := SI.Source_Location); -- If Left = Right then test case is considered PASSED, otherwise -- the test status is FAILED and Final_Status set to 1. procedure Assert (Left : Wide_String; Right : UTF8.UTF_8_String; Msg : String := ""; Location : String := SI.Source_Location); -- If Left = Right then test case is considered PASSED, otherwise -- the test status is FAILED and Final_Status set to 1. procedure Assert_Inferior (Left : Time; Right : Time; Msg : String := ""; Location : String := SI.Source_Location); -- If Left <= Right then test case is considred PASSED, otherwise -- the test status is FAILED and Final_Status set to 1. procedure Assert (Left : Integer; Right : Integer; Msg : String := ""; Location : String := SI.Source_Location); -- If Left = Right then test case is considered PASSED, otherwise -- the test status is FAILED and Final_Status set to 1. Assert_Count : Natural := 0; -- Incremented every time an assert is called. Can be checked against a -- specific value to verify that the expected number of Asserts triggered, -- when their number depends on execution, e.g. if they are called from -- inside callbacks or conditional branches. function Report return Natural; -- Report should be called the following way at the end of a test -- program main function: -- -- return Report; -- -- Testsuite driver will consider a test to PASS if all the -- following conditions are met: -- -- * test program exit with status 0 -- * all assert calls did succeed -- * test program display the message "<=== TEST PASSED ===>" end Test_Assert; gnatcoll-bindings-25.0.0/python3/tests/support/test_common.adb000066400000000000000000000006331464374334300244720ustar00rootroot00000000000000with Ada.Environment_Variables; with GNATCOLL.Python.Lifecycle; use GNATCOLL.Python.Lifecycle; package body Test_Common is package Env renames Ada.Environment_Variables; function Python_Home return String is begin return Env.Value ("ADA_PYTHON_HOME"); end Python_Home; procedure Set_Python_Home is begin Py_SetPythonHome (Python_Home); end Set_Python_Home; end Test_Common; gnatcoll-bindings-25.0.0/python3/tests/support/test_common.ads000066400000000000000000000001601464374334300245060ustar00rootroot00000000000000package Test_Common is function Python_Home return String; procedure Set_Python_Home; end Test_Common; gnatcoll-bindings-25.0.0/python3/tests/support/test_support.gpr000066400000000000000000000002141464374334300247530ustar00rootroot00000000000000project Test_Support is for Source_Dirs use ("."); for Object_Dir use "obj/support"; for Languages use ("Ada"); end Test_Support; gnatcoll-bindings-25.0.0/python3/tests/tests/000077500000000000000000000000001464374334300211175ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/python3/tests/tests/class.getter_setter/000077500000000000000000000000001464374334300251035ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/python3/tests/tests/class.getter_setter/my_test.py000066400000000000000000000005471464374334300271470ustar00rootroot00000000000000from Test import My_Class # pass an integer in the field waiting for a float m = My_Class(42) # the returned value should be a float assert m.get_value() == 42.0 assert My_Class.get_value(m) == 42.0 # Computation m.set_value(m.get_value() / 2 + 0.1) # Verify the value almost match assert str(m.get_value()).startswith("21.1") print('<=== TEST PASSED ===>') gnatcoll-bindings-25.0.0/python3/tests/tests/class.getter_setter/test.adb000066400000000000000000000050371464374334300265370ustar00rootroot00000000000000with GNATCOLL.Scripts; use GNATCOLL.Scripts; with GNATCOLL.Scripts.Python; use GNATCOLL.Scripts.Python; with Test_Common; function Test return Integer is Repository : Scripts_Repository := null; Python : Python_Scripting := null; Errors : Boolean; procedure My_Class_Handler (Data : in out Callback_Data'Class; Command : String); ---------------------- -- My_Class_Handler -- ---------------------- procedure My_Class_Handler (Data : in out Callback_Data'Class; Command : String) is begin if Command = Constructor_Method then declare My_Inst : constant Class_Instance := Nth_Arg (Data, 1); Val : constant Float := Nth_Arg (Data, 2); begin Set_Data (My_Inst, "value", Create_Property (Val)); end; elsif Command = "get_value" then declare My_Inst : constant Class_Instance := Nth_Arg (Data, 1); begin Set_Return_Value (Data, Get_Data (My_Inst, "value").As_Float); end; elsif Command = "set_value" then declare My_Inst : constant Class_Instance := Nth_Arg (Data, 1); Val : constant Float := Nth_Arg (Data, 2); begin Set_Data (My_Inst, "value", Create_Property (Val)); end; end if; end My_Class_Handler; begin Test_Common.Set_Python_Home; Repository := new Scripts_Repository_Record; Register_Python_Scripting (Repo => Repository, Module => "Test"); Python := GNATCOLL.Scripts.Python.Python_Scripting (GNATCOLL.Scripts.Lookup_Scripting_Language (Repository, Python_Name)); declare My_Class : constant Class_Type := Repository.New_Class ("My_Class"); begin Repository.Register_Command (Command => Constructor_Method, Params => (1 .. 1 => Param ("value")), Handler => My_Class_Handler'Unrestricted_Access, Class => My_Class); Repository.Register_Command (Command => "get_value", Handler => My_Class_Handler'Unrestricted_Access, Class => My_Class); Repository.Register_Command (Command => "set_value", Params => (1 .. 1 => Param ("new_value")), Handler => My_Class_Handler'Unrestricted_Access, Class => My_Class); end; Python.Execute_File (Filename => "my_test.py", Show_Command => False, Errors => Errors); Python.Destroy; return 0; end Test; gnatcoll-bindings-25.0.0/python3/tests/tests/class.getter_setter/test.yaml000066400000000000000000000002761464374334300267530ustar00rootroot00000000000000description: test the creation of getter/setter goals: | The test creates a class named My_Class which has a getter and a setter for its hidden property named "value" of type float. gnatcoll-bindings-25.0.0/python3/tests/tests/class.gps_data/000077500000000000000000000000001464374334300240055ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/python3/tests/tests/class.gps_data/my_test.py000066400000000000000000000001651464374334300260450ustar00rootroot00000000000000from Test import My_Class m = My_Class("FooBar") assert m.Get_Property() == "FooBar" print('<=== TEST PASSED ===>') gnatcoll-bindings-25.0.0/python3/tests/tests/class.gps_data/test.adb000066400000000000000000000042011464374334300254310ustar00rootroot00000000000000with GNATCOLL.Scripts; use GNATCOLL.Scripts; with GNATCOLL.Scripts.Python; use GNATCOLL.Scripts.Python; with Test_Common; function Test return Integer is Repository : Scripts_Repository := null; Python : Python_Scripting := null; Errors : Boolean; procedure My_Class_Handler (Data : in out Callback_Data'Class; Command : String); ---------------------- -- My_Class_Handler -- ---------------------- procedure My_Class_Handler (Data : in out Callback_Data'Class; Command : String) is Property_Name : constant String := "My_Property"; begin if Command = Constructor_Method then declare My_Inst : constant Class_Instance := Nth_Arg (Data, 1); Name : constant String := Nth_Arg (Data, 2); begin Set_Data (My_Inst, Property_Name, Create_Property (Name)); end; elsif Command = "Get_Property" then declare My_Inst : constant Class_Instance := Nth_Arg (Data, 1); begin Set_Return_Value (Data, Get_Data (My_Inst, Property_Name).As_String); end; end if; end My_Class_Handler; begin Test_Common.Set_Python_Home; Repository := new Scripts_Repository_Record; Register_Python_Scripting (Repo => Repository, Module => "Test"); Python := GNATCOLL.Scripts.Python.Python_Scripting (GNATCOLL.Scripts.Lookup_Scripting_Language (Repository, Python_Name)); declare My_Class : constant Class_Type := Repository.New_Class ("My_Class"); begin Repository.Register_Command (Command => Constructor_Method, Params => (1 .. 1 => Param ("name")), Handler => My_Class_Handler'Unrestricted_Access, Class => My_Class); Repository.Register_Command (Command => "Get_Property", Handler => My_Class_Handler'Unrestricted_Access, Class => My_Class); end; Python.Execute_File (Filename => "my_test.py", Show_Command => False, Errors => Errors); Python.Destroy; return 0; end Test; gnatcoll-bindings-25.0.0/python3/tests/tests/class.gps_data/test.yaml000066400000000000000000000004171464374334300256520ustar00rootroot00000000000000description: test the creation of the hidden property __gps_data goals: | The test generates a python class named My_Class and add the hidden property __gps_data. Then it will verify the data stored inside __gps_data can easily be retrieved in the Ada layer. gnatcoll-bindings-25.0.0/python3/tests/tests/class.static/000077500000000000000000000000001464374334300235125ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/python3/tests/tests/class.static/my_test.py000066400000000000000000000001441464374334300255470ustar00rootroot00000000000000from Test import My_Class assert My_Class.Hello() == "Hello World!" print('<=== TEST PASSED ===>') gnatcoll-bindings-25.0.0/python3/tests/tests/class.static/test.adb000066400000000000000000000030341464374334300251410ustar00rootroot00000000000000with GNATCOLL.Scripts; use GNATCOLL.Scripts; with GNATCOLL.Scripts.Python; use GNATCOLL.Scripts.Python; with Test_Common; function Test return Integer is Repository : Scripts_Repository := null; Python : Python_Scripting := null; Errors : Boolean; procedure My_Class_Handler (Data : in out Callback_Data'Class; Command : String); ---------------------- -- My_Class_Handler -- ---------------------- procedure My_Class_Handler (Data : in out Callback_Data'Class; Command : String) is begin if Command = "Hello" then declare Val : constant String := "Hello World!"; begin Set_Return_Value (Data, Val); end; end if; end My_Class_Handler; begin Test_Common.Set_Python_Home; Repository := new Scripts_Repository_Record; Register_Python_Scripting (Repo => Repository, Module => "Test"); Python := GNATCOLL.Scripts.Python.Python_Scripting (GNATCOLL.Scripts.Lookup_Scripting_Language (Repository, Python_Name)); declare My_Class : constant Class_Type := Repository.New_Class ("My_Class"); begin Repository.Register_Command (Command => "Hello", Handler => My_Class_Handler'Unrestricted_Access, Class => My_Class, Static_Method => True); end; Python.Execute_File (Filename => "my_test.py", Show_Command => False, Errors => Errors); Python.Destroy; return 0; end Test; gnatcoll-bindings-25.0.0/python3/tests/tests/class.static/test.yaml000066400000000000000000000001751464374334300253600ustar00rootroot00000000000000description: test the creation of static method goals: | Creates a class named My_Class with a staticmethod named Hello. gnatcoll-bindings-25.0.0/python3/tests/tests/exception.from_ada/000077500000000000000000000000001464374334300246645ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/python3/tests/tests/exception.from_ada/my_test.py000066400000000000000000000003031464374334300267160ustar00rootroot00000000000000from Test import My_Class try: My_Class.raise_error() assert False # Should be unreachable except Exception as e: assert str(e) == "My_Error_Message" print('<=== TEST PASSED ===>') gnatcoll-bindings-25.0.0/python3/tests/tests/exception.from_ada/test.adb000066400000000000000000000027161464374334300263210ustar00rootroot00000000000000with GNATCOLL.Scripts; use GNATCOLL.Scripts; with GNATCOLL.Scripts.Python; use GNATCOLL.Scripts.Python; with Test_Common; function Test return Integer is Repository : Scripts_Repository := null; Python : Python_Scripting := null; Errors : Boolean; procedure My_Class_Handler (Data : in out Callback_Data'Class; Command : String); ---------------------- -- My_Class_Handler -- ---------------------- procedure My_Class_Handler (Data : in out Callback_Data'Class; Command : String) is begin if Command = "raise_error" then Set_Error_Msg (Data, "My_Error_Message"); end if; end My_Class_Handler; begin Test_Common.Set_Python_Home; Repository := new Scripts_Repository_Record; Register_Python_Scripting (Repo => Repository, Module => "Test"); Python := GNATCOLL.Scripts.Python.Python_Scripting (GNATCOLL.Scripts.Lookup_Scripting_Language (Repository, Python_Name)); declare My_Class : constant Class_Type := Repository.New_Class ("My_Class"); begin Repository.Register_Command (Command => "raise_error", Handler => My_Class_Handler'Unrestricted_Access, Class => My_Class, Static_Method => True); end; Python.Execute_File (Filename => "my_test.py", Show_Command => False, Errors => Errors); Python.Destroy; return 0; end Test; gnatcoll-bindings-25.0.0/python3/tests/tests/exception.from_ada/test.yaml000066400000000000000000000004201464374334300265230ustar00rootroot00000000000000description: test the propagation of error from Ada to Python goals: | Creates a class named My_Class with a static method "raise_error" which raises an error with a custom message. The error and the message should properly be propagated to the Python script. gnatcoll-bindings-25.0.0/python3/tests/tests/exception.from_python/000077500000000000000000000000001464374334300254605ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/python3/tests/tests/exception.from_python/my_test.py000066400000000000000000000000371464374334300275160ustar00rootroot00000000000000raise TypeError("Hello World") gnatcoll-bindings-25.0.0/python3/tests/tests/exception.from_python/test.adb000066400000000000000000000016041464374334300271100ustar00rootroot00000000000000with GNATCOLL.Scripts; use GNATCOLL.Scripts; with GNATCOLL.Scripts.Python; use GNATCOLL.Scripts.Python; with Test_Assert; with Test_Common; function Test return Integer is Repository : Scripts_Repository := null; Python : Python_Scripting := null; Errors : Boolean; begin Test_Common.Set_Python_Home; Repository := new Scripts_Repository_Record; Register_Python_Scripting (Repo => Repository, Module => "Test"); Python := GNATCOLL.Scripts.Python.Python_Scripting (GNATCOLL.Scripts.Lookup_Scripting_Language (Repository, Python_Name)); Python.Execute_File (Filename => "my_test.py", Show_Command => False, Errors => Errors); Test_Assert.Assert (Success => Errors, Msg => "The python script should raise an error."); Python.Destroy; return Test_Assert.Report; end Test; gnatcoll-bindings-25.0.0/python3/tests/tests/exception.from_python/test.yaml000066400000000000000000000002511464374334300273210ustar00rootroot00000000000000description: test propagation of exception from Python to Ada goals: | Execute a python script raising an exception check that the Ada layer recieved the error. gnatcoll-bindings-25.0.0/python3/tests/tests/lifecycle.py_main/000077500000000000000000000000001464374334300245115ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/python3/tests/tests/lifecycle.py_main/test.adb000066400000000000000000000007341464374334300261440ustar00rootroot00000000000000with GNATCOLL.Python.Lifecycle; use GNATCOLL.Python.Lifecycle; with GNATCOLL.Python; use GNATCOLL.Python; with Test_Assert; with Test_Common; function Test return Integer is package A renames Test_Assert; Status : Interpreter_Status; begin Py_SetPythonHome (Test_Common.Python_Home); Py_SetProgramName; Py_Initialize; Status := Py_Main; A.Assert(Status = Interpreter_Exit_Normally, "Interpreter failure"); Py_Finalize; return A.Report; end Test; gnatcoll-bindings-25.0.0/python3/tests/tests/lifecycle.py_main/test.yaml000066400000000000000000000005261464374334300263570ustar00rootroot00000000000000description: test using python interpreter main loop goals: | The goal of the test is to use GNATCOLL.Python.Lifecycle.Py_Main to launch the interpreter console loop. The test also ensure that arguments on the command line are passed correctly to the Python interpreter. test_args: ["-c", "import sys; print(sys.executable)"] gnatcoll-bindings-25.0.0/python3/tests/tests/scripts.execute_file/000077500000000000000000000000001464374334300252465ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/python3/tests/tests/scripts.execute_file/simple_print.py000066400000000000000000000000431464374334300303220ustar00rootroot00000000000000print('Hello from python binding') gnatcoll-bindings-25.0.0/python3/tests/tests/scripts.execute_file/test.adb000066400000000000000000000013711464374334300266770ustar00rootroot00000000000000with GNATCOLL.Scripts; use GNATCOLL.Scripts; with GNATCOLL.Scripts.Python; use GNATCOLL.Scripts.Python; with Test_Common; function Test return Integer is Repository : Scripts_Repository := null; Python : Python_Scripting := null; Errors : Boolean; begin Test_Common.Set_Python_Home; Repository := new Scripts_Repository_Record; Register_Python_Scripting (Repo => Repository, Module => "Test"); Python := GNATCOLL.Scripts.Python.Python_Scripting (GNATCOLL.Scripts.Lookup_Scripting_Language (Repository, Python_Name)); Python.Execute_File (Filename => "simple_print.py", Show_Command => False, Errors => Errors); Python.Destroy; return 0; end Test; gnatcoll-bindings-25.0.0/python3/tests/tests/scripts.execute_file/test.py000066400000000000000000000002771464374334300266050ustar00rootroot00000000000000from e3.os.process import Run import os import sys p = Run([os.path.join('obj', 'test')]) assert 'Hello from python binding' in p.out, f'output was\n:{p.out}' print('<=== TEST PASSED ===>') gnatcoll-bindings-25.0.0/python3/tests/tests/scripts.execute_file/test.yaml000066400000000000000000000007621464374334300271160ustar00rootroot00000000000000description: test gnatcoll.scripts.execute_file goals: | The test spawn a python script using the GNATCOLL.Scripts function Execute_File. The test is using an intermediate test.py to launch it in order to ensure that I/O are redirected correctly. Note that with Python 3.x, if GNATCOLL.Scripts.Python.Destroy is not called some output might be lost when stdout is not a console. Indeed Python 3.x buffering strategy differs from Python 2.x (Issue detected in T701-014) gnatcoll-bindings-25.0.0/python3/tests/testsuite.py000077500000000000000000000062521464374334300223700ustar00rootroot00000000000000#! /usr/bin/env python3 from e3.testsuite import Testsuite from e3.testsuite.driver import TestDriver from e3.testsuite.result import TestStatus from e3.testsuite.process import check_call from e3.env import Env from e3.fs import mkdir, cp, ls import logging import sys import os ROOT_DIR = os.path.dirname(os.path.abspath(__file__)) class DefaultDriver(TestDriver): @property def project_file(self): result = os.path.join(self.test_env["test_dir"], "test.gpr") if not os.path.isfile(result): result = os.path.join(self.env.root_dir, "support", "test.gpr") return result @property def build_dir(self): return self.test_env["working_dir"] @property def test_source_dir(self): return self.test_env["test_dir"] @property def support_source_dir(self): return os.path.join(self.env.root_dir, "support") def build(self, prev, slot): self.logger = logging.getLogger(f"test.{self.test_env['test_name']}") env = { "TEST_SOURCES": self.test_source_dir, "SUPPORT_SOURCES": self.support_source_dir, } mkdir(self.build_dir) py_files = ls(os.path.join(self.test_source_dir, "*.py")) if py_files: cp(py_files, self.build_dir) check_call( self, ["gprbuild", "-P", self.project_file, "--relocate-build-tree", "-p"], cwd=self.build_dir, timeout=300, env=env, ignore_environ=False, ) def run(self, prev, slot): if self.result.status == TestStatus.ERROR: # means that status was not set test_py = os.path.join(self.build_dir, "test.py") if os.path.isfile(test_py): self.test_process = check_call( self, [sys.executable, "./test.py"], cwd=self.build_dir, timeout=60 ) else: self.test_process = check_call( self, [os.path.join(self.build_dir, "obj", "test")] + self.test_env.get("test_args", []), timeout=60, cwd=self.build_dir, ) def analyze(self, prev, slot): if self.result.status == TestStatus.ERROR: # means that status was not set if "<=== TEST PASSED ===>" not in self.test_process.out: self.result.set_status(TestStatus.FAIL) else: self.result.set_status(TestStatus.PASS) self.push_result() def add_test(self, dag): self.add_fragment(dag, "build") self.add_fragment(dag, "run", after=["build"]) self.add_fragment(dag, "analyze", after=["run"]) class GNATCOLLPython3Test(Testsuite): """Testsuite for the bc(1) calculator.""" test_driver_map = {"default": DefaultDriver} default_driver = "default" tests_subdir = "tests" if __name__ == "__main__": Env.add_search_path("GPR_PROJECT_PATH", os.path.join(ROOT_DIR, "support")) assert ( "ADA_PYTHON_HOME" in os.environ ), "ADA_PYTHON_HOME should point to Python distrib used to build the binding" sys.exit(GNATCOLLPython3Test().testsuite_main()) gnatcoll-bindings-25.0.0/readline/000077500000000000000000000000001464374334300167725ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/readline/README.md000066400000000000000000000017451464374334300202600ustar00rootroot00000000000000The GNAT Components Collection (GNATCOLL) - Readline ==================================================== This is the Readline component of the GNAT Components Collection. This component provides an interface to the readline library. This library provides support for interactive input from the user, providing nice key bindings to edit the current line (including support for backspace, move to beginning or end of line,...), as well as support for completion (via the key) and history (via up and down keys). Readline is licensed under the Full GNU General Public License. If you distribute a program using this package and the readline library, this program must be free software. When building, you need to pass an explicit option `--accept-gpl` to indicate that you accept and understand the terms of the license. Dependencies ------------ This component requires the following external components, that should be available on your system: - gprbuild - gnatcoll-core - readline gnatcoll-bindings-25.0.0/readline/docs/000077500000000000000000000000001464374334300177225ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/readline/docs/Makefile000066400000000000000000000000431464374334300213570ustar00rootroot00000000000000include ../../docs-common/Makefile gnatcoll-bindings-25.0.0/readline/docs/conf.py000066400000000000000000000016531464374334300212260ustar00rootroot00000000000000# -*- coding: utf-8 -*- # GNATcoll Bindings - Readline documentation build configuration file # Load the base setup exec(open('../../docs-common/common_conf.py').read()) # General information about the project. project = u'GNATcoll Bindings - Readline' # Output file base name for HTML help builder. htmlhelp_basename = 'GNATcoll-Readline' # Grouping the document tree into LaTeX files. List of tuples # (source start file, target name, title, author, documentclass # [howto/manual]). latex_documents = [ ('index', 'GNATcoll-Readline.tex', u'GNATcoll Bindings - Readline Documentation', u'AdaCore', 'manual'), ] # One entry per manual page. List of tuples # (source start file, name, description, authors, manual section). man_pages = [ ('index', 'gnatcoll-readline', u'GNATcoll Bindings - Readline Documentation', [u'AdaCore'], 1) ] # Bibliographic Dublin Core info. epub_title = u'GNATcoll Bindings - Readline' gnatcoll-bindings-25.0.0/readline/docs/index.rst000066400000000000000000000027751464374334300215760ustar00rootroot00000000000000GNATcoll Bindings - Readline: interactive command line ====================================================== .. highlight:: ada GNATcoll provides an interface to the ``readline`` library. .. sidebar:: License |Note| The GNU `readline` library is licensed under the terms of the GNU General Public License, version 3. This means that if you want to use Readline in a program that you release or distribute to anyone, the program must be free software and have a GPL-compatible license. You need to pass ``--accept-gpl`` to the ``setup.py`` script in order to indicate you understand the license of ``readline``. This component provides various features to enhance command line support in tools. In particular, it provides various keybindings to make editing more comfortable than ``Ada.Text_IO.Get_Line``. For instance, it is possible to use backspace to edit what you have just typed. It is also possible to move forward or backward by word, go to the start or end of line, ... ``readline`` also provides support for completion: by using the :kbd:`tab` key, users can get all possible completions for the current word. This behavior is controllable from Ada, where your application can provide the list of completions. Finally, readline comes with support for history. By using the :kbd:`up` and :kbd:`down` keys, the user can navigate the commands that were previously typed. It is also possible to preserve the history across sessions. See the ``GNATCOLL.Readline`` package for more information on this API. gnatcoll-bindings-25.0.0/readline/gnatcoll-readline.adb000066400000000000000000000167421464374334300230400ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2012-2017, 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. -- -- -- -- 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 Interfaces.C.Strings; use Interfaces.C.Strings; package body GNATCOLL.Readline is type Rl_Completion_Function is access function (Text : Interfaces.C.Strings.chars_ptr; Start : Integer; Last : Integer) return Possible_Completions; pragma Convention (C, Rl_Completion_Function); type Rl_Compentry_Func is access function (Text : Interfaces.C.Strings.chars_ptr; State : Integer) return chars_ptr; pragma Convention (C, Rl_Compentry_Func); -- A function that returns each of the possible completions for -- Text. On the first call, STATE is set to 0, and then is non-zero. -- This function should return Null_Ptr when there are no more matches. function Rl_Completion_Matches (Text : chars_ptr; Generator : Rl_Compentry_Func) return Possible_Completions; pragma Import (C, Rl_Completion_Matches, "rl_completion_matches"); -- Returns an array of strings which is a list of completions for -- TEXT. If there are no completions, returns NULL. -- GENERATOR is a function that returns all possible completions, in -- turn. procedure Using_History; pragma Import (C, Using_History, "using_history"); -- Enables support for history. procedure Read_History (filename : chars_ptr); pragma Import (C, Read_History, "read_history"); -- Reads the history from a file. procedure Write_History (Filename : chars_ptr); pragma Import (C, Write_History, "write_history"); -- Write the current history back to a file. function C_Completer (Text : Interfaces.C.Strings.chars_ptr; Start : Integer; Last : Integer) return Possible_Completions; pragma Convention (C, C_Completer); -- Attempt to complete on the contents of TEXT. START and END bound the -- region of rl_line_buffer that contains the word to complete. TEXT is -- the word to complete. We can use the entire contents of rl_line_buffer -- in case we want to do some simple parsing. Return the array of matches, -- or NULL if there aren't any. Rl_Line_Buffer : chars_ptr; pragma Import (C, Rl_Line_Buffer, "rl_line_buffer"); -- The line gathered so far by readline. Rl_Readline_Name : Interfaces.C.Strings.chars_ptr; pragma Import (C, Rl_Readline_Name, "rl_readline_name"); Rl_Attempted_Completion_Function : Rl_Completion_Function; pragma Import (C, Rl_Attempted_Completion_Function, "rl_attempted_completion_function"); -- A pointer to an alternative function to create matches. Ada_Completer : Completer_Function; ---------------- -- Initialize -- ---------------- procedure Initialize (Appname : String := ""; History_File : String := ""; Completer : Completer_Function := null) is Tmp : chars_ptr; begin if Appname /= "" then Rl_Readline_Name := New_String (Appname); end if; if Completer /= null then Rl_Attempted_Completion_Function := C_Completer'Access; Ada_Completer := Completer; end if; Using_History; if History_File /= "" then Tmp := New_String (History_File); Read_History (Tmp); Free (Tmp); end if; end Initialize; -------------- -- Finalize -- -------------- procedure Finalize (History_File : String := "") is Tmp : chars_ptr; begin if History_File /= "" then Tmp := New_String (History_File); Write_History (Tmp); Free (Tmp); end if; end Finalize; ------------------------ -- Completion_Matches -- ------------------------ function Completion_Matches (Text : String; Generator : Completion_Entry_Func) return Possible_Completions is Txt : Interfaces.C.Strings.chars_ptr := New_String (Text); function Completion_Generator (Txt : Interfaces.C.Strings.chars_ptr; State : Integer) return chars_ptr; pragma Convention (C, Completion_Generator); -- Wrapper around the user's completion function. -------------------------- -- Completion_Generator -- -------------------------- function Completion_Generator (Txt : Interfaces.C.Strings.chars_ptr; State : Integer) return chars_ptr is pragma Unreferenced (Txt); Choice : constant String := Generator (Text, State); begin if Choice = "" then return Null_Ptr; else return New_String (Choice); end if; end Completion_Generator; Result : Possible_Completions; begin Result := Rl_Completion_Matches (Txt, Completion_Generator'Unrestricted_Access); Free (Txt); return Result; end Completion_Matches; ----------------- -- C_Completer -- ----------------- function C_Completer (Text : Interfaces.C.Strings.chars_ptr; Start : Integer; Last : Integer) return Possible_Completions is begin return Ada_Completer (Full_Line => Value (Rl_Line_Buffer), Text => Value (Text), Start => Start, Last => Last); end C_Completer; -------------- -- Get_Line -- -------------- function Get_Line (Prompt : String := "") return String is function Readline (Prompt : chars_ptr) return chars_ptr; pragma Import (C, Readline, "readline"); procedure Add_History (Str : chars_ptr); pragma Import (C, Add_History, "add_history"); Pr : chars_ptr; Result : chars_ptr; begin if Prompt /= "" then Pr := New_String (Prompt); Result := Readline (Pr); Free (Pr); else Result := Readline (Null_Ptr); end if; if Result /= Null_Ptr then declare Val : constant String := Value (Result); begin if Val /= "" then Add_History (Result); end if; Free (Result); return Val; end; else raise Ada.Text_IO.End_Error; end if; end Get_Line; end GNATCOLL.Readline; gnatcoll-bindings-25.0.0/readline/gnatcoll-readline.ads000066400000000000000000000135501464374334300230530ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2012-2021, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package provides an interface to the readline library. -- This library provides support for interactive input from the user, -- providing nice key bindings to edit the current line (including support -- for backspace, move to beginning or end of line,...), as well as support -- for completion (via the key) and history (via up and down keys). -- -- Readline is licensed under the Full GNU General Public License. If you -- distribute a program using this package and the readline library, this -- program must be free software. package GNATCOLL.Readline is ---------------- -- Completion -- ---------------- -- Readline supports completion of the current word when the user presses -- . -- The default is to complete on file names and user names, but you can -- configure your own subprogram to do the completion. Since there is a -- single instance of readline per application, it heavily uses global -- variables. As a result, your own completer should also use global -- variables if it needs to save information. type Possible_Completions_Array (<>) is private; type Possible_Completions is access Possible_Completions_Array; type Completion_Entry_Func is access function (Text : String; State : Integer) return String; function Completion_Matches (Text : String; Generator : Completion_Entry_Func) return Possible_Completions; -- An adapter for a completion generator. -- The goal of Generator is to return (one by one) each of the possible -- completions for Text. The first time it is called for a given word, -- State will be 0. It will then be increased by 1 for each entry to -- suggest. -- When there are no more possible completions, it should return the -- the empty string. type Completer_Function is access function (Full_Line : String; Text : String; Start, Last : Integer) return Possible_Completions; -- This function returns an array of strings, that should be generated -- by Completion_Matches above; it can also return null -- to use the default completion from readline (on filenames). -- Full_Line is the current full line, as read by readline so far. -- Text is the text to complete. Start is the position of Text within -- the Full_Line (0 means this is the first word on the line). -- -- For instance: -- if Start = 0 then -- -- First word on the line ? -- return Completion_Matches (Text, Command_Completion'Access); -- else -- -- default filename completion -- return null; -- end if; ----------- -- Setup -- ----------- procedure Initialize (Appname : String := ""; History_File : String := ""; Completer : Completer_Function := null); -- Initialize the support for readline. -- If that library is not available on the system, this operation does -- nothing, and is safe to call. -- Appname is the name of the application, and is used for conditional -- parsing of the ~/.inputrc file. -- History_File is the name of the file that should read to initialize the -- history (useful for saving the history across sessions). procedure Finalize (History_File : String := ""); -- Finalize the support for gnatcoll. -- In particular, saves the current history to History_File if specified, -- so that the next session can restore that history. function Get_Line (Prompt : String := "") return String; -- Display Prompt, and reads one line of input. -- The exception Ada.Text_IO.End_Error is raised if the user presses -- control-D type Ctrl_C_Handler is access procedure; pragma Convention (C, Ctrl_C_Handler); -- Any parameterless library level procedure can be used as a handler. -- Ctrl_C_Handler should not propagate exceptions. -- Such a function is useful for saving the history when the application -- exits for instance. procedure Install_Ctrl_C_Handler (Handler : Ctrl_C_Handler); pragma Import (C, Install_Ctrl_C_Handler, "__gnat_install_int_handler"); -- Set up Handler to be called if the operator hits Ctrl-C private type Possible_Completions_Array is null record; end GNATCOLL.Readline; gnatcoll-bindings-25.0.0/readline/gnatcoll_readline.gpr000066400000000000000000000074101464374334300231540ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2015-2020, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with "gnatcoll_core"; library project GnatColl_Readline is Version := External ("GNATCOLL_VERSION", "0.0"); Name := "gnatcoll_readline"; type Build_Type is ("DEBUG", "PROD"); Build : Build_Type := External ("GNATCOLL_BUILD_MODE", External ("BUILD", "PROD")); type Library_Type_Type is ("relocatable", "static", "static-pic"); Library_Type : Library_Type_Type := External ("LIBRARY_TYPE", "static"); for Source_Dirs use ("."); for Library_Kind use Library_Type; for Object_Dir use "obj/" & Project'Library_Kind; for Library_Dir use "lib/" & Project'Library_Kind; for Library_Name use Name; Link_Opts := ("-lreadline"); case Library_Type is when "relocatable" => for Library_Version use "lib" & Name & Gnatcoll_Core.So_Ext & "." & Version; for Leading_Library_Options use External_As_List ("LDFLAGS", " "); for Library_Options use Link_Opts; when others => null; end case; for Languages use ("Ada"); package Compiler is case Build is when "DEBUG" => for Switches ("Ada") use ("-g", "-O0", "-gnata", "-gnatVa", "-gnatQ", "-gnaty", "-gnateE", "-gnatwaCJe", "-fstack-check"); when "PROD" => -- Do not use -gnatwe for production mode for Switches ("Ada") use ("-O2", "-gnatn", "-gnatwaCJ"); end case; for Switches ("Ada") use Compiler'Switches ("Ada") & External_As_List ("ADAFLAGS", " "); end Compiler; package Linker is for Linker_Options use Link_Opts; end Linker; package Binder is case Build is when "DEBUG" => for Switches ("Ada") use ("-E"); when "PROD" => null; end case; end Binder; package Builder is case Build is when "DEBUG" => for Global_Configuration_Pragmas use "../gnat_debug.adc"; when "PROD" => null; end case; end Builder; package Ide is for VCS_Kind use "Git"; end Ide; end GnatColl_Readline; gnatcoll-bindings-25.0.0/readline/setup.py000077500000000000000000000046321464374334300205140ustar00rootroot00000000000000#!/usr/bin/env python import logging import os import sys sys.path.append(os.path.dirname(os.path.dirname(os.path.abspath(__file__)))) from setup_support import SetupApp class GNATCollReadline(SetupApp): name = 'gnatcoll_readline' project = 'gnatcoll_readline.gpr' description = 'GNATColl Readline bindings' def create(self): super(GNATCollReadline, self).create() self.build_cmd.add_argument( '--debug', help='build project in debug mode', action="store_true", default=False) self.build_cmd.add_argument( '--accept-gpl', help='accept the GPL license', action="store_true", default=False) def update_config(self, config, args): assert args.accept_gpl, "--accept-gpl is required" logging.info('%-26s %s', 'Libraries kind', ", ".join(config.data['library_types'])) # Set library version with open(os.path.join(config.source_dir, '..', 'version_information'), 'r') as fd: version = fd.read().strip() config.set_data('GNATCOLL_VERSION', version, sub='gprbuild') # Set build mode config.set_data('BUILD', 'DEBUG' if args.debug else 'PROD', sub='gprbuild') logging.info('%-26s %s', 'Build mode', config.data['gprbuild']['BUILD']) # Set GNATCOLL_OS if 'darwin' in config.data['canonical_target']: gnatcoll_os = 'osx' elif 'windows' in config.data['canonical_target']: gnatcoll_os = 'windows' else: # Assume this is an Unix system gnatcoll_os = 'unix' config.set_data('GNATCOLL_OS', gnatcoll_os, sub='gprbuild') def variants(self, config, cmd): result = [] for library_type in config.data['library_types']: gpr_vars = {'LIBRARY_TYPE': library_type, 'XMLADA_BUILD': library_type, 'GPR_BUILD': library_type} if cmd == 'install': result.append((['--build-name=%s' % library_type, '--build-var=LIBRARY_TYPE'], gpr_vars)) else: result.append(([], gpr_vars)) return result if __name__ == '__main__': app = GNATCollReadline() sys.exit(app.run()) gnatcoll-bindings-25.0.0/setup_support.py000066400000000000000000000325541464374334300205260ustar00rootroot00000000000000#!/usr/bin/env python from subprocess import check_output, check_call, CalledProcessError import argparse import json import logging import os import re import sys def which(prog, paths=None, default=''): """Locate executable. :param prog: program to find :type prog: str :param paths: if not None then we use this value instead of PATH to look for the executable. :type paths: str | None :param default: default value to return if not found :type default: str | None | T :return: absolute path to the program on success, found by searching for an executable in the directories listed in the environment variable PATH or default value if not found :rtype: str | None | T """ def is_exe(fpath): return os.path.isfile(fpath) and os.access(fpath, os.X_OK) def possible_names(fpath): names = [fpath] if sys.platform == 'win32': names.extend([fpath + ext for ext in os.environ.get('PATHEXT', '').split(';')]) return names fpath, fname = os.path.split(prog) if fpath: # Full path given, check if executable for progname in possible_names(prog): if is_exe(progname): return progname else: # Check for all directories listed in $PATH if paths is None: paths = os.environ["PATH"] for pathdir in paths.split(os.pathsep): exe_file = os.path.join(pathdir, prog) for progname in possible_names(exe_file): if is_exe(progname): return progname # Not found. return default SUPPORTED_LIBRARY_TYPES = {'static', 'static-pic', 'relocatable'} def decode_library_types(arg): library_types = arg.split(',') library_type_set = set(library_types) # Make sure that all requested library types are supported unsupported = library_type_set - SUPPORTED_LIBRARY_TYPES if unsupported: raise ValueError('Unsupported library types: {}' .format(', '.join(sorted(unsupported)))) # Make sure that the given list of library types contains no double entries if len(library_types) != len(library_type_set): raise ValueError('Library types cannot be requested twice') # Return the list, and not the set, to keep the original ordering return library_types class Config(object): def __init__(self, args=None): self.object_dir = os.path.abspath(os.getcwd()) self.source_dir = os.path.abspath(os.path.dirname(sys.argv[0])) self.json_cache = os.path.join(self.object_dir, 'setup.json') if args is not None: self.load_cache = args.load_cache else: self.load_cache = True self.cache_loaded = False self.init_data(args) @classmethod def add_arguments(cls, parser): parser.add_argument('--jobs', '-j', help='gprbuild parallelism', default='0') parser.add_argument('--reconfigure', help='ignore previous setup results', dest='load_cache', default=True, action="store_false") parser.add_argument('--target', help='target', default=None) parser.add_argument('--prefix', help='installation prefix', default='auto') parser.add_argument('--integrated', help='installation in platform specific subdir', default=False, action="store_true") parser.add_argument('--library-types', default=['static', 'static-pic', 'relocatable'], type=decode_library_types, help='Comma-separated list of library types to' ' build. By default, build all of them.') def init_data(self, args): if self.load_cache and os.path.isfile(self.json_cache): with open(self.json_cache, 'r') as fd: try: data = json.load(fd) except Exception: data = {} # Check that the setup is not changed if (data.get('source_dir', '') == self.source_dir and data.get('object_dir', '') == self.object_dir): self.data = data self.cache_loaded = True return self.data = {} self.data['source_dir'] = self.source_dir self.data['object_dir'] = self.object_dir if args is not None: if args.target is None: self.data['target'] = self.run('gcc', '-dumpmachine', grab=True) else: self.data['target'] = args.target self.data['jobs'] = args.jobs self.data['integrated'] = args.integrated self.data['canonical_target'] = self.run( 'gprconfig', '--config=ada', '--target=%s' % self.data['target'], '--mi-show-compilers', grab=r' 1 normalized_target:(\S*)') default_prefix = os.path.dirname( os.path.dirname( self.run('gprconfig', '--config=ada', '--target=%s' % self.data['target'], '--mi-show-compilers', grab=r' 1 path:(.*)'))) if args.prefix == 'auto': self.data['prefix'] = default_prefix else: self.data['prefix'] = args.prefix # The first element in library_types list define the default type # of library that will be used. Do not rely on the default set in # the project file. self.data['library_types'] = args.library_types def set_data(self, name, value, sub=None): if sub is None: self.data[name] = value else: if sub not in self.data: self.data[sub] = {} self.data[sub][name] = value def save_data(self): with open(self.json_cache, 'w') as fd: json.dump(self.data, fd) def gprcmd(self, cmd, project, *args, **kwargs): cmd = list(cmd) + list(args) # Handle out of source dir builds if self.source_dir != self.object_dir: cmd.append('-P%s' % os.path.join(self.source_dir, project)) cmd.append('--relocate-build-tree') else: cmd.append('-P%s' % project) # Always pass --target so that 'Target value is enforced. cmd.append('--target=%s' % self.data['canonical_target']) # Pass common variables values computed during configure # step and stored in setup.json if 'gprbuild' in self.data: for name, value in self.data['gprbuild'].items(): cmd.append('-X%s=%s' % (name, value)) # Additional scenario variables coming usually from variants if 'gpr_vars' in kwargs: for name, value in kwargs['gpr_vars'].items(): cmd.append('-X%s=%s' % (name, value)) return self.run(*cmd, **kwargs) @property def prefix(self): prefix = self.data['prefix'] # In integrated mode always install in a subdirectory which is # target specific if self.data['integrated']: prefix = os.path.join(prefix, self.data['canonical_target']) return prefix def gprbuild(self, project, *args, **kwargs): cmd = ['gprbuild', '-j%s' % self.data['jobs'], '-p'] return self.gprcmd(cmd, project, *args, **kwargs) def gprclean(self, project, *args, **kwargs): cmd = ['gprclean', '-q'] return self.gprcmd(cmd, project, *args, **kwargs) def gprinstall(self, project, *args, **kwargs): # Sources are shared between all variants and put in # include/ where project_name is the base name of # project file. cmd = ['gprinstall', '-p', '-f', '--prefix=%s' % self.prefix, '--sources-subdir=include/%s' % project[:-4]] return self.gprcmd(cmd, project, *args, **kwargs) def gpruninstall(self, project, *args, **kwargs): cmd = ['gprinstall', '-p', '-f', '--prefix=%s' % self.prefix] cmd.append('--uninstall') return self.gprcmd(cmd, project, *args, **kwargs) def run(self, *args, **kwargs): grab = kwargs.get('grab', False) cmd = list(args) cmd[0] = which(cmd[0]) assert cmd[0], "cannot find program: %s" % args[0] if grab: output = check_output(cmd).decode('utf-8').strip() if not isinstance(grab, bool): output = re.findall(grab, output)[0] return output else: logging.info('Launch: %s' % " ".join(cmd)) return check_call(cmd) class SetupApp(object): def __init__(self): pass def variants(self, config, cmd): return [([], {})] def build(self, args): config = Config(args) if not config.cache_loaded: self.update_config(config, args) config.save_data() for gpr_args, gpr_vars in self.variants(config, 'build'): config.gprbuild( self.project, *(gpr_args + args.gpr_opts + ['-gargs']), gpr_vars=gpr_vars) return 0 def clean(self, args): config = Config() if not config.cache_loaded: logging.info('nothing to clean') return 0 for gpr_args, gpr_vars in self.variants(config, 'clean'): config.gprclean(self.project, *(gpr_args + args.gpr_opts), gpr_vars=gpr_vars) def install(self, args): config = Config() if not config.cache_loaded: logging.info('nothing to install') return 0 if args.prefix is not None: config.set_data('prefix', args.prefix) logging.info('%-26s %s', 'Installation directory', config.data['prefix']) for gpr_args, gpr_vars in self.variants(config, 'install'): config.gprinstall(self.project, *(gpr_args + args.gpr_opts), gpr_vars=gpr_vars) def uninstall(self, args): config = Config() if not config.cache_loaded: logging.info('nothing to uninstall') return 0 if args.prefix is not None: config.set_data('prefix', args.prefix) config.gpruninstall(self.project, *args.gpr_opts) def create(self): self.main = argparse.ArgumentParser(description=self.description) self.parser = self.main.add_subparsers( title='commands', description='available commands (do ./setup.py CMD --help ' 'for help on command CMD)') # Build command self.build_cmd = self.parser.add_parser('build', help='build %s' % self.name) self.build_cmd.add_argument( '--gpr-opts', nargs=argparse.REMAINDER, default=[], help="pass remaining arguments to gprbuild") Config.add_arguments(self.build_cmd) self.build_cmd.set_defaults(command=self.build) # Clean command self.clean_cmd = self.parser.add_parser( 'clean', help='clean %s' % self.name) self.clean_cmd.add_argument( '--gpr-opts', default=[], nargs=argparse.REMAINDER, help="pass remaining arguments to gprclean") self.clean_cmd.set_defaults(command=self.clean) # Install command self.install_cmd = self.parser.add_parser( 'install', help='install %s' % self.name) self.install_cmd.add_argument( '--gpr-opts', default=[], nargs=argparse.REMAINDER, help="pass remaining arguments to gprinstall") self.install_cmd.add_argument('--prefix', help='installation prefix', default=None) self.install_cmd.set_defaults(command=self.install) # Uninstall command self.uninstall_cmd = self.parser.add_parser( 'uninstall', help='uninstall %s' % self.name) self.uninstall_cmd.add_argument( '--gpr-opts', default=[], nargs=argparse.REMAINDER, help="pass remaining arguments to gpruninstall") self.uninstall_cmd.add_argument('--prefix', help='un-installation prefix', default=None) self.uninstall_cmd.set_defaults(command=self.uninstall) logging.basicConfig(level=logging.DEBUG, format='%(message)s') def run(self): self.create() args = self.main.parse_args() try: return args.command(args) except CalledProcessError as e: logging.error('process failed with status: %s', e.returncode) return 1 except AssertionError as e: logging.error('requirement missing: %s', e) return 1 gnatcoll-bindings-25.0.0/syslog/000077500000000000000000000000001464374334300165275ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/syslog/README.md000066400000000000000000000010601464374334300200030ustar00rootroot00000000000000The GNAT Components Collection (GNATCOLL) - Syslog ================================================== This is the Syslog component of the GNAT Components Collection. Interface to syslog, the system logger on Unix systems. This package provides two levels of interfaces: - a low level interface to syslog (on Unix systems) - a higher level interface that can be used through GNAT.Traces. Dependencies ------------ This component requires the following external components, that should be available on your system: - gprbuild - gnatcoll-core - syslog gnatcoll-bindings-25.0.0/syslog/docs/000077500000000000000000000000001464374334300174575ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/syslog/docs/Makefile000066400000000000000000000000431464374334300211140ustar00rootroot00000000000000include ../../docs-common/Makefile gnatcoll-bindings-25.0.0/syslog/docs/conf.py000066400000000000000000000016331464374334300207610ustar00rootroot00000000000000# -*- coding: utf-8 -*- # # GNATcoll Bindings - Syslog documentation build configuration file # Load the base setup exec(open('../../docs-common/common_conf.py').read()) # General information about the project. project = u'GNATcoll Bindings - Syslog' # Output file base name for HTML help builder. htmlhelp_basename = 'GNATcoll-Syslogdoc' # Grouping the document tree into LaTeX files. List of tuples # (source start file, target name, title, author, documentclass # [howto/manual]). latex_documents = [ ('index', 'GNATcoll-Syslog.tex', u'GNATcoll Bindings - Syslog Documentation', u'AdaCore', 'manual'), ] # One entry per manual page. List of tuples # (source start file, name, description, authors, manual section). man_pages = [ ('index', 'gnatcoll-syslog', u'GNATcoll Bindings - Syslog Documentation', [u'AdaCore'], 1) ] # Bibliographic Dublin Core info. epub_title = u'GNATcoll Bindings - Syslog' gnatcoll-bindings-25.0.0/syslog/docs/index.rst000066400000000000000000000023171464374334300213230ustar00rootroot00000000000000GNATcoll Bindings - Syslog ========================== Among the predefined streams, GNATColl gives access to the system logger ``syslog``. This is a standard utility on all Unix systems, but is not available on other systems. Activating support for syslog requires the following call in your application:: GNATCOLL.Traces.Syslog.Register_Syslog_Stream; After the above call, trace handles can be redirected to a stream named ``"syslog"``. The package ``GNATCOLL.Traces.Syslog`` also contains a low-level interface to syslog, which, although fully functional, you should probably not use, since that would make your code system-dependent. Syslog itself dispatches its output based on two criteria: the ``facility``, which indicates what application emitted the message, and where it should be filed, and the ``level`` which indicates the urgency level of the message. Both of these criteria can be specified in the ``GNATCOLL.Traces`` configuration file, as follows:: MODULE=yes >&syslog:user:error The above configuration will redirect to a facility called ``user``, with an urgency level ``error``. See the enumeration types in :file:`gnatcoll-traces-syslog.ads` for more information on valid facilities and levels. gnatcoll-bindings-25.0.0/syslog/gnatcoll-traces-syslog.adb000066400000000000000000000167601464374334300236110ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2001-2017, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Command_Line; with Ada.Strings.Fixed; use Ada.Strings.Fixed; with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.Task_Lock; use GNAT.Task_Lock; with Interfaces.C.Strings; use Interfaces.C.Strings; package body GNATCOLL.Traces.Syslog is C_Prefix : chars_ptr := Null_Ptr; -- This variable belongs to the package because on some systems, -- most notably Linux, openlog() does not copy the content of -- ident. As a consequence, we can't deallocate it until the closelog(). -- Any access to these variables is protected through the use of -- Lock_Task/Unlock_Task, in order to have locking feature without -- getting the whole runtime. Facilities_To_Integer : constant array (Facilities) of Integer := (Kernel => 0 * 8, User => 1 * 8, Mail => 2 * 8, Daemon => 3 * 8, Auth => 4 * 8, Sys_Log => 5 * 8, Printer => 6 * 8, News => 7 * 8, UUCP => 8 * 8, Cron => 9 * 8, Auth_Priv => 10 * 8, FTP => 11 * 8, NTP => 12 * 8, Security => 13 * 8, Console => 14 * 8, Local0 => 16 * 8, Local1 => 17 * 8, Local2 => 18 * 8, Local3 => 19 * 8, Local4 => 20 * 8, Local5 => 21 * 8, Local6 => 22 * 8, Local7 => 23 * 8); Levels_To_Integer : constant array (Levels) of Integer := (Emergency => 0, Alert => 1, Critical => 2, Error => 3, Warning => 4, Notice => 5, Info => 6, Debug => 7); -- Convert Facilities to integers. Do not use representation clauses for -- two reasons: -- They would have to appear in the public part of the spec, which is -- not nice -- We cannot convert a value to an integer through an attribute, and -- we need to be able to combine levels and facilities in the call -- to syslog... type Syslog_Stream_Record is new Trace_Stream_Record with record Facility : Facilities; Level : Levels; end record; overriding procedure Put (Stream : in out Syslog_Stream_Record; Str : Msg_Strings.XString); overriding function Supports_Color (Stream : Syslog_Stream_Record) return Boolean is (False); overriding function Supports_Time (Stream : Syslog_Stream_Record) return Boolean is (False); -- See inherited documentation type Factory is new Stream_Factory with null record; overriding function New_Stream (Fact : Factory; Args : String) return Trace_Stream; -- Create a syslog stream --------- -- Put -- --------- overriding procedure Put (Stream : in out Syslog_Stream_Record; Str : Msg_Strings.XString) is S : Msg_Strings.Char_Array; L : Natural; begin Str.Get_String (S, L); -- Do not include the trailing newline Syslog (Stream.Facility, Stream.Level, String (S (1 .. L - 1))); end Put; ---------------- -- New_Stream -- ---------------- function New_Stream (Fact : Factory; Args : String) return Trace_Stream is pragma Unreferenced (Fact); Colon : constant Integer := Index (Args, ":"); Facility : Facilities := User; Level : Levels := Info; begin if Args /= "" then if Colon < Args'First then Facility := Facilities'Value (Args); else Facility := Facilities'Value (Args (Args'First .. Colon - 1)); Level := Levels'Value (Args (Colon + 1 .. Args'Last)); end if; end if; return new Syslog_Stream_Record' (Trace_Stream_Record with Facility => Facility, Level => Level); end New_Stream; ---------------------------- -- Register_Syslog_Stream -- ---------------------------- procedure Register_Syslog_Stream is Fact : constant Stream_Factory_Access := new Factory; begin Openlog (Base_Name (Ada.Command_Line.Command_Name), Customization => PID, Default_Facility => User); Register_Stream_Factory (Stream_Syslog, Fact); end Register_Syslog_Stream; ------------- -- Openlog -- ------------- procedure Openlog (Prefix : String; Customization : Options; Default_Facility : Facilities) is procedure Internal (Prefix : chars_ptr; Customization : Options; Facility : Integer); pragma Import (C, Internal, "openlog"); -- Low-level binding begin Lock; if C_Prefix /= Null_Ptr then Free (C_Prefix); end if; C_Prefix := New_String (Prefix); Internal (C_Prefix, Customization, Facilities_To_Integer (Default_Facility)); Unlock; end Openlog; ------------ -- Syslog -- ------------ procedure Syslog (Facility : Facilities := Kernel; Level : Levels := Emergency; Message : String) is -- We go through our own wrapper of syslog, because on some systems -- apparently we get a STORAGE_ERROR when interfacing directly to -- "syslog". procedure Internal (Priority : Integer; Message : String); pragma Import (C, Internal, "syslog_wrapper"); -- Low-level binding begin Internal (Levels_To_Integer (Level) + Facilities_To_Integer (Facility), Message & ASCII.NUL); end Syslog; -------------- -- Closelog -- -------------- procedure Closelog is procedure Internal; pragma Import (C, Internal, "closelog"); -- Low-level binding begin Lock; Internal; if C_Prefix /= Null_Ptr then Free (C_Prefix); end if; Unlock; end Closelog; end GNATCOLL.Traces.Syslog; gnatcoll-bindings-25.0.0/syslog/gnatcoll-traces-syslog.ads000066400000000000000000000160521464374334300236240ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2001-2017, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ -- Interface to syslog. -- This package provides two levels of interfaces: -- - a low level interface to syslog (on Unix systems) -- - a higher level interface that can be used through GNAT.Traces. -- syslog is the system logger on Unix systems. package GNATCOLL.Traces.Syslog is Stream_Syslog : constant String := "syslog"; -- Name of the stream that can be used in GNAT.Traces configuration files -- or calls to Create to send a stream to syslog. -- You must have called Register_Syslog_Stream (see below) first. procedure Register_Syslog_Stream; -- Register a GNAT.Traces stream that can send its output to the system -- logger syslog. This stream takes two optional arguments which are the -- facility and the level to pass to calls to Syslog (see below). -- For instance, your configuration file for GNAT.Traces could contains -- SYSLOG_ERROR=yes >&syslog:local0:error -- SYSLOG_INFO=yes >&syslog:local0:info -- and then your Ada code can use: -- Errors : Trace_Handle := Create ("SYSLOG_ERROR"); -- Info : Trace_Handle := Create ("SYSLOG_INFO"); -- Trace (Errors, "An error"); -- to send messages to syslog. Since GNAT.Traces can be configured -- dynamically, this means that the Errors stream defined above could be -- redirected for instance to stdout instead on systems where syslog is not -- supported. ----------------------------------- -- Low-level interface to syslog -- ----------------------------------- -- The following types and subprograms can be used if you need to interface -- directly to syslog. One drawback is that these are not usable (will not -- even exist) on systems that do not have syslog. -- -- A message sent to syslog has two attributes: its facility, and its -- level. The facility indicates what type of program is logging the -- message. This lets the syslog configuration file (system-wide) specify -- that messages from different facilities will be handled differently. -- The level determines the importance of the message. type Levels is (Emergency, -- system is unusable Alert, -- action must be taken immediately Critical, -- critical conditions Error, -- error conditions Warning, -- warning conditions Notice, -- normal but significant condition Info, -- informational Debug); -- debug-level messages -- Importance of the messages, in order of decreasing importance type Facilities is (Kernel, -- kernel messages User, -- random user-level messages Mail, -- mail system Daemon, -- system daemons Auth, -- security/authorization messages Sys_Log, -- messages generated internally Printer, -- line printer subsystem News, -- network news subsystem UUCP, -- UUCP subsystem Cron, -- clock daemon Auth_Priv, -- security/authorization messages FTP, -- ftp daemon NTP, -- ntp daemon Security, -- security subsystems Console, -- /dev/console output Local0, -- reserved for local use Local1, -- reserved for local use Local2, -- reserved for local use Local3, -- reserved for local use Local4, -- reserved for local use Local5, -- reserved for local use Local6, -- reserved for local use Local7); -- reserved for local use -- What type of program is logging the message type Options is mod Integer'Last; -- Options when opening the connection to syslog None : constant Options; -- no options at all PID : constant Options; -- log the pid with each message Cons : constant Options; -- log on the console if errors Open_Delay : constant Options; -- delay open() until first call to syslog() No_Delay : constant Options; -- don't delay open() No_Wait : constant Options; -- don't wait for console forks Std_Error : constant Options; -- log to stderr as well procedure Openlog (Prefix : String; Customization : Options; Default_Facility : Facilities); -- The (optional) call to this subprogram specifies the attributes of the -- connection to syslog. In particular, Prefix will be prepended to every -- message, and is in general used to specify the name of the program. -- Customization specifies flags to control the connection (in particular -- whether the PID of the process should be logged). -- Finally, Default_Facility will be used when the call to Syslog (see -- below) does not specify the facility. procedure Syslog (Facility : Facilities := Kernel; Level : Levels := Emergency; Message : String); -- Writes Message to the system logger. If Facility is left to its default -- value, the priority specified in the call to Openlog will be used -- instead. procedure Closelog; -- The (optional) call to this subprogram closes the connection with syslog private None : constant Options := 16#00#; PID : constant Options := 16#01#; Cons : constant Options := 16#02#; Open_Delay : constant Options := 16#04#; No_Delay : constant Options := 16#08#; No_Wait : constant Options := 16#10#; Std_Error : constant Options := 16#20#; end GNATCOLL.Traces.Syslog; gnatcoll-bindings-25.0.0/syslog/gnatcoll_syslog.gpr000066400000000000000000000075761464374334300224630ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2015-2020, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with "gnatcoll_core"; library project GnatColl_Syslog is Version := External ("GNATCOLL_VERSION", "0.0"); Name := "gnatcoll_syslog"; type Build_Type is ("DEBUG", "PROD"); Build : Build_Type := External ("GNATCOLL_BUILD_MODE", External ("BUILD", "PROD")); type Library_Type_Type is ("relocatable", "static", "static-pic"); Library_Type : Library_Type_Type := External ("LIBRARY_TYPE", "static"); for Source_Dirs use ("."); for Library_Kind use Library_Type; for Object_Dir use "obj/" & Project'Library_Kind; for Library_Dir use "lib/" & Project'Library_Kind; for Library_Name use Name; case Library_Type is when "relocatable" => for Library_Version use "lib" & Name & Gnatcoll_Core.So_Ext & "." & Version; for Leading_Library_Options use External_As_List ("LDFLAGS", " "); when others => null; end case; for Languages use ("Ada", "C"); package Compiler is case Build is when "DEBUG" => for Switches ("Ada") use ("-g", "-O0", "-gnata", "-gnatVa", "-gnatQ", "-gnaty", "-gnateE", "-gnatwaCJe", "-fstack-check"); for Switches ("C") use ("-g", "-Wunreachable-code"); when "PROD" => -- Do not use -gnatwe for production mode for Switches ("Ada") use ("-O2", "-gnatn", "-gnatwaCJ"); for Switches ("C") use ("-O2", "-Wunreachable-code"); end case; for Switches ("Ada") use Compiler'Switches ("Ada") & External_As_List ("ADAFLAGS", " "); for Switches ("C") use Compiler'Switches ("C") & External_As_List ("CFLAGS", " ") & External_As_List ("CPPFLAGS", " "); end Compiler; package Binder is case Build is when "DEBUG" => for Switches ("Ada") use ("-E"); when "PROD" => null; end case; end Binder; package Builder is case Build is when "DEBUG" => for Global_Configuration_Pragmas use "../gnat_debug.adc"; when "PROD" => null; end case; end Builder; package Ide is for VCS_Kind use "Git"; end Ide; end GnatColl_Syslog; gnatcoll-bindings-25.0.0/syslog/setup.py000077500000000000000000000042521464374334300202470ustar00rootroot00000000000000#!/usr/bin/env python import logging import os import sys sys.path.append(os.path.dirname(os.path.dirname(os.path.abspath(__file__)))) from setup_support import SetupApp class GNATCollSyslog(SetupApp): name = 'gnatcoll_syslog' project = 'gnatcoll_syslog.gpr' description = 'GNATColl Syslog bindings' def create(self): super(GNATCollSyslog, self).create() self.build_cmd.add_argument( '--debug', help='build project in debug mode', action="store_true", default=False) def update_config(self, config, args): logging.info('%-26s %s', 'Libraries kind', ", ".join(config.data['library_types'])) # Set library version with open(os.path.join(config.source_dir, '..', 'version_information'), 'r') as fd: version = fd.read().strip() config.set_data('GNATCOLL_VERSION', version, sub='gprbuild') # Set build mode config.set_data('BUILD', 'DEBUG' if args.debug else 'PROD', sub='gprbuild') logging.info('%-26s %s', 'Build mode', config.data['gprbuild']['BUILD']) # Set GNATCOLL_OS if 'darwin' in config.data['canonical_target']: gnatcoll_os = 'osx' elif 'windows' in config.data['canonical_target']: gnatcoll_os = 'windows' else: # Assume this is an Unix system gnatcoll_os = 'unix' config.set_data('GNATCOLL_OS', gnatcoll_os, sub='gprbuild') def variants(self, config, cmd): result = [] for library_type in config.data['library_types']: gpr_vars = {'LIBRARY_TYPE': library_type, 'XMLADA_BUILD': library_type, 'GPR_BUILD': library_type} if cmd == 'install': result.append((['--build-name=%s' % library_type, '--build-var=LIBRARY_TYPE'], gpr_vars)) else: result.append(([], gpr_vars)) return result if __name__ == '__main__': app = GNATCollSyslog() sys.exit(app.run()) gnatcoll-bindings-25.0.0/syslog/syslog_support.c000066400000000000000000000002551464374334300220110ustar00rootroot00000000000000/* * Syslog binding support * Copyright (C) 2017, AdaCore */ #include void syslog_wrapper(int priority, const char* msg) { syslog(priority, "%s", msg); } gnatcoll-bindings-25.0.0/testsuite/000077500000000000000000000000001464374334300172405ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/testsuite/README.md000066400000000000000000000117331464374334300205240ustar00rootroot00000000000000Running GNATcoll Testsuite ========================== `The testsuite is currently under construction !` Getting Started ------------------- To run it you need to have **Python** installed along with the package **e3-testsuite**. To install e3-testsuite: ```sh pip install git+https://github.com/AdaCore/e3-testsuite.git ``` Then do ```sh ./run-tests ``` By default the test suite will be run with the **GNATcoll** library found in the environment. A summary of the results will be displayed once the testsuite ends. Detailed results and logs can be found for each test in the `out/new` subdirectory. In this directory a **YaML** file will be created for each test. In order to have coverage information with **gcov**, just add `--gcov`. It will recompiles **GNATcoll** with coverage information and a summary of the coverage information will be displayed at the end of the test suite run. Full coverage information can be found in `gcov/results` subdirectory. Running the testsuite -------------------------- ### Partial Runs In some contexts, it might be useful to run only subsets of the testsuite. In order to do so you can use two different workflows. #### E3-test Call ``e3-test`` from any subdirectory of the testsuite will run only the tests contained in that directory. This workflow is useful when working for example in a single tests. By default you the testsuite will be run with default parameters, but you can adjust the default parameters by editing the **YaML** file called ``e3-test.yaml`` located in the root directory of the testsuite. The ``default_args`` can be used to add default parameters such as ``--gcov`` for example. #### Run-tests Call ``./run-tests`` with a list of test directories ### Which GNATcoll library is used ? If the testsuite is launched without any argument, then the **GNATcoll** from the user environment will be picked. If you add ``--gcov`` switch then **GNATcoll** will be recompiled using sources from your current checkout. This **GNATcoll** will be used for all tests except the one with the ``no-coverage`` marker in their description (see format of ``test.yaml`` section). Adding ``--recompile`` will recompile a **GNATcoll** library in production mode to be used by the testsuite. If both ``--gcov`` and ``--recompile`` are used then the production mode version of the library will be used only for tests with the ``no-coverage`` marker (might be useful for tests doing some performance measurement). ### Reference Run ``run-tests --help`` to get the full list of options Writing tests ------------- Testcases are found in the ``tests`` subdirectory. A testcase is a directory containing the a file called `test.yaml`. A ``test.yaml`` looks like: ```yaml # Mandatory description: My test description # Specify the test driver to be used. If not specified the default driver # called 'default' is used driver: driver_name ``` Some additional information which is driver specific might be present. To get a list of available drivers look for ``DRIVERS`` dictionary in run-tests script. From there you will be able to locate the **Python** class that implement that driver along with its docstring. ### The default driver In this readme we will only document the default driver. The default driver follow the following workflow: 1. Check if the test should be skipped. 2. If not build the test 3. Run the test and check that the output contains some expected patterns A minimal test should contains only one **Ada** unit called ``test.adb`` that contains a function ``Test``. The skeleton of that function should look like ```ada -- Following unit is provided by the testsuite in support subdirectory with Test_Assert; function Test return Integer is begin Test_Assert.Assert (True, "my test is ok :-)"); return Test_Assert.Report; end Test; ``` You can override the default project by creating a file called ``test.gpr`` in the test directory. You can also changed the name of the executable that is executed by setting the ``test_exe`` key in ``test.yaml`` (default value is ``obj/test``). For some specific case for which you never want to enable coverage instrumentation, just add ``no-coverage: True`` to ``test.yaml``. If you need some data files while running your tests, you need to specify them using the ``data`` key. For example: ```yaml description: Loading projects data: - "*.gpr" ``` Will copy all local ``.gpr`` files to the working directory before executing the test. Test can also be skipped based on a set of given conditions. For example: ```yaml description: A test skip: - ['XFAIL', 'env.build.os.name == "windows"'] ``` The skip entry is a list of tuple of the form (status, condition). If the condition (a **Python** expression) is True then test is skipped and test status set to ``status``. Note that currently only the following symbols are available in the conditions: ``env`` (a BaseEnv object), ``test_env`` (the test.yaml file as a **Python** dict) and the function ``disk_space`` (return the available disk space in the working directory). gnatcoll-bindings-25.0.0/testsuite/drivers/000077500000000000000000000000001464374334300207165ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/testsuite/drivers/__init__.py000066400000000000000000000146411464374334300230350ustar00rootroot00000000000000import logging import os import sys import traceback from e3.fs import mkdir from e3.os.fs import df from e3.os.process import Run from e3.testsuite.driver import TestDriver from e3.testsuite.process import check_call from e3.testsuite.result import TestStatus # Root directory of respectively the testsuite and the gnatcoll # repository. TESTSUITE_ROOT_DIR = os.path.dirname( os.path.dirname(os.path.abspath(__file__)) ) GNATCOLL_ROOT_DIR = os.path.dirname(TESTSUITE_ROOT_DIR) PROJECT = { "gmp": "gnatcoll_gmp.gpr", "iconv": "gnatcoll_iconv.gpr", "lzma": "gnatcoll_lzma.gpr", "omp": "gnatcoll_omp.gpr", "zlib": "gnatcoll_zlib.gpr", "cpp": "gnatcoll_cpp.gpr", } def make_gnatcoll(work_dir, build_mode, gcov=False): """Build gnatcoll core with or without gcov instrumentation. :param work_dir: working directory. gnatcoll is built in `build` subdir and installed in `install` subdir :type work_dir: str :param build_mode: build mode to use in order to build the gnatcoll project :param gcov: if True, build it with gcov instrumentation :type gcov: bool :return: a triplet (project path, source path, object path) :rtype: (str, str, str) :raise AssertError: in case compilation of installation fails """ params = f"({build_mode}, gcov={gcov})" # Create build tree structure build_dir = os.path.join(work_dir, "build") install_dir = os.path.join(work_dir, "install") mkdir(build_dir) mkdir(install_dir) # Compute make invocation for binding in PROJECT.keys(): logging.info(f"Compiling gnatcoll {binding} {params}") setup = os.path.join(GNATCOLL_ROOT_DIR, binding, "setup.py") obj_dir = os.path.join(build_dir, binding) mkdir(obj_dir) build_cmd = [sys.executable, setup, "build", "--library-types=static"] install_cmd = [ sys.executable, setup, "install", "--prefix", install_dir, ] if gcov: build_cmd += [ "--gpr-opts", "-cargs", "-fprofile-arcs", "-ftest-coverage", "-largs", "-lgcov", "-gargs", f"-XBUILD={build_mode}", ] else: build_cmd += ["--gpr-opts", f"-XBUILD={build_mode}"] # Build & Install p = Run(build_cmd, cwd=obj_dir) assert p.status == 0, "gnatcoll %s build failed:\n%s" % ( binding, p.out, ) logging.debug("build:\n%s", p.out) p = Run(install_cmd, cwd=obj_dir) assert p.status == 0, "gnatcoll %s installation failed:\n%s" % ( binding, p.out, ) logging.debug("install:\n%s", p.out) return ( os.path.join(install_dir, "share", "gpr"), os.path.join(install_dir, "include"), build_dir, ) def gprbuild( driver, project_file=None, cwd=None, gcov=False, scenario=None, gpr_project_path=None, **kwargs ): """Launch gprbuild. :param project_file: project file to compile. If None, we looks first for a test.gpr in the test dir and otherwise fallback on the common test.gpr project of the support subdir of the testsuite. :type project_file: str :param cwd: directory in which to run gprbuild. If None the gprbuild build is run in the default working dir for the test. :type cwd: str | None :param gcov: if True link with gcov libraries :type gcov: bool :param scenario: scenario variable values :type scenario: dict :param gpr_project_path: if not None prepent this value to GPR_PROJECT_PATH :type gpr_project_path: None | str :param kwargs: additional keyword arguements are passed to e3.testsuite.process.check_call function :return: True on successful completion :rtype: bool """ if scenario is None: scenario = {} if cwd is None: cwd = driver.test_env["working_dir"] mkdir(cwd) if project_file is None: project_file = os.path.join(driver.test_env["test_dir"], "test.gpr") if not os.path.isfile(project_file): project_file = os.path.join(cwd, "test.gpr") with open( os.path.join(TESTSUITE_ROOT_DIR, "support", "test.gpr"), "r" ) as fd: content = fd.read() with open(project_file, "w") as fd: for component in driver.test_env.get("components", []): fd.write('with "%s";\n' % PROJECT[component]) fd.write(content) scenario["TEST_SOURCES"] = driver.test_env["test_dir"] scenario["SUPPORT_SOURCES"] = os.path.join(TESTSUITE_ROOT_DIR, "support") gprbuild_cmd = [ "gprbuild", "--relocate-build-tree", "-p", "-P", project_file, ] for k, v in scenario.items(): gprbuild_cmd.append("-X%s=%s" % (k, v)) if gcov: gprbuild_cmd += [ "-largs", "-lgcov", "-cargs", "-fprofile-arcs", "-ftest-coverage", "-g", ] # Adjust process environment env = None if gpr_project_path: new_gpr_path = gpr_project_path if "GPR_PROJECT_PATH" in os.environ: new_gpr_path += os.path.pathsep + os.environ["GPR_PROJECT_PATH"] env = {"GPR_PROJECT_PATH": new_gpr_path} check_call( driver, gprbuild_cmd, cwd=cwd, env=env, ignore_environ=False, **kwargs ) # If we get there it means the build succeeded. return True class GNATcollTestDriver(TestDriver): """Abstract class to share some common facilities.""" def should_skip(self): """Handle of 'skip' in test.yaml. :return: None if the test should not be skipped, a TestStatus otherwise. :rtype: None | TestStatus """ if "skip" in self.test_env: eval_env = { "env": self.env, "test_env": self.test_env, "disk_space": lambda: df(self.env.working_dir), } for status, expr in self.test_env["skip"]: try: if eval(expr, eval_env): return TestStatus[status] except Exception: logging.error(traceback.format_exc()) return TestStatus.ERROR return None gnatcoll-bindings-25.0.0/testsuite/drivers/basic.py000066400000000000000000000044301464374334300223520ustar00rootroot00000000000000import os from e3.fs import cp from e3.testsuite.result import TestStatus from drivers import gprbuild, GNATcollTestDriver from drivers.valgrind import check_call_valgrind class BasicTestDriver(GNATcollTestDriver): """Default GNATcoll testsuite driver. In order to declare a test: 1- Create a directory with a test.yaml inside 2- Add test sources in that directory 3- Add a main called test.adb that use support/test_assert.ads package. 4- Do not put test.gpr there, it breaks the test, if you need a project file for testing, name it something else. 5- If you need additional files for you test, list them in test.yaml: data: - "your_file1" - "your_file2" """ def add_test(self, dag): """Declare test workflow. The workflow is the following:: build --> check status :param dag: tree of test fragment to amend :type dag: e3.collection.dag.DAG """ self.add_fragment(dag, "build") self.add_fragment(dag, "check_run", after=["build"]) if "test_exe" not in self.test_env: self.test_env["test_exe"] = "obj/test" def build(self, previous_values, slot): """Build fragment.""" if self.test_env.get("no-coverage"): gpr_project_path = self.env.gnatcoll_prod_gpr_dir else: gpr_project_path = self.env.gnatcoll_gpr_dir return gprbuild( self, gcov=self.env.gcov, gpr_project_path=gpr_project_path ) def check_run(self, previous_values, slot): """Check status fragment.""" if not previous_values["build"]: return for data in self.test_env.get("data", []): cp( os.path.join(self.test_env["test_dir"], data), self.test_env["working_dir"], recursive=True, ) process = check_call_valgrind( self, [ os.path.join( self.test_env["working_dir"], self.test_env["test_exe"] ) ], ) if "<=== TEST PASSED ===>" not in process.out: self.result.set_status(TestStatus.FAIL) else: self.result.set_status(TestStatus.PASS) self.push_result() gnatcoll-bindings-25.0.0/testsuite/drivers/valgrind.py000066400000000000000000000010701464374334300230740ustar00rootroot00000000000000from e3.testsuite.process import check_call def check_call_valgrind(driver, cmd, test_name=None, result=None, **kwargs): """ Wrapper for `e3.testsuite.process` that runs the process under Valgrind if this is a Valgrind-checked testsuite run. The process exit status will be 2 if Valgrind finds memory issues. """ if driver.env.valgrind: cmd = [ "valgrind", "-q", "--error-exitcode=2", "--leak-check=full", ] + cmd return check_call(driver, cmd, test_name, result, **kwargs) gnatcoll-bindings-25.0.0/testsuite/e3-test.yaml000066400000000000000000000000411464374334300214030ustar00rootroot00000000000000main: run-tests default_args: [] gnatcoll-bindings-25.0.0/testsuite/support/000077500000000000000000000000001464374334300207545ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/testsuite/support/test.gpr000066400000000000000000000010251464374334300224430ustar00rootroot00000000000000-- Default project use for tests -- -- The scenario variable TEST_SOURCES is automatically set by the -- driver to point to the test sources. with "gnatcoll_core"; project Test is Test_Sources := External("TEST_SOURCES"); Support_Sources := External("SUPPORT_SOURCES"); for Source_Dirs use (".", Test_Sources, Support_Sources); for Main use ("test.adb"); for Languages use ("Ada", "C"); for Object_Dir use "obj"; package Compiler is for Default_Switches ("Ada") use ("-g"); end Compiler; end Test; gnatcoll-bindings-25.0.0/testsuite/support/test_assert.adb000066400000000000000000000063131464374334300237670ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2018, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; package body Test_Assert is package IO renames Ada.Text_IO; ------------ -- Assert -- ------------ procedure Assert (Success : Boolean; Msg : String := ""; Location : String := SI.Source_Location) is begin IO.Put (Location & ": "); if Success then IO.Put ("PASSED:"); else IO.Put ("FAILED:"); Final_Status := 1; end if; if Msg'Length > 0 then IO.Put (" "); IO.Put (Msg); end if; IO.New_Line; end Assert; ------------ -- Assert -- ------------ procedure Assert (Left, Right : String; Msg : String := ""; Location : String := SI.Source_Location) is Success : constant Boolean := Left = Right; begin Assert (Success, Msg, Location); if not Success then if Right'Length > 0 then IO.Put_Line ("expected: " & Right); else IO.Put_Line ("expected empty string"); end if; if Left'Length > 0 then IO.Put_Line ("got: " & Left); else IO.Put_Line ("got empty string"); end if; end if; end Assert; ------------ -- Report -- ------------ function Report return Natural is begin if Final_Status = 0 then IO.Put_Line ("<=== TEST PASSED ===>"); else IO.PUT_Line ("<=== TEST FAILED ===>"); end if; return Final_Status; end Report; end Test_Assert; gnatcoll-bindings-25.0.0/testsuite/support/test_assert.ads000066400000000000000000000055711464374334300240150ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2018, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ -- Helper package to implement tests that comply with the expectations -- of the default test driver. with GNAT.Source_Info; package Test_Assert is package SI renames GNAT.Source_Info; Final_Status : Natural := 0; procedure Assert (Success : Boolean; Msg : String := ""; Location : String := SI.Source_Location); -- If Success is True then test case is considered PASSED, otherwise -- the test status is FAILED and Final_Status set to 1. procedure Assert (Left, Right : String; Msg : String := ""; Location : String := SI.Source_Location); -- If Left = Right then test case is considered PASSED, otherwise -- the test status is FAILED and Final_Status set to 1. function Report return Natural; -- Report should be called the following way at the end of a test -- program main function: -- -- return Report; -- -- Testsuite driver will consider a test to PASS if all the -- following conditions are met: -- -- * test program exit with status 0 -- * all assert calls did succeed -- * test program display the message "<=== TEST PASSED ===>" end Test_Assert; gnatcoll-bindings-25.0.0/testsuite/support/test_remote.adb000066400000000000000000000145721464374334300237670ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2018, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with GNAT.OS_Lib; with GNAT.Directory_Operations; with GNAT.Expect; with GNAT.Expect.TTY; with Ada.Text_IO; with GNATCOLL.Utils; package body Test_Remote is package Expect renames GNAT.Expect; package OS renames GNAT.OS_Lib; package OS_Path renames GNAT.Directory_Operations; package IO renames Ada.Text_IO; use type GVT.FS_String; -------------- -- Nickname -- -------------- function Nickname (Server : Local_Transport) return String is begin return "local"; end Nickname; -------------- -- Shell_FS -- -------------- function Shell_FS (Server : Local_Transport) return GVT.FS_Type is begin return GVT.FS_Unix; end Shell_FS; ---------------------- -- Execute_Remotely -- ---------------------- procedure Execute_Remotely (Server : access Local_Transport; Args : GNAT.Strings.String_List; Status : out Boolean; Execution_Directory : GVT.FS_String := "") is CWD : constant String := OS_Path.Get_Current_Dir; Script : constant String := GNATCOLL.Utils.Join (" ", Args); Program_Name : constant String := "/bin/bash"; Program_Args : GNAT.Strings.String_List (1 .. 2) := (1 => new String'("-c"), 2 => new String'(Script)); begin if Execution_Directory /= "" then OS_Path.Change_Dir (String (Execution_Directory)); end if; OS.Spawn (Program_Name, Program_Args, Status); if Execution_Directory /= "" then OS_Path.Change_Dir (String (CWD)); end if; end Execute_Remotely; ---------------------- -- Execute_Remotely -- ---------------------- procedure Execute_Remotely (Server : access Local_Transport; Args : GNAT.Strings.String_List; Result : out GNAT.Strings.String_Access; Status : out Boolean; Execution_Directory : GVT.FS_String := "") is CWD : constant String := OS_Path.Get_Current_Dir; Program_Name : constant String := Args (1).all; Program_Args : constant GNAT.Strings.String_List := Args (2 .. Args'Last); Int_Status : aliased Integer; begin if Execution_Directory /= "" then OS_Path.Change_Dir (String (Execution_Directory)); end if; IO.Put_Line (Program_Name); Result := new String' (Expect.Get_Command_Output (Program_Name, Program_Args, "", Int_Status'Access, True)); if Int_Status = 0 then Status := True; else Status := False; end if; if Execution_Directory /= "" then OS_Path.Change_Dir (String (CWD)); end if; end Execute_Remotely; -------------------- -- Spawn_Remotely -- -------------------- procedure Spawn_Remotely (Server : access Local_Transport; Descriptor : out GNAT.Expect.Process_Descriptor_Access; Args : GNAT.Strings.String_List) is Program_Name : constant String := Args (1).all; Program_Args : constant GNAT.Strings.String_List := Args (2 .. Args'Last); begin Descriptor := new GNAT.Expect.TTY.TTY_Process_Descriptor; IO.Put_Line (Program_Name); Expect.Non_Blocking_Spawn (Descriptor.all, Program_Name, Program_Args); end Spawn_Remotely; ------------------- -- Is_Configured -- ------------------- function Is_Configured (Config : Local_DB; Nickname : String) return Boolean is begin if Nickname = "local_test" then return True; else return False; end if; end Is_Configured; ---------------- -- Get_Server -- ---------------- function Get_Server (Config : Local_DB; Nickname : String) return GR.Server_Access is begin return new Local_Transport; end Get_Server; --------------------- -- Nb_Mount_Points -- --------------------- function Nb_Mount_Points (Config : Local_DB; Nickname : String) return Natural is begin return 1; end Nb_Mount_Points; -------------------------------- -- Get_Mount_Point_Local_Root -- -------------------------------- function Get_Mount_Point_Local_Root (Config : Local_DB; Nickname : String; Index : Natural) return GVT.FS_String is begin return "/tmp/local_vfs"; end Get_Mount_Point_Local_Root; ------------------------------- -- Get_Mount_Point_Host_Root -- ------------------------------- function Get_Mount_Point_Host_Root (Config : Local_DB; Nickname : String; Index : Natural) return GVT.FS_String is begin return "/tmp/remote_vfs"; end Get_Mount_Point_Host_Root; end Test_Remote; gnatcoll-bindings-25.0.0/testsuite/support/test_remote.ads000066400000000000000000000074351464374334300240100ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2018, 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 package provides remote support using only local resources. This -- allows to test remote functionalities without the need for a remote host. with GNAT.Expect; with GNAT.Strings; with GNATCOLL.Remote; with GNATCOLL.VFS_Types; with GNATCOLL.Remote.DB; package Test_Remote is package GR renames GNATCOLL.Remote; package GRDB renames GNATCOLL.Remote.DB; package GVT renames GNATCOLL.VFS_Types; -- Declare local transport protocol (basically spawn /bin/bash) type Local_Transport is new GR.Server_Record with null record; function Nickname (Server : Local_Transport) return String; function Shell_FS (Server : Local_Transport) return GVT.FS_Type; procedure Execute_Remotely (Server : access Local_Transport; Args : GNAT.Strings.String_List; Status : out Boolean; Execution_Directory : GVT.FS_String := ""); procedure Execute_Remotely (Server : access Local_Transport; Args : GNAT.Strings.String_List; Result : out GNAT.Strings.String_Access; Status : out Boolean; Execution_Directory : GVT.FS_String := ""); procedure Spawn_Remotely (Server : access Local_Transport; Descriptor : out GNAT.Expect.Process_Descriptor_Access; Args : GNAT.Strings.String_List); -- Declare local remote database which holds only one host nickname -- called local_test type Local_DB is new GRDB.Remote_Db_Interface with null record; function Is_Configured (Config : Local_DB; Nickname : String) return Boolean; function Get_Server (Config : Local_DB; Nickname : String) return GR.Server_Access; function Nb_Mount_Points (Config : Local_DB; Nickname : String) return Natural; function Get_Mount_Point_Local_Root (Config : Local_DB; Nickname : String; Index : Natural) return GVT.FS_String; function Get_Mount_Point_Host_Root (Config : Local_DB; Nickname : String; Index : Natural) return GVT.FS_String; end Test_Remote; gnatcoll-bindings-25.0.0/testsuite/tests/000077500000000000000000000000001464374334300204025ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/testsuite/tests/coders/000077500000000000000000000000001464374334300216615ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/testsuite/tests/coders/save_streams.adb000066400000000000000000000036101464374334300250250ustar00rootroot00000000000000package body Save_Streams is ---------- -- Read -- ---------- overriding procedure Read (Stream : in out Stream_Type; Item : out Stream_Element_Array; Last : out Stream_Element_Offset) is Length : constant Integer := Natural'Min (Item'Length, Stream.Buffer.Length - Stream.Position); Target : String (1 .. Integer'Max (Length, 0)); for Target'Address use Item'Address; begin if Target = "" then Last := Item'First - 1; return; end if; Target := To_String (Stream.Buffer.Slice (Stream.Position + 1, Stream.Position + Length)); Stream.Position := Stream.Position + Length; Last := Item'First + Stream_Element_Offset (Length) - 1; end Read; ----------- -- Write -- ----------- overriding procedure Write (Stream : in out Stream_Type; Item : Stream_Element_Array) is Source : String (1 .. Item'Length); for Source'Address use Item'Address; begin Stream.Buffer.Append (Source); end Write; ----------- -- Clear -- ----------- procedure Clear (Stream : in out Stream_Type) is begin Stream.Buffer.Clear; Stream.Reset; end Clear; ----------------------- -- Remove_Last_Bytes -- ----------------------- procedure Remove_Last_Bytes (Stream : in out Stream_Type; Count : Natural) is begin Stream.Buffer := Stream.Buffer.Head (Stream.Buffer.Length - Count); end Remove_Last_Bytes; ----------- -- Reset -- ----------- procedure Reset (Stream : in out Stream_Type) is begin Stream.Position := 0; end Reset; ----------- -- Slice -- ----------- function Slice (Stream : Stream_Type; Low : Positive; High : Natural) return String is begin return To_String (Stream.Buffer.Slice (Low, High)); end Slice; end Save_Streams; gnatcoll-bindings-25.0.0/testsuite/tests/coders/save_streams.ads000066400000000000000000000020031464374334300250410ustar00rootroot00000000000000with Ada.Streams; use Ada.Streams; with GNATCOLL.Strings; use GNATCOLL.Strings; package Save_Streams is type Stream_Type is new Root_Stream_Type with private; -- Stream reading the data which was wrote there before overriding procedure Read (Stream : in out Stream_Type; Item : out Stream_Element_Array; Last : out Stream_Element_Offset); overriding procedure Write (Stream : in out Stream_Type; Item : Stream_Element_Array); procedure Reset (Stream : in out Stream_Type); -- Reset read position to the start of data procedure Clear (Stream : in out Stream_Type); -- Clear all internal written data from stream function Slice (Stream : Stream_Type; Low : Positive; High : Natural) return String; procedure Remove_Last_Bytes (Stream : in out Stream_Type; Count : Natural); private type Stream_Type is new Root_Stream_Type with record Position : Natural := 0; Buffer : XString; end record; end Save_Streams; gnatcoll-bindings-25.0.0/testsuite/tests/coders/test.adb000066400000000000000000000237261464374334300233220ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2019, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Calendar; with Ada.Exceptions; with Ada.Streams; use Ada.Streams; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with Ada.Text_IO; use Ada.Text_IO; with GNATCOLL.Coders.LZMA; use GNATCOLL.Coders; with GNATCOLL.Coders.ZLib; with GNATCOLL.Coders.Streams; with GNATCOLL.Paragraph_Filling; with Save_Streams; with Test_Streams; with Test_Assert; function Test return Integer is package A renames Test_Assert; subtype Coder_Class is Coder_Interface'Class; Coder_X : aliased LZMA.Coder_Type; Back_X : aliased LZMA.Coder_Type; Coder_Z : aliased ZLib.Coder_Type; Back_Z : aliased ZLib.Coder_Type; Gettysburg : constant String := "Four score and seven years ago our fathers brought forth on this" & " continent a new nation, conceived in liberty, and dedicated to the" & " proposition that all men are created equal. Now we are engaged in a" & " great civil war, testing whether that nation, or any nation so" & " conceived and so dedicated, can long endure. We are met on a great" & " battlefield of that war. We have come to dedicate a portion of that" & " field, as a final resting place for those who here gave their lives" & " that that nation might live. It is altogether fitting and proper that" & " we should do this. But, in a larger sense, we can not dedicate, we" & " can not consecrate, we can not hallow this ground. The brave men," & " living and dead, who struggled here, have consecrated it, far above" & " our poor power to add or detract. The world will little note, nor" & " long remember what we say here, but it can never forget what they did" & " here. It is for us the living, rather, to be dedicated here to the" & " unfinished work which they who fought here have thus far so nobly" & " advanced. It is rather for us to be here dedicated to the great task" & " devotion to that cause for which they gave the last full measure of" & " people, shall not perish from the earth."; Formatted : constant String := To_String (GNATCOLL.Paragraph_Filling.Knuth_Fill (Gettysburg)); Source : Stream_Element_Array (1 .. Formatted'Length); for Source'Address use Formatted'Address; Encoded : Stream_Element_Array (1 .. Formatted'Length); Last : Stream_Element_Offset; O, L : Stream_Element_Offset; procedure Encode (Coder : in out Coder_Class); procedure Decode (Coder : in out Coder_Class); procedure Test_Stream_Coder (Coder, Back : in out Coder_Class); ------------ -- Encode -- ------------ procedure Encode (Coder : in out Coder_Class) is begin -- Compress the whole source once Coder.Transcode (Source, Last, Encoded, L, Finish); A.Assert (Last = Source'Last, "Compressed at once"); end Encode; ------------ -- Decode -- ------------ procedure Decode (Coder : in out Coder_Class) is Restored : Stream_Element_Array (Source'Range); Block_Size : constant := 4; P : Stream_Element_Offset := Encoded'First - 1; -- This makes sure that the last block contains -- only Adler checksum data for zlib begin -- Now we decompress the data, passing short blocks of data to Zlib -- (because this demonstrates the problem - the last block passed will -- contain checksum information and there will be no output, only a -- check inside Zlib that the checksum is correct). loop Coder.Transcode (Encoded (P + 1 .. Stream_Element_Offset'Min (P + Block_Size, L)), P, Restored (Stream_Element_Offset (Coder.Total_Out + 1) .. Restored'Last), O, No_Flush); exit when P = L; end loop; A.Assert (Restored = Source, "Decompressed text matches original text"); end Decode; ----------------------- -- Test_Stream_Coder -- ----------------------- procedure Test_Stream_Coder (Coder, Back : in out Coder_Class) is Test_Stream : aliased Test_Streams.Stream_Type; Coder_Stream : Streams.Stream_Type; Test_2_Flush : Boolean := True; begin Test_Stream.Set_Limit (2_000_000); Coder_Stream.Initialize (Read_Coder => Coder'Unchecked_Access, Write_Coder => Back'Unchecked_Access, Read_From => Test_Stream'Unchecked_Access, Write_To => Test_Stream'Unchecked_Access); loop declare Buffer : Stream_Element_Array (1 .. 4000); Last : Stream_Element_Offset; begin Coder_Stream.Read (Buffer, Last); Coder_Stream.Write (Buffer (1 .. Last)); exit when Coder_Stream.End_Of_Input; if Test_2_Flush and then Coder.Total_Out > 16000 then loop Coder_Stream.Flush_Read (Buffer, Last); Coder_Stream.Write (Buffer (1 .. Last)); exit when Last < Buffer'Last; end loop; Coder_Stream.Flush_Read (Buffer, Last); A.Assert (Last = Buffer'First - 1, "Flushed"); Coder_Stream.Flush_Read (Buffer, Last); A.Assert (Last = Buffer'First - 1, "Flushed"); Test_2_Flush := False; end if; -- Put_Line (Coder.Total_In'Img & Coder.Total_Out'Img); end; end loop; loop declare Buffer : Stream_Element_Array (1 .. 4000); Last : Stream_Element_Offset; begin Coder_Stream.Flush_Read (Buffer, Last, Finish); Coder_Stream.Write (Buffer (1 .. Last)); exit when Last < Buffer'Last; end; end loop; Coder_Stream.Flush (Finish); end Test_Stream_Coder; ------------------ -- Another_Test -- ------------------ procedure Another_Test (Coder, Back : in out Coder_Class; Remove_Tail : Natural) is Save_Stream : aliased Save_Streams.Stream_Type; Coder_Stream : Streams.Stream_Type; Got_Back : Stream_Element_Array (Source'First .. Source'Last + 1); Last : Stream_Element_Offset; begin Coder_Stream.Initialize (Write_Coder => Coder'Unchecked_Access, Write_To => Save_Stream'Unchecked_Access); Coder_Stream.Write (Source); Coder_Stream.Flush (Finish); Coder_Stream.Initialize (Read_Coder => Back'Unchecked_Access, Read_From => Save_Stream'Unchecked_Access); Put_Line ("Remove tail" & Remove_Tail'Img); Save_Stream.Remove_Last_Bytes (Remove_Tail); Coder_Stream.Read (Got_Back, Last); A.Assert (Source = Got_Back (Got_Back'First .. Last), "compare with data got back"); end Another_Test; begin ----------------- -- LZMA tests -- ----------------- Coder_X.Encoder; Encode (Coder_X); Coder_X.Auto_Decoder; Decode (Coder_X); for T in 1 .. 3 loop Coder_X.Encoder (Threads => T); Back_X.Auto_Decoder; declare use Ada.Calendar; Stamp : constant Time := Clock; begin Test_Stream_Coder (Coder_X, Back_X); Put_Line (T'Img & Duration'Image (Clock - Stamp)); end; end loop; for J in 0 .. 2 loop Coder_X.Encoder (Threads => 2); Back_X.Auto_Decoder; begin Another_Test (Coder_X, Back_X, J); A.Assert (J = 0, "Expected success on holistic data"); exception when E : LZMA.LZMA_Error => A.Assert (J > 0, "Expected failure on truncated data " & Ada.Exceptions.Exception_Message (E)); end; end loop; ----------------- -- ZLib tests -- ----------------- Coder_Z.Deflate_Init; Encode (Coder_Z); Coder_Z.Inflate_Init; Decode (Coder_Z); Coder_Z.Deflate_Init; Back_Z.Inflate_Init; Test_Stream_Coder (Coder_Z, Back_Z); for J in 0 .. 2 loop Coder_Z.Deflate_Init; Back_Z.Inflate_Init; begin Another_Test (Coder_Z, Back_Z, J); A.Assert (J = 0, "Expected success on holistic data"); exception when E : ZLib.ZLib_Error => A.Assert (J > 0, "Expected failure on truncated data " & Ada.Exceptions.Exception_Message (E)); end; end loop; return A.Report; end Test; gnatcoll-bindings-25.0.0/testsuite/tests/coders/test.gpr000066400000000000000000000006731464374334300233600ustar00rootroot00000000000000with "gnatcoll_core"; with "gnatcoll_lzma"; with "gnatcoll_zlib"; project Test is for Main use ("test.adb"); for Source_Dirs use (".", "../../support"); for Object_Dir use "obj"; package Compiler is for Switches ("Ada") use ("-g", "-gnateE"); end Compiler; package Linker is for Switches ("Ada") use ("-g"); end Linker; package Binder is for Switches ("Ada") use ("-E"); end Binder; end Test; gnatcoll-bindings-25.0.0/testsuite/tests/coders/test.yaml000066400000000000000000000000461464374334300235240ustar00rootroot00000000000000description: Test for GNATCOLL.Coders gnatcoll-bindings-25.0.0/testsuite/tests/coders/test_streams.adb000066400000000000000000000045001464374334300250450ustar00rootroot00000000000000with Ada.Text_IO; use Ada.Text_IO; package body Test_Streams is function Next_Stream_Element (G : in out Generator; Remain : in out XString) return Stream_Element; ------------------------- -- Next_Stream_Element -- ------------------------- function Next_Stream_Element (G : in out Generator; Remain : in out XString) return Stream_Element is S : State; E : Stream_Element; begin if Remain.Is_Empty then Remain := To_XString (ASCII.LF & Float'Image (Random (G))); Save (G, S); Remain.Append (Image (S) (1 .. 100)); end if; E := Character'Pos (Remain (Remain.Length)); Remain.Slice (1, Remain.Length - 1); return E; end Next_Stream_Element; --------------- -- Set_Limit -- --------------- procedure Set_Limit (Stream : in out Stream_Type; Limit : Stream_Element_Count) is begin Stream.Limit := Limit; end Set_Limit; ---------- -- Read -- ---------- overriding procedure Read (Stream : in out Stream_Type; Item : out Stream_Element_Array; Last : out Stream_Element_Offset) is begin if not Stream.Read_Started then Stream.Read_Started := True; Reset (Stream.Read_Generator); Save (Stream.Read_Generator, Stream.Init_State); end if; Last := Item'First - 1; while Last < Item'Last and then Stream.Limit > 0 loop Last := Last + 1; Stream.Limit := Stream.Limit - 1; Item (Last) := Next_Stream_Element (Stream.Read_Generator, Stream.Read_Remain); end loop; end Read; ----------- -- Write -- ----------- overriding procedure Write (Stream : in out Stream_Type; Item : Stream_Element_Array) is begin if not Stream.Write_Started then Stream.Write_Started := True; Reset (Stream.Write_Generator, Stream.Init_State); end if; for J in Item'Range loop if Item (J) /= Next_Stream_Element (Stream.Write_Generator, Stream.Write_Remain) then Put_Line ("Random initialization state to restore the bug:"); Put_Line (Image (Stream.Init_State)); raise Program_Error with "Data differ"; end if; end loop; end Write; end Test_Streams; gnatcoll-bindings-25.0.0/testsuite/tests/coders/test_streams.ads000066400000000000000000000022401464374334300250650ustar00rootroot00000000000000with Ada.Streams; use Ada.Streams; with Ada.Numerics.Float_Random; use Ada.Numerics.Float_Random; with GNATCOLL.Strings; use GNATCOLL.Strings; package Test_Streams is type Stream_Type is new Root_Stream_Type with private; -- Stream checking that all data taken from Read have to be the same -- accepted by Write. overriding procedure Read (Stream : in out Stream_Type; Item : out Stream_Element_Array; Last : out Stream_Element_Offset); overriding procedure Write (Stream : in out Stream_Type; Item : Stream_Element_Array); procedure Set_Limit (Stream : in out Stream_Type; Limit : Stream_Element_Count); -- Set the data limit to get from Read routine. private type Stream_Type is new Root_Stream_Type with record Read_Started : Boolean := False; Write_Started : Boolean := False; Limit : Stream_Element_Count := Stream_Element_Count'Last; Read_Generator : Generator; Write_Generator : Generator; Init_State : State; Read_Remain : XString; Write_Remain : XString; end record; end Test_Streams; gnatcoll-bindings-25.0.0/testsuite/tests/cpp_strings/000077500000000000000000000000001464374334300227355ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/testsuite/tests/cpp_strings/test.adb000066400000000000000000001057031464374334300243720ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Text_IO; with Interfaces.C.Strings; with GNATCOLL.CPP.Strings; with Test_Assert; use Test_Assert; function Test return Integer is use Ada.Text_IO; use Interfaces.C; use Interfaces.C.Strings; use GNATCOLL.CPP.Strings; ------------------- -- Output_Header -- ------------------- procedure Output_Header (Msg : String) is Dots : String (1 .. 60) := (others => '.'); begin Put (Msg); Put (Dots (1 .. Dots'Length - Msg'Length)); end Output_Header; ----------------------------------------------------- -- Constructors, Data(), Size() and Length() Tests -- ----------------------------------------------------- procedure Test_01 is Str : CPP_String := New_CPP_String; begin Assert (Data (Str) = "" and then Size (Str) = 0 and then Length (Str) = 0); Free (Str); end Test_01; procedure Test_02 is Str : CPP_String := New_CPP_String ("Ada & C++"); begin Assert (Data (Str) = "Ada & C++" and then Size (Str) = 9 and then Length (Str) = 9); Free (Str); end Test_02; procedure Test_03 is Str_1 : CPP_String := New_CPP_String ("Ada & C++"); Str_2 : CPP_String := New_CPP_String (Str_1); begin Assert (Data (Str_2) = "Ada & C++" and then Size (Str_2) = 9 and then Length (Str_2) = 9); Free (Str_1); Free (Str_2); end Test_03; procedure Test_04 is C_Ptr : chars_ptr := New_String ("Ada & C++"); Str : CPP_String := New_CPP_String (C_Ptr); begin Assert (Data (Str) = "Ada & C++" and then Size (Str) = 9 and then Length (Str) = 9); Free (C_Ptr); Free (Str); end Test_04; procedure Test_05 is Str : CPP_String := New_CPP_String (10, '*'); begin Assert (Data (Str) = "**********" and then Size (Str) = 10 and then Length (Str) = 10); Free (Str); end Test_05; ------------------------- -- Tests of Capacity() -- ------------------------- procedure Test_06 is Str : CPP_String := New_CPP_String ("Ada"); begin Assert (Data (Str) = "Ada" and then Size (Str) = 3 and then Capacity (Str) >= Size (Str) and then Max_Size (Str) > Capacity (Str)); Free (Str); end Test_06; procedure Test_07 is Str : CPP_String := New_CPP_String ("Ada"); begin Assert (Data (Str) = "Ada" and then Size (Str) = 3 and then Capacity (Str) >= Size (Str) and then Max_Size (Str) > Capacity (Str)); Free (Str); end Test_07; ----------------------- -- Tests of Resize() -- ----------------------- procedure Test_08 is Str : CPP_String := New_CPP_String ("Ada & C++"); begin Resize (Str, 3); Assert (Data (Str) = "Ada" and then Size (Str) = 3); Free (Str); end Test_08; procedure Test_09 is Str : CPP_String := New_CPP_String ("Ada"); Init_Size : constant Size_T := Size (Str); begin Resize (Str, 2 * Init_Size); Assert (Data (Str) = "Ada" and then Size (Str) = 2 * Init_Size and then Length (Str) = 2 * Init_Size); Free (Str); end Test_09; procedure Test_10 is Str : CPP_String := New_CPP_String ("Ada"); begin Resize (Str, 6, '-'); Assert (Data (Str) = "Ada---" and then Size (Str) = 6 and then Length (Str) = 6); Free (Str); end Test_10; ------------------------ -- Tests of Reserve() -- ------------------------ procedure Test_11 is Str : CPP_String := New_CPP_String ("Ada"); Init_Capacity : constant Size_T := Capacity (Str); begin Reserve (Str, Init_Capacity + 5); Assert (Capacity (Str) >= Init_Capacity + 5); Free (Str); end Test_11; ---------------------------------- -- Tests of Clear() and Empty() -- ---------------------------------- procedure Test_12 is Str : CPP_String := New_CPP_String ("Ada"); begin Clear (Str); Assert (Data (Str) = "" and then Size (Str) = 0 and then Length (Str) = 0 and then Empty (Str)); Free (Str); end Test_12; ------------------------ -- Tests of Char_At() -- ------------------------ procedure Test_13 is Str : CPP_String := New_CPP_String ("abcd"); begin Assert (Char_At (Str, 0) = 'a' and then Char_At (Str, 1) = 'b' and then Char_At (Str, 2) = 'c' and then Char_At (Str, 3) = 'd'); Free (Str); end Test_13; ----------------------- -- Tests of Append() -- ----------------------- procedure Test_14 is Str : CPP_String := New_CPP_String; begin Append (Str, "Ada"); Append (Str, " & C++"); Assert (Data (Str) = "Ada & C++" and then Size (Str) = 9 and then Length (Str) = 9); Free (Str); end Test_14; procedure Test_15 is Str : CPP_String := New_CPP_String; Str_1 : CPP_String := New_CPP_String ("Ada"); Str_2 : CPP_String := New_CPP_String (" & C++"); begin Append (Str, Str_1); Append (Str, Str_2); Assert (Data (Str) = "Ada & C++" and then Size (Str) = 9 and then Length (Str) = 9); Free (Str_1); Free (Str_2); Free (Str); end Test_15; procedure Test_16 is Str : CPP_String := New_CPP_String; C_Ptr_1 : chars_ptr := New_String ("Ada"); C_Ptr_2 : chars_ptr := New_String (" & C++"); begin Append (Str, C_Ptr_1); Append (Str, C_Ptr_2); Assert (Data (Str) = "Ada & C++" and then Size (Str) = 9 and then Length (Str) = 9); Free (C_Ptr_1); Free (C_Ptr_2); Free (Str); end Test_16; procedure Test_17 is Str_1 : CPP_String := New_CPP_String ("Ada"); Str_2 : CPP_String := New_CPP_String (" Programming"); begin Append (Str_1, Str_2, Subpos => 4, Sublen => 4); Assert (Data (Str_1) = "Adagram" and then Size (Str_1) = 7 and then Length (Str_1) = 7); Free (Str_1); Free (Str_2); end Test_17; procedure Test_18 is Str : CPP_String := New_CPP_String ("Ada"); C_Ptr : chars_ptr := New_String (" Programming"); begin Append (Str, C_Ptr, N => 8); Assert (Data (Str) = "Ada Program" and then Size (Str) = 11 and then Length (Str) = 11); Free (Str); Free (C_Ptr); end Test_18; procedure Test_19 is Str : CPP_String := New_CPP_String ("Ada/C"); begin Append (Str, 2, '+'); Assert (Data (Str) = "Ada/C++" and then Size (Str) = 7 and then Length (Str) = 7); Free (Str); end Test_19; ----------------------- -- Tests of Assign() -- ----------------------- procedure Test_20 is Str : CPP_String := New_CPP_String ("abc"); begin Assign (Str, "Ada/C++"); Assert (Data (Str) = "Ada/C++" and then Size (Str) = 7 and then Length (Str) = 7); Free (Str); end Test_20; procedure Test_21 is Str_1 : CPP_String := New_CPP_String ("Ada/C++"); Str_2 : CPP_String := New_CPP_String; begin Assign (Str_2, Str_1); Assert (Data (Str_2) = "Ada/C++" and then Size (Str_2) = 7 and then Length (Str_2) = 7); Free (Str_1); Free (Str_2); end Test_21; procedure Test_22 is C_Ptr : chars_ptr := New_String ("Ada/C++"); Str : CPP_String := New_CPP_String; begin Assign (Str, C_Ptr); Assert (Data (Str) = "Ada/C++" and then Size (Str) = 7 and then Length (Str) = 7); Free (C_Ptr); Free (Str); end Test_22; procedure Test_23 is Str : CPP_String := New_CPP_String ("Ada"); begin Assign (Str, 'C'); Assert (Data (Str) = "C" and then Size (Str) = 1 and then Length (Str) = 1); Free (Str); end Test_23; ----------------------- -- Tests of Insert() -- ----------------------- procedure Test_24 is Str : CPP_String := New_CPP_String ("012345"); begin Insert (Str, 3, "Ada"); Assert (Data (Str) = "012Ada345" and then Size (Str) = 9 and then Length (Str) = 9); Free (Str); end Test_24; procedure Test_25 is Str_1 : CPP_String := New_CPP_String ("012345"); Str_2 : CPP_String := New_CPP_String ("Ada"); begin Insert (Str_1, 3, Str_2); Assert (Data (Str_1) = "012Ada345" and then Size (Str_1) = 9 and then Length (Str_1) = 9); Free (Str_1); Free (Str_2); end Test_25; procedure Test_26 is Str_1 : CPP_String := New_CPP_String ("012345"); Str_2 : CPP_String := New_CPP_String (" Programming"); begin Insert (Str_1, 3, Str_2, Subpos => 1, Sublen => 7); Assert (Data (Str_1) = "012Program345" and then Size (Str_1) = 13 and then Length (Str_1) = 13); Free (Str_1); Free (Str_2); end Test_26; procedure Test_27 is Str : CPP_String := New_CPP_String ("012345"); C_Ptr : chars_ptr := New_String ("Ada Programming"); begin Insert (Str, 3, C_Ptr, N => 7); Assert (Data (Str) = "012Ada Pro345" and then Size (Str) = 13 and then Length (Str) = 13); Free (C_Ptr); Free (Str); end Test_27; procedure Test_28 is Str : CPP_String := New_CPP_String ("012345"); Pos : constant size_t := 3; N : constant size_t := 4; begin Insert (Str, 3, N, 'x'); Assert (Data (Str) = "012xxxx345" and then Size (Str) = 10 and then Length (Str) = 10); Free (Str); end Test_28; ------------------------ -- Tests of Push_Back -- ------------------------ procedure Test_29 is Str : CPP_String := New_CPP_String ("Ada/"); begin Push_Back (Str, 'C'); Push_Back (Str, '+'); Push_Back (Str, '+'); Assert (Data (Str) = "Ada/C++" and then Size (Str) = 7 and then Length (Str) = 7); Free (Str); end Test_29; ----------------------- -- Tests of Pop_Back -- ----------------------- procedure Test_30 is Str : CPP_String := New_CPP_String ("Ada/"); begin Pop_Back (Str); Assert (Data (Str) = "Ada"); Free (Str); end Test_30; -------------------- -- Tests of Erase -- -------------------- procedure Test_31 is Str : CPP_String := New_CPP_String ("012345"); begin Erase (Str, 3, 2); Assert (Data (Str) = "0125" and then Size (Str) = 4 and then Length (Str) = 4); Free (Str); end Test_31; procedure Test_32 is Str : CPP_String := New_CPP_String ("012345"); begin Erase (Str); Assert (Data (Str) = "" and then Size (Str) = 0 and then Length (Str) = 0); Free (Str); end Test_32; ---------------------- -- Tests of Replace -- ---------------------- procedure Test_33 is Str : CPP_String := New_CPP_String ("abcdefg"); begin Replace (Str, Pos => 2, Len => 3, Text => "012345"); Assert (Data (Str) = "ab012345fg"); Free (Str); end Test_33; procedure Test_34 is Str_1 : CPP_String := New_CPP_String ("abcdefg"); Str_2 : CPP_String := New_CPP_String ("012345"); begin Replace (Str_1, Pos => 2, Len => 3, Text => Str_2); Assert (Data (Str_1) = "ab012345fg"); Free (Str_1); Free (Str_2); end Test_34; procedure Test_35 is Str_1 : CPP_String := New_CPP_String ("abcdefg"); Str_2 : CPP_String := New_CPP_String ("012345"); begin Replace (Str_1, Pos => 2, Len => 3, Text => Str_2, Subpos => 1, Sublen => 3); Assert (Data (Str_1) = "ab123fg"); Free (Str_1); Free (Str_2); end Test_35; procedure Test_36 is Str_1 : CPP_String := New_CPP_String ("abcdefg"); Str_2 : chars_ptr := New_String ("012345"); begin Replace (Str_1, Pos => 2, Len => 3, Text => Str_2); Assert (Data (Str_1) = "ab012345fg"); Free (Str_1); Free (Str_2); end Test_36; procedure Test_37 is Str_1 : CPP_String := New_CPP_String ("abcdefg"); Str_2 : chars_ptr := New_String ("012345"); begin Replace (Str_1, Pos => 2, Len => 3, Text => Str_2, N => 3); Assert (Data (Str_1) = "ab012fg"); Free (Str_1); Free (Str_2); end Test_37; procedure Test_38 is Str_1 : CPP_String := New_CPP_String ("abcdefg"); Str_2 : chars_ptr := New_String ("012345"); begin Replace (Str_1, Pos => 2, Len => 3, N => 4, C => '.'); Assert (Data (Str_1) = "ab....fg"); Free (Str_1); Free (Str_2); end Test_38; ------------------- -- Tests of Swap -- ------------------- procedure Test_39 is Str_1 : CPP_String := New_CPP_String ("abcdefg"); Str_2 : CPP_String := New_CPP_String ("012345"); begin Swap (Str_1, Str_2); Assert (Data (Str_1) = "012345" and then Data (Str_2) = "abcdefg"); Free (Str_1); Free (Str_2); end Test_39; -------------------- -- Tests of C_Str -- -------------------- procedure Test_40 is Text : constant String := "abcdef"; Str : CPP_String := New_CPP_String (Text); C_Ptr : chars_ptr; Expected : chars_ptr := New_String (Text); begin C_Ptr := C_Str (Str); declare Value_C_Ptr : constant String := Value (C_Ptr); Value_Expected : constant String := Value (Expected); begin Assert (Strlen (C_Ptr) = Text'Length and then Strlen (C_Ptr) = Strlen (Expected) and then Value_C_Ptr = Value_Expected); end; Free (Str); Free (Expected); end Test_40; ------------------- -- Tests of Data -- ------------------- procedure Test_41 is Text : constant String := "Ada & C++"; Str : CPP_String := New_CPP_String (Text); C_Ptr : chars_ptr; Expected : chars_ptr := New_String (Text); begin C_Ptr := Data (Str); declare Value_C_Ptr : constant String := Value (C_Ptr); Value_Expected : constant String := Value (Expected); begin Assert (Strlen (C_Ptr) = Text'Length and then Strlen (C_Ptr) = Strlen (Expected) and then Value_C_Ptr = Value_Expected); end; Free (Str); Free (Expected); end Test_41; ------------------- -- Tests of Copy -- ------------------- procedure Test_42 is Str : CPP_String := New_CPP_String ("Ada & C++"); C_Ptr : chars_ptr := New_String ("1234567890"); Num_Chars : size_t; begin Copy (From_Str => Str, To_Str => C_Ptr, Len => 7, Pos => 0, Num_Chars => Num_Chars); declare Value_C_Ptr : constant String := Value (C_Ptr); begin Assert (Num_Chars = 7 and then Value_C_Ptr = "Ada & C890"); end; Free (Str); Free (C_Ptr); end Test_42; ------------------- -- Tests of Find -- ------------------- procedure Test_43 is Str : CPP_String := New_CPP_String ("Testing Ada & C++"); Text : CPP_String := New_CPP_String ("Ada"); Pos : size_t; begin Pos := Find (Str, Text); Assert (Pos = 8); Free (Str); Free (Text); end Test_43; procedure Test_44 is Str : CPP_String := New_CPP_String ("Testing Ada & C++"); Text : chars_ptr := New_String ("Ada"); Pos : size_t; begin Pos := Find (Str, Text); Assert (Pos = 8); Free (Str); Free (Text); end Test_44; procedure Test_45 is Str : CPP_String := New_CPP_String ("Testing Ada & C++"); Text : chars_ptr := New_String ("Adaxxx"); Pos : size_t; begin Pos := Find (Str, Text, Pos => 0, N => 3); Assert (Pos = 8); Free (Str); Free (Text); end Test_45; procedure Test_46 is Str : CPP_String := New_CPP_String ("Testing Ada & C++"); Pos : size_t; begin Pos := Find (Str, 'd'); Assert (Pos = 9); Free (Str); end Test_46; --------------------------- -- Tests of Reverse_Find -- --------------------------- procedure Test_47 is Str : CPP_String := New_CPP_String ("Testing Ada & C++"); Text : CPP_String := New_CPP_String ("Ada"); Pos : size_t; begin Pos := Reverse_Find (Str, Text); Assert (Pos = 8); Free (Str); Free (Text); end Test_47; procedure Test_48 is Str : CPP_String := New_CPP_String ("Testing Ada & C++"); Text : chars_ptr := New_String ("Ada"); Pos : size_t; begin Pos := Reverse_Find (Str, Text); Assert (Pos = 8); Free (Str); Free (Text); end Test_48; procedure Test_49 is Str : CPP_String := New_CPP_String ("Testing Ada & C++"); Text : chars_ptr := New_String ("Adaxxx"); Pos : size_t; begin Pos := Reverse_Find (Str, Text, Pos => Npos, N => 3); Assert (Pos = 8); Free (Str); Free (Text); end Test_49; procedure Test_50 is Str : CPP_String := New_CPP_String ("Testing Ada & C++"); Pos : size_t; begin Pos := Find (Str, 'd'); Assert (Pos = 9); Free (Str); end Test_50; ---------------------------- -- Tests of Find_First_Of -- ---------------------------- procedure Test_51 is Str : CPP_String := New_CPP_String ("Testing Ada & C++"); Text : CPP_String := New_CPP_String ("dC"); Pos : size_t; begin Pos := Find_First_Of (Str, Text); Assert (Pos = 9); Free (Str); Free (Text); end Test_51; procedure Test_52 is Str : CPP_String := New_CPP_String ("Testing Ada & C++"); Text : chars_ptr := New_String ("dC"); Pos : size_t; begin Pos := Find_First_Of (Str, Text); Assert (Pos = 9); Free (Str); Free (Text); end Test_52; procedure Test_53 is Str : CPP_String := New_CPP_String ("Testing Ada & C++"); Text : chars_ptr := New_String ("dCxxx"); Pos : size_t; begin Pos := Find_First_Of (Str, Text, Pos => 0, N => 2); Assert (Pos = 9); Free (Str); Free (Text); end Test_53; procedure Test_54 is Str : CPP_String := New_CPP_String ("Testing Ada & C++"); Pos : size_t; begin Pos := Find_First_Of (Str, 'd'); Assert (Pos = 9); Free (Str); end Test_54; --------------------------- -- Tests of Find_Last_Of -- --------------------------- procedure Test_55 is Str : CPP_String := New_CPP_String ("Testing Ada & C++"); Text : CPP_String := New_CPP_String ("dC"); Pos : size_t; begin Pos := Find_Last_Of (Str, Text); Assert (Pos = 14); Free (Str); Free (Text); end Test_55; procedure Test_56 is Str : CPP_String := New_CPP_String ("Testing Ada & C++"); Text : chars_ptr := New_String ("dC"); Pos : size_t; begin Pos := Find_Last_Of (Str, Text); Assert (Pos = 14); Free (Str); Free (Text); end Test_56; procedure Test_57 is Str : CPP_String := New_CPP_String ("Testing Ada & C++"); Text : chars_ptr := New_String ("dCxxx"); Pos : size_t; begin Pos := Find_Last_Of (Str, Text, Pos => Npos, N => 2); Assert (Pos = 14); Free (Str); Free (Text); end Test_57; procedure Test_58 is Str : CPP_String := New_CPP_String ("Testing Ada & C++"); Pos : size_t; begin Pos := Find_Last_Of (Str, 'd'); Assert (Pos = 9); Free (Str); end Test_58; -------------------------------- -- Tests of Find_First_Not_Of -- -------------------------------- procedure Test_59 is Str : CPP_String := New_CPP_String ("Testing Ada & C++"); Text : CPP_String := New_CPP_String ("seTt"); Pos : size_t; begin Pos := Find_First_Not_Of (Str, Text); Assert (Pos = 4); Free (Str); Free (Text); end Test_59; procedure Test_60 is Str : CPP_String := New_CPP_String ("Testing Ada & C++"); Text : chars_ptr := New_String ("seTt"); Pos : size_t; begin Pos := Find_First_Not_Of (Str, Text); Assert (Pos = 4); Free (Str); Free (Text); end Test_60; procedure Test_61 is Str : CPP_String := New_CPP_String ("Testing Ada & C++"); Text : chars_ptr := New_String ("seTtxxx"); Pos : size_t; begin Pos := Find_First_Not_Of (Str, Text, Pos => 0, N => 4); Assert (Pos = 4); Free (Str); Free (Text); end Test_61; procedure Test_62 is Str : CPP_String := New_CPP_String ("xxxxxxxxTesting Ada & C++"); Pos : size_t; begin Pos := Find_First_Not_Of (Str, 'x'); Assert (Pos = 8); Free (Str); end Test_62; ------------------------------- -- Tests of Find_Last_Not_Of -- ------------------------------- procedure Test_63 is Str : CPP_String := New_CPP_String ("Testing Ada & C++"); Text : CPP_String := New_CPP_String ("&+ C"); Pos : size_t; begin Pos := Find_Last_Not_Of (Str, Text); Assert (Pos = 10); Free (Str); Free (Text); end Test_63; procedure Test_64 is Str : CPP_String := New_CPP_String ("Testing Ada & C++"); Text : chars_ptr := New_String ("&+ C"); Pos : size_t; begin Pos := Find_Last_Not_Of (Str, Text); Assert (Pos = 10); Free (Str); Free (Text); end Test_64; procedure Test_65 is Str : CPP_String := New_CPP_String ("Testing Ada & C++"); Text : chars_ptr := New_String ("&+ Cxxx"); Pos : size_t; begin Pos := Find_Last_Not_Of (Str, Text, Pos => Npos, N => 4); Assert (Pos = 10); Free (Str); Free (Text); end Test_65; procedure Test_66 is Str : CPP_String := New_CPP_String ("Testing Ada & C++"); Pos : size_t; begin Pos := Find_Last_Not_Of (Str, '+'); Assert (Pos = 14); Free (Str); end Test_66; --------------------- -- Tests of Substr -- --------------------- procedure Test_67 is Str : CPP_String := New_CPP_String ("Testing Ada & C++"); Result : CPP_String := Substr (Str, 8, 3); begin Assert (Data (Result) = "Ada"); Free (Str); Free (Result); end Test_67; ---------------------- -- Tests of Compare -- ---------------------- procedure Test_68 is Str_1 : CPP_String := New_CPP_String ("Testing Ada & C++"); Str_2 : CPP_String := New_CPP_String ("Ada"); begin Assert (Compare (Str_1, Str_1) = 0 and then Compare (Str_1, Str_2) > 0); Free (Str_1); Free (Str_2); end Test_68; procedure Test_69 is Str_1 : CPP_String := New_CPP_String ("Testing Ada & C++"); Str_2 : CPP_String := New_CPP_String ("Ada"); begin Assert (Compare (Str_1, 8, 3, Str_2) = 0 and then Compare (Str_1, 0, 2, Str_2) > 0); Free (Str_1); Free (Str_2); end Test_69; procedure Test_70 is Str_1 : CPP_String := New_CPP_String ("Testing Ada & C++"); Str_2 : CPP_String := New_CPP_String ("xxAdaxx"); begin Assert (Compare (Str_1, 8, 3, Str_2, 2, 3) = 0 and then Compare (Str_1, 0, 2, Str_2, 2, 3) > 0); Free (Str_1); Free (Str_2); end Test_70; procedure Test_71 is Str_1 : CPP_String := New_CPP_String ("Testing Ada & C++"); Str_2 : chars_ptr := New_String ("Ada"); begin Assert (Compare (Str_1, Str_1) = 0 and then Compare (Str_1, Str_2) > 0); Free (Str_1); Free (Str_2); end Test_71; procedure Test_72 is Str_1 : CPP_String := New_CPP_String ("Testing Ada & C++"); Str_2 : chars_ptr := New_String ("Ada"); begin Assert (Compare (Str_1, 8, 3, Str_2) = 0 and then Compare (Str_1, 0, 2, Str_2) > 0); Free (Str_1); Free (Str_2); end Test_72; procedure Test_73 is Str_1 : CPP_String := New_CPP_String ("Testing Ada & C++"); Str_2 : chars_ptr := New_String ("Adaxxxx"); begin Assert (Compare (Str_1, 8, 3, Str_2, 3) = 0 and then Compare (Str_1, 0, 2, Str_2, 2) > 0); Free (Str_1); Free (Str_2); end Test_73; ------------------ -- Tests of "=" -- ------------------ procedure Test_74 is Str_1 : CPP_String := New_CPP_String ("Testing Ada & C++"); Str_2 : CPP_String := New_CPP_String ("Testing Ada & C++"); Str_3 : CPP_String := New_CPP_String ("Ada"); begin Assert (Str_1 = Str_2 and then not (Str_1 = Str_3)); Free (Str_1); Free (Str_2); Free (Str_3); end Test_74; procedure Test_75 is Str_1 : chars_ptr := New_String ("Testing Ada & C++"); Str_2 : CPP_String := New_CPP_String ("Testing Ada & C++"); Str_3 : CPP_String := New_CPP_String ("Ada"); begin Assert (Str_1 = Str_2 and then not (Str_1 = Str_3)); Free (Str_1); Free (Str_2); Free (Str_3); end Test_75; procedure Test_76 is Str_1 : CPP_String := New_CPP_String ("Testing Ada & C++"); Str_2 : chars_ptr := New_String ("Testing Ada & C++"); Str_3 : CPP_String := New_CPP_String ("Ada"); begin Assert (Str_1 = Str_2 and then not (Str_1 = Str_3)); Free (Str_1); Free (Str_2); Free (Str_3); end Test_76; ------------------ -- Tests of "<" -- ------------------ procedure Test_77 is Str_1 : CPP_String := New_CPP_String ("Testing Ada & C++"); Str_2 : CPP_String := New_CPP_String ("Testing Ada & C++"); Str_3 : CPP_String := New_CPP_String ("Ada"); begin Assert (Str_3 < Str_1 and then not (Str_1 < Str_2)); Free (Str_1); Free (Str_2); Free (Str_3); end Test_77; procedure Test_78 is Str_1 : chars_ptr := New_String ("Testing Ada & C++"); Str_2 : CPP_String := New_CPP_String ("Testing Ada & C++"); Str_3 : CPP_String := New_CPP_String ("Ada"); begin Assert (Str_3 < Str_1 and then not (Str_1 < Str_2)); Free (Str_1); Free (Str_2); Free (Str_3); end Test_78; procedure Test_79 is Str_1 : CPP_String := New_CPP_String ("Testing Ada & C++"); Str_2 : chars_ptr := New_String ("Testing Ada & C++"); Str_3 : CPP_String := New_CPP_String ("Ada"); begin Assert (Str_3 < Str_1 and then not (Str_1 < Str_2)); Free (Str_1); Free (Str_2); Free (Str_3); end Test_79; ------------------- -- Tests of "<=" -- ------------------- procedure Test_80 is Str_1 : CPP_String := New_CPP_String ("Testing Ada & C++"); Str_2 : CPP_String := New_CPP_String ("Testing Ada & C++"); Str_3 : CPP_String := New_CPP_String ("Ada"); begin Assert (Str_3 <= Str_1 and then Str_1 <= Str_2); Free (Str_1); Free (Str_2); Free (Str_3); end Test_80; procedure Test_81 is Str_1 : chars_ptr := New_String ("Testing Ada & C++"); Str_2 : CPP_String := New_CPP_String ("Testing Ada & C++"); Str_3 : CPP_String := New_CPP_String ("Ada"); begin Assert (Str_3 <= Str_1 and then Str_1 <= Str_2); Free (Str_1); Free (Str_2); Free (Str_3); end Test_81; procedure Test_82 is Str_1 : CPP_String := New_CPP_String ("Testing Ada & C++"); Str_2 : chars_ptr := New_String ("Testing Ada & C++"); Str_3 : CPP_String := New_CPP_String ("Ada"); begin Assert (Str_3 <= Str_1 and then Str_1 <= Str_2); Free (Str_1); Free (Str_2); Free (Str_3); end Test_82; ------------------ -- Tests of ">" -- ------------------ procedure Test_83 is Str_1 : CPP_String := New_CPP_String ("Testing Ada & C++"); Str_2 : CPP_String := New_CPP_String ("Testing Ada & C++"); Str_3 : CPP_String := New_CPP_String ("Ada"); begin Assert (Str_1 > Str_3 and then not (Str_1 > Str_2)); Free (Str_1); Free (Str_2); Free (Str_3); end Test_83; procedure Test_84 is Str_1 : chars_ptr := New_String ("Testing Ada & C++"); Str_2 : CPP_String := New_CPP_String ("Testing Ada & C++"); Str_3 : CPP_String := New_CPP_String ("Ada"); begin Assert (Str_1 > Str_3 and then not (Str_1 > Str_2)); Free (Str_1); Free (Str_2); Free (Str_3); end Test_84; procedure Test_85 is Str_1 : CPP_String := New_CPP_String ("Testing Ada & C++"); Str_2 : chars_ptr := New_String ("Testing Ada & C++"); Str_3 : CPP_String := New_CPP_String ("Ada"); begin Assert (Str_1 > Str_3 and then not (Str_1 > Str_2)); Free (Str_1); Free (Str_2); Free (Str_3); end Test_85; ------------------- -- Tests of ">=" -- ------------------- procedure Test_86 is Str_1 : CPP_String := New_CPP_String ("Testing Ada & C++"); Str_2 : CPP_String := New_CPP_String ("Testing Ada & C++"); Str_3 : CPP_String := New_CPP_String ("Ada"); begin Assert (Str_1 >= Str_3 and then Str_1 >= Str_2); Free (Str_1); Free (Str_2); Free (Str_3); end Test_86; procedure Test_87 is Str_1 : chars_ptr := New_String ("Testing Ada & C++"); Str_2 : CPP_String := New_CPP_String ("Testing Ada & C++"); Str_3 : CPP_String := New_CPP_String ("Ada"); begin Assert (Str_1 >= Str_3 and then Str_1 >= Str_2); Free (Str_1); Free (Str_2); Free (Str_3); end Test_87; procedure Test_88 is Str_1 : CPP_String := New_CPP_String ("Testing Ada & C++"); Str_2 : chars_ptr := New_String ("Testing Ada & C++"); Str_3 : CPP_String := New_CPP_String ("Ada"); begin Assert (Str_1 >= Str_3 and then Str_1 >= Str_2); Free (Str_1); Free (Str_2); Free (Str_3); end Test_88; -------------------- -- Run_All_Tests -- -------------------- procedure Run_All_Tests is begin -- Constructors, Data(), Size() and Length() Tests ----------- Test_01; Test_02; Test_03; Test_04; Test_05; -- Tests of Capacity() ---------------------------------------- Test_06; Test_07; -- Tests of Resize() ------------------------------------------ Test_08; Test_09; Test_10; -- Tests of Reserve() ----------------------------------------- Test_11; -- Tests of Clear() and Empty() ------------------------------- Test_12; -- Tests of Char_At() ----------------------------------------- Test_13; -- Tests of Append() ------------------------------------------ Test_14; Test_15; Test_16; Test_17; Test_18; Test_19; -- Tests of Assign() ------------------------------------------ Test_20; Test_21; Test_22; Test_23; -- Tests of Insert() ------------------------------------------ Test_24; Test_25; Test_26; Test_27; Test_28; -- Tests of Push_Back ----------------------------------------- Test_29; -- Tests of Pop_Back ------------------------------------------ Test_30; -- Tests of Erase --------------------------------------------- Test_31; Test_32; -- Tests of Replace ------------------------------------------- Test_33; Test_34; Test_35; Test_36; Test_37; Test_38; -- Tests of Swap ---------------------------------------------- Test_39; -- Tests of C_Str --------------------------------------------- Test_40; -- Tests of Data ---------------------------------------------- Test_41; -- Tests of Copy ---------------------------------------------- Test_42; -- Tests of Find ---------------------------------------------- Test_43; Test_44; Test_45; Test_46; -- Tests of Reverse_Find -------------------------------------- Test_47; Test_48; Test_49; Test_50; -- Tests of Find_First_Of ------------------------------------- Test_51; Test_52; Test_53; Test_54; -- Tests of Find_Last_Of -------------------------------------- Test_55; Test_56; Test_57; Test_58; -- Tests of Find_First_Not_Of --------------------------------- Test_59; Test_60; Test_61; Test_62; -- Tests of Find_Last_Not_Of ---------------------------------- Test_63; Test_64; Test_65; Test_66; -- Tests of Substr -------------------------------------------- Test_67; -- Tests of Compare ------------------------------------------- Test_68; Test_69; Test_70; Test_71; Test_72; Test_73; -- Tests of "=" ----------------------------------------------- Test_74; Test_75; Test_76; -- Tests of "<" ----------------------------------------------- Test_77; Test_78; Test_79; -- Tests of "<=" ---------------------------------------------- Test_80; Test_81; Test_82; -- Tests of ">" ----------------------------------------------- Test_83; Test_84; Test_85; -- Tests of ">=" ---------------------------------------------- Test_86; Test_87; Test_88; end Run_All_Tests; begin Run_All_Tests; return Report; end Test; gnatcoll-bindings-25.0.0/testsuite/tests/cpp_strings/test.yaml000066400000000000000000000001011464374334300245700ustar00rootroot00000000000000description: Test for GNATCOLL.CPP.Strings components: - cpp gnatcoll-bindings-25.0.0/testsuite/tests/gmp/000077500000000000000000000000001464374334300211655ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/testsuite/tests/gmp/test.adb000066400000000000000000000041631464374334300226200ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2015-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 -- -- . -- -- -- ------------------------------------------------------------------------------ with Test_Image, Test_Div, Test_Eq, Test_Pow, Test_Mod, Test_Rem, Test_Swap, Test_Roots, Test_GCD, Test_Operators, Test_Bitwise, Test_Rationals; with Test_Assert; function Test return Integer is begin Test_Eq; Test_Image; Test_Swap; Test_Roots; Test_Pow; Test_Div; Test_Rem; Test_Mod; Test_GCD; Test_Operators; Test_Bitwise; Test_Rationals; return Test_Assert.Report; end Test; gnatcoll-bindings-25.0.0/testsuite/tests/gmp/test.yaml000066400000000000000000000000711464374334300230260ustar00rootroot00000000000000description: Test for GNATCOLL.GMP components: - gmp gnatcoll-bindings-25.0.0/testsuite/tests/gmp/test_bitwise.adb000066400000000000000000000106631464374334300243500ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with GNATCOLL.GMP.Integers; use GNATCOLL.GMP.Integers; with Test_Assert; use Test_Assert; procedure Test_Bitwise is -- Test all logical/bitwise operators on a set of cases to make sure all -- functions are bound to the correct C routines. function Img (I : Integer) return String is (Make (I'Image).Image); type Binop_Test is record Left, Right : Integer; -- Left and right operands for the binary operation to test And_Result, Or_Result, Xor_Result : Integer; -- Expected result for the and/or/xor operators end record; type Binop_Test_Array is array (Positive range <>) of Binop_Test; Binop_Tests : constant Binop_Test_Array := ((Left => 0, Right => 0, And_Result => 0, Or_Result => 0, Xor_Result => 0), (Left => 0, Right => 1, And_Result => 0, Or_Result => 1, Xor_Result => 1), (Left => 1, Right => 0, And_Result => 0, Or_Result => 1, Xor_Result => 1), (Left => 1, Right => 1, And_Result => 1, Or_Result => 1, Xor_Result => 0), (Left => 0, Right => -1, And_Result => 0, Or_Result => -1, Xor_Result => -1), (Left => -1, Right => 0, And_Result => 0, Or_Result => -1, Xor_Result => -1), (Left => -1, Right => -1, And_Result => -1, Or_Result => -1, Xor_Result => 0)); type Unop_Test is record Op : Integer; -- Operand for the unary operator to test Result : Integer; -- Expected result for the operator end record; type Unop_Test_Array is array (Positive range <>) of Unop_Test; Unop_Tests : constant Unop_Test_Array := ((0, -1), (1, -2), (-1, 0)); begin for T of Binop_Tests loop declare L : constant Big_Integer := Make (T.Left'Image); R : constant Big_Integer := Make (T.Right'Image); And_Result : constant Big_Integer := L and R; Or_Result : constant Big_Integer := L or R; Xor_Result : constant Big_Integer := L xor R; begin Assert (And_Result.Image, Img (T.And_Result), "test: " & L.Image & " and " & R.Image); Assert (Or_Result.Image, Img (T.Or_Result), "test: " & L.Image & " or " & R.Image); Assert (Xor_Result.Image, Img (T.Xor_Result), "test: " & L.Image & " xor " & R.Image); end; end loop; for T of Unop_Tests loop declare O : constant Big_Integer := Make (T.Op'Image); Result : constant Big_Integer := not O; begin Assert (Result.Image, Img (T.Result), "test: not " & O.Image); end; end loop; end Test_Bitwise; gnatcoll-bindings-25.0.0/testsuite/tests/gmp/test_div.adb000066400000000000000000000045101464374334300234560ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2018, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with GNATCOLL.GMP.Integers; use GNATCOLL.GMP.Integers; with Test_Assert; use Test_Assert; procedure Test_Div is Q, N, D : Big_Integer; Dividend : constant String := "1000000000000000000000000000000000000000000000000000000000000000000000"; Divisor : constant String := Dividend (1 .. Dividend'Length - 1); Quotient : constant String := Dividend (1 .. Dividend'Length - Divisor'Length + 1); begin Set (N, Dividend); Set (D, Divisor); Divide (Q, N, D); Assert (Image (Q), Quotient, "test_div 1"); Set (Q, To => N / D); Assert (Image (Q), Quotient, "test_div 2"); end Test_Div; gnatcoll-bindings-25.0.0/testsuite/tests/gmp/test_eq.adb000066400000000000000000000040511464374334300233010ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2018, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with GNATCOLL.GMP.Integers; use GNATCOLL.GMP; -- for numeric types use GNATCOLL.GMP.Integers; with Test_Assert; use Test_Assert; procedure Test_Eq is D, N : Big_Integer; begin Set (N, "14"); Set (D, 28 / 2); Assert (N = D, "test_eq 1"); Assert (N = 14, "test_eq 2 "); Assert (14 = N, "test_eq 3"); end Test_Eq; gnatcoll-bindings-25.0.0/testsuite/tests/gmp/test_gcd.adb000066400000000000000000000040571464374334300234370ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2018, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with GNATCOLL.GMP.Integers.Number_Theoretic; use GNATCOLL.GMP.Integers.Number_Theoretic; use GNATCOLL.GMP.Integers; with Test_Assert; use Test_Assert; procedure Test_GCD is A, B, C : Big_Integer; begin Set (A, "42"); Set (B, "56"); Get_GCD (Input1 => A, Input2 => B, Output => C); Assert (C = 14, "test_gcd"); end Test_GCD; gnatcoll-bindings-25.0.0/testsuite/tests/gmp/test_image.adb000066400000000000000000000062451464374334300237650ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2018, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with GNATCOLL.GMP.Integers; use GNATCOLL.GMP.Integers; with Test_Assert; use Test_Assert; procedure Test_Image is N : Big_Integer; Input : constant String := "14000000000000000000000" & "000000000000000000000001"; Negated_Input : constant String := '-' & Input; Input_Base_2 : constant String := "1001110011110010000001111001000111010111100010000101010100011010011" & "0000111101110001100000010011011111001001100000000000000000000000000" & "00000000000000000001"; Input_Base_3 : constant String := "123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"; begin Set (N, Input); Assert (Image (N), Input, "test_image 1"); Negate (N); Assert (Image (N), Negated_Input, "test_image 2"); Set (N, Input); Assert (Image (N, Base => 2), Input_Base_2, "test_image 3"); for J in Input_Base_3'Range loop declare Img : constant String := Input_Base_3 (1 .. J); Img0 : constant String := Input_Base_3 (1 .. J) & '0'; Base : constant Positive := Img0'Length; begin Set (N, Img, Base => GNATCOLL.GMP.Int (Base)); Assert (Img, Image (N, (if J < 36 then -Base else Base)), "test_image -" & J'Img); Set (N, Img0, Base => GNATCOLL.GMP.Int (Base)); Assert (Img0, Image (N, (if J < 36 then -Base else Base)), "test_image: " & J'Img); end; end loop; end Test_Image; gnatcoll-bindings-25.0.0/testsuite/tests/gmp/test_mod.adb000066400000000000000000000110711464374334300234530ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2018, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with GNAT.OS_Lib; with GNATCOLL.GMP.Integers.IO; use GNATCOLL.GMP.Integers; use GNATCOLL.GMP.Integers.IO; use GNATCOLL.GMP; -- for numeric types with Test_Assert; use Test_Assert; procedure Test_Mod is R, A, B : Big_Integer; begin Set (B, "5", 10); Set (A, "10", 10); Get_Mod (R, A, B); Assert (R = 0, "Get_Mod (10, 5) = 0"); Set (A, "11", 10); Get_Mod (R, A, B); Assert (R = 1,"Get_Mod (11, 5) = 1"); Set (A, "12", 10); Get_Mod (R, A, B); Assert (R = 2,"Get_Mod (12, 5) = 2"); Set (A, "13", 10); Get_Mod (R, A, B); Assert (R = 3,"Get_Mod (13, 5) = 3"); Set (A, "14", 10); Get_Mod (R, A, B); Assert (R = 4,"Get_Mod (14, 5) = 4"); ---- Set (B, "-5", 10); Set (A, "10", 10); Get_Mod (R, A, B); Assert (R = 0,"Get_Mod (10, -5) = 0"); Set (A, "11", 10); Get_Mod (R, A, B); Assert (R = -4,"Get_Mod (11, -5) = -4"); Set (A, "12", 10); Get_Mod (R, A, B); Assert (R = -3,"Get_Mod (12, -5) = -3"); Set (A, "13", 10); Get_Mod (R, A, B); Assert (R = -2,"Get_Mod (13, -5) = -2"); Set (A, "14", 10); Get_Mod (R, A, B); Assert (R = -1,"Get_Mod (14, -5) = -1"); ---- Set (B, "5", 10); Set (A, "10", 10); Set (R, A mod B); Assert (R = 0,"10 mod 5 = 0"); Set (A, "11", 10); Set (R, A mod B); Assert (R = 1,"11 mod 5 = 1"); Set (A, "12", 10); Set (R, A mod B); Assert (R = 2,"12 mod 5 = 2"); Set (A, "13", 10); Set (R, A mod B); Assert (R = 3,"13 mod 5 = 3"); Set (A, "14", 10); Set (R, A mod B); Assert (R = 4, "14 mod 5 = 4"); ---- Set (B, "5", 10); Set (A, "-10", 10); Set (R, A mod B); Assert (R = 0, "-10 mod 5 = 0"); Set (A, "-11", 10); Set (R, A mod B); Assert (R = 4, "-11 mod 5 = 4"); Set (A, "-12", 10); Set (R, A mod B); Assert (R = 3, "-12 mod 5 = 3"); Set (A, "-13", 10); Set (R, A mod B); Assert (R = 2, "-13 mod 5 = 2"); Set (A, "-14", 10); Set (R, A mod B); Assert (R = 1, "-14 mod 5 = 1"); ---- Set (B, "-5", 10); Set (A, "10", 10); Set (R, A mod B); Assert (R = 0, "10 mod -5 = 0"); Set (A, "11", 10); Set (R, A mod B); Assert (R = -4, "11 mod -5 = -4"); Set (A, "12", 10); Set (R, A mod B); Assert (R = -3, "12 mod -5 = -3"); Set (A, "13", 10); Set (R, A mod B); Assert (R = -2, "13 mod -5 = -2"); Set (A, "14", 10); Set (R, A mod B); Assert (R = -1, "14 mod -5 = -1"); ---- Set (B, "-5", 10); Set (A, "-10", 10); Set (R, A mod B); Assert (R = 0, "-10 mod -5 = 0"); Set (A, "-11", 10); Set (R, A mod B); Assert (R = -1, "-11 mod -5 = -1"); Set (A, "-12", 10); Set (R, A mod B); Assert (R = -2, "-12 mod -5 = -2"); Set (A, "-13", 10); Set (R, A mod B); Assert (R = -3, "-13 mod -5 = -3"); Set (A, "-14", 10); Set (R, A mod B); Assert (R = -4, "-14 mod -5 = -4"); end Test_Mod; gnatcoll-bindings-25.0.0/testsuite/tests/gmp/test_operators.adb000066400000000000000000000123471464374334300247210ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-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 -- -- . -- -- -- ------------------------------------------------------------------------------ with GNATCOLL.GMP.Integers; use GNATCOLL.GMP.Integers; with Test_Assert; use Test_Assert; procedure Test_Operators is A, B, C : Big_Integer; begin Set (A, "2"); Set (B, A ** 5); Set (C, B - A); Assert (C = 30, "test_operators: 32 - 2 = 30"); Set (A, A + 100); Assert (A = 102, "test_operators: A + 100 = 102"); Set (A, B * C); Assert (A = 960, "test_operators: B * C = 960"); Set (C, A / 10); Assert (C = 96, "test_operators: A / 10 = 96"); -- Test truncate/floor/ceil division/remainder on a set of cases to make -- sure all functions are bound to the correct functions. declare type Test_Values is record N, D : Integer; -- Numerator and divisor TQ, TR : Integer; -- Expected quotient/remainder for the "truncate" division FQ, FR : Integer; -- Expected quotient/remainder for the "floor" division CQ, CR : Integer; -- Expected quotient/remainder for the "ceil" division end record; type Test_Values_Array is array (Positive range <>) of Test_Values; function Img (I : Integer) return String is (Make (I'Image).Image); Tests : constant Test_Values_Array := ((N => 10, D => 10, TQ => 1, TR => 0, FQ => 1, FR => 0, CQ => 1, CR => 0), (N => 12, D => 10, TQ => 1, TR => 2, FQ => 1, FR => 2, CQ => 2, CR => -8), (N => 15, D => 10, TQ => 1, TR => 5, FQ => 1, FR => 5, CQ => 2, CR => -5), (N => 17, D => 10, TQ => 1, TR => 7, FQ => 1, FR => 7, CQ => 2, CR => -3), (N => 20, D => 10, TQ => 2, TR => 0, FQ => 2, FR => 0, CQ => 2, CR => 0), (N => -10, D => 10, TQ => -1, TR => 0, FQ => -1, FR => 0, CQ => -1, CR => 0), (N => -12, D => 10, TQ => -1, TR => -2, FQ => -2, FR => 8, CQ => -1, CR => -2), (N => -15, D => 10, TQ => -1, TR => -5, FQ => -2, FR => 5, CQ => -1, CR => -5), (N => -17, D => 10, TQ => -1, TR => -7, FQ => -2, FR => 3, CQ => -1, CR => -7), (N => -20, D => 10, TQ => -2, TR => 0, FQ => -2, FR => 0, CQ => -2, CR => 0)); begin for T of Tests loop declare N : constant Big_Integer := Make (T.N'Image); D : constant Big_Integer := Make (T.D'Image); N_Img : constant String := N.Image; D_Img : constant String := D.Image; TQ : constant Big_Integer := Truncate_Divide (N, D); TR : constant Big_Integer := Truncate_Remainder (N, D); FQ : constant Big_Integer := Floor_Divide (N, D); FR : constant Big_Integer := Floor_Remainder (N, D); CQ : constant Big_Integer := Ceil_Divide (N, D); CR : constant Big_Integer := Ceil_Remainder (N, D); begin Assert (TQ.Image, Img (T.TQ), "test: " & N_Img & " tdiv " & D_Img); Assert (TR.Image, Img (T.TR), "test: " & N_Img & " trem " & D_Img); Assert (FQ.Image, Img (T.FQ), "test: " & N_Img & " fdiv " & D_Img); Assert (FR.Image, Img (T.FR), "test: " & N_Img & " frem " & D_Img); Assert (CQ.Image, Img (T.CQ), "test: " & N_Img & " cdiv " & D_Img); Assert (CR.Image, Img (T.CR), "test: " & N_Img & " crem " & D_Img); end; end loop; end; end Test_Operators; gnatcoll-bindings-25.0.0/testsuite/tests/gmp/test_pow.adb000066400000000000000000000040651464374334300235060ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2018, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with GNATCOLL.GMP.Integers; use GNATCOLL.GMP.Integers; with Test_Assert; use Test_Assert; procedure Test_Pow is A, B : Big_Integer; begin Set (A, "2"); Set (B, A ** 5); Assert (B = 32, "test_pow: 2**5 = 32"); Set (A, 100); Raise_To_N (A, 5); Assert (Image (A), "10000000000", "test_pow 100**5 = 10000000000"); end Test_Pow; gnatcoll-bindings-25.0.0/testsuite/tests/gmp/test_rationals.adb000066400000000000000000000556151464374334300247040ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2022, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Exceptions; use Ada.Exceptions; with Ada.Strings; use Ada.Strings; with Ada.Strings.Fixed; use Ada.Strings.Fixed; with GNATCOLL.GMP; use GNATCOLL.GMP; with GNATCOLL.GMP.Integers; use GNATCOLL.GMP.Integers; with GNATCOLL.GMP.Rational_Numbers; use GNATCOLL.GMP.Rational_Numbers; with Test_Assert; use Test_Assert; procedure Test_Rationals is procedure Test_Assignments; -- Test Set for all supported argument types procedure Test_Conversions; -- Test conversions from/to floating-point values procedure Test_Arithmetics; -- Test rational number arithmetic procedure Test_Comparisons; -- Test rational number comparisons procedure Test_Num_Den; -- Test procedures to set/get numerator/denominator of a rational number ---------------------- -- Test_Assignments -- ---------------------- procedure Test_Assignments is A, B, C, D, R, S : Rational; Zero : constant String := "0"; One : constant String := "2/2"; Pi : constant String := "355/113"; begin -- A is initialized to 0/1 at initialization-time Assert (A.Image, Zero, "Image should return 0 as the denominator is 1"); -- Reinitialize A to 1 using a non canonical form (re-using A should not -- generate a memory leak). A.Set (One, Canonicalize => False); Assert (A.Image, One); -- Reinitialize A to 1 using a non canonical form but let the default -- canonicalization happen. A.Set (One); Assert (A.Image, "1"); -- Ensure that a reinitialized number is correctly marked as -- Canonicalized. declare I : Big_Integer := Make ("1"); begin A.Set (One, Canonicalize => False); A.Set (I); Assert (A.Is_Canonical); end; -- Invalid string initialization begin A.Set ("f/1"); Assert (False, "invalid initialization string"); exception when E : Rational_Numbers.Failure => Assert (Exception_Message (E), "cannot parse f/1 (base: 10)"); end; -- Initialization in base 16 A.Set ("f/1", Base => 16); Assert (A.Image, "15"); -- Approximation of pi B.Set (Pi); Assert (B.Image, Pi); -- Rational_Numbers.Image doesn't print the leading whitespace C.Set (Integer'Last'Image); Assert (" " & C.Image, Integer'Last'Image); -- Cannot set a rational with 0 as denominator begin D.Set ("0/0"); Assert (False, "0/0 is not a valid rational number"); exception when E : Rational_Numbers.Failure => Assert (Exception_Message (E), "cannot set number with 0 as denominator"); end; begin D.Set ("123/0"); Assert (False, "123/0 is not a valid rational number"); exception when E : Rational_Numbers.Failure => Assert (Exception_Message (E), "cannot set number with 0 as denominator"); end; begin D.Set (1, 0); Assert (False, "1/0 is not a valid rational number"); exception when E : Rational_Numbers.Failure => Assert (Exception_Message (E), "cannot set number with 0 as denominator"); end; -- Check usage of bound values declare Result : constant String := Long'First'Image & "/" & Trim (Unsigned_Long'Last'Image, Left); begin R.Set (Result); Assert (R.Image, Result); end; -- Setting from Long/Unsigned_Long declare function Image (Num, Den : String) return String is (Trim (Num, Left) & (if Den /= " 1" then "/" & Trim (Den, Left) else "")); LF : constant Long := Long'First; LL : constant Long := Long'Last; UF : constant Unsigned_Long := Unsigned_Long'First + 1; UL : constant Unsigned_Long := Unsigned_Long'Last; begin R.Set (LF, UF); Assert (R.Image, Image (LF'Image, UF'Image)); R.Set (LL, UF); Assert (R.Image, Image (LL'Image, UF'Image)); R.Set (LF, UL); Assert (R.Image, Image (LF'Image, UL'Image)); R.Set (LL, UL); Assert (R.Image, Image (LL'Image, UL'Image)); end; -- Setting from Big_Integer declare I : Big_Integer; L : constant Long := Long'First; begin I.Set (L); R.Set (I); Assert (R.Image, L'Image); end; -- Swap rational numbers R.Set ("1/2"); S.Set ("3/4"); R.Swap (S); Assert (R.Image, "3/4"); Assert (S.Image, "1/2"); end Test_Assignments; ---------------------- -- Test_Conversions -- ---------------------- procedure Test_Conversions is R : Rational; Result : Double; Pos_Zero_Image : constant String := " 0.00000000000000E+00"; Pos_Inf_Image : constant String := "+Inf****************"; Neg_Inf_Image : constant String := "-Inf****************"; begin -- Check conversions from/to Double declare D : constant Double := Double'Last; begin R.Set (D); Result := R.To_Double; Assert (Result = D); end; -- Same tests but from an Ada floating-point type declare E : constant Long_Float := Long_Float'Model_Small; begin R.Set (Double (E)); Result := R.To_Double; Assert (Long_Float (Result) = E); end; -- Ensure that NaN, +Inf, -Inf are invalid inputs for Double conversion declare function Minus (A, B : Double) return Double is (A - B); Zero : constant Double := Minus (1.0, 1.0); NaN : constant Double := Zero / Zero; Inf : Double := 1.0 / Zero; begin -- NaN begin Assert (NaN'Image, "NaN*****************"); R.Set (NaN); Assert (False, "Should complain about NaN"); exception when E : Rational_Numbers.Failure => Assert (Exception_Message (E), "cannot set number from a NaN"); end; -- +Inf begin Assert (Inf'Image, "+Inf****************"); R.Set (Inf); Assert (False, "Should complain about infinity"); exception when E : Rational_Numbers.Failure => Assert (Exception_Message (E), "cannot set number from infinity"); end; -- -Inf begin Inf := -Inf; Assert (Inf'Image, "-Inf****************"); R.Set (Inf); Assert (False, "Should complain about infinity"); exception when E : Rational_Numbers.Failure => Assert (Exception_Message (E), "cannot set number from infinity"); end; end; -- 0/1 is converted to 0.0 in the floating-point set R.Set ("0/1"); Result := R.To_Double; Assert (Result'Image, Pos_Zero_Image); -- Underflow R.Set ("1/1" & (1 .. 350 => '0')); Result := R.To_Double; Assert (Result'Image, Pos_Zero_Image); -- Overflow R.Set ("1" & (1 .. 350 => '0')); Result := R.To_Double; Assert (Result'Image, Pos_Inf_Image); end Test_Conversions; ---------------------- -- Test_Arithmetics -- ---------------------- procedure Test_Arithmetics is R, A, B, C : Rational; I : Big_Integer; begin A.Set ("1/10"); -- Init a rational number without explicit canonicalization B.Set ("150/15", Canonicalize => False); Assert (B.Image, "150/15"); -- Canonicalize B and check that the copy C is still non-canonicalized C.Set (B, Canonicalize => B.Is_Canonical); B.Canonicalize; Assert (B.Image, "10"); Assert (C.Image, "150/15"); Assert (B.Is_Canonical); Assert (not C.Is_Canonical); -- Check some basic arithemtic R.Set (A + B); Assert (R.Image, "101/10"); R.Set (A - B); Assert (R.Image, "-99/10"); R.Set (A * B); Assert (R.Image, "1"); R.Set (A / B); Assert (R.Image, "1/100"); R.Set (-A); Assert (R.Image, "-1/10"); R.Set (abs R); Assert (R.Image, "1/10"); R.Set (A + B - A * B / (-A)); Assert (R.Image, "201/10"); I.Set (8); R.Set (B ** I); Assert (R.Image, "100000000"); R.Set (B ** (-I)); Assert (R.Image, "1/100000000"); -- Division by zero raises a Failure exception declare A, B : Rational; begin A.Set ("1/1"); B.Set ("0/1"); begin R.Set (A / B); Assert (False, "division by 0"); exception when E : Rational_Numbers.Failure => Assert (Exception_Message (E), "Division by zero"); end; end; -- Operations raise an exception when operands are not in a canonical -- form. declare type Binary_Operator is access function (Left, Right : Rational) return Rational; type Binary_Mixed_Operator is access function (Left: Rational; Right : Big_Integer) return Rational; type Unary_Operator is access function (Operand : Rational) return Rational; procedure Test_Binary (Op : Binary_Operator; Left, Right : Rational; Expected_Message : String); -- Test an expected failure of a binary operation procedure Test_Binary (Op : Binary_Mixed_Operator; Left : Rational; Right : Big_Integer; Expected_Message : String); -- Test an expected failure of a binary operation procedure Test_Unary (Op : Unary_Operator; Operand : Rational; Expected_Message : String); -- Test an expected failure of an unary operation ----------------- -- Test_Binary -- ----------------- procedure Test_Binary (Op : Binary_Operator; Left, Right : Rational; Expected_Message : String) is Result : Rational; begin begin Result.Set (Op (Left, Right)); Assert (False, "Should raise a Failure exception"); exception when E : Rational_Numbers.Failure => Assert (Exception_Message (E), Expected_Message); end; end Test_Binary; ----------------- -- Test_Binary -- ----------------- procedure Test_Binary (Op : Binary_Mixed_Operator; Left : Rational; Right : Big_Integer; Expected_Message : String) is Result : Rational; begin begin Result.Set (Op (Left, Right)); Assert (False, "Should raise a Failure exception"); exception when E : Rational_Numbers.Failure => Assert (Exception_Message (E), Expected_Message); end; end Test_Binary; ---------------- -- Test_Unary -- ---------------- procedure Test_Unary (Op : Unary_Operator; Operand : Rational; Expected_Message : String) is Result : Rational; begin begin Result.Set (Op (Operand)); Assert (False, "Should raise a Failure exception"); exception when E : Rational_Numbers.Failure => Assert (Exception_Message (E), Expected_Message); end; end Test_Unary; A, B : Rational; C : Big_Integer; begin A.Set ("2/2", Canonicalize => False); B.Set ("1/2"); C.Set (Long_Integer'Last'Image); Test_Binary ("+"'Access, A, B, "Left operand must be canonicalized"); Test_Binary ("-"'Access, A, B, "Left operand must be canonicalized"); Test_Binary ("*"'Access, A, B, "Left operand must be canonicalized"); Test_Binary ("/"'Access, A, B, "Left operand must be canonicalized"); Test_Binary ("+"'Access, B, A, "Right operand must be canonicalized"); Test_Binary ("-"'Access, B, A, "Right operand must be canonicalized"); Test_Binary ("*"'Access, B, A, "Right operand must be canonicalized"); Test_Binary ("/"'Access, B, A, "Right operand must be canonicalized"); Test_Unary ("-"'Access, A, "operand must be canonicalized"); Test_Unary ("abs"'Access, A, "operand must be canonicalized"); Test_Binary ("**"'Access, A, C, "Left operand must be canonicalized"); C.Set (C * C); Test_Binary ("**"'Access, B, C, "Exponent too big, exponentiation won't fit in memory"); end; end Test_Arithmetics; ---------------------- -- Test_Comparisons -- ---------------------- procedure Test_Comparisons is R, Equal_To_R, Greater_Than_R, Equal_To_B : Rational; B, Less_Than_B, Greater_Than_B : Big_Integer; begin Set (R, "1/2"); Set (Equal_To_R, "1/2"); Set (Greater_Than_R, "355/113"); Set (Less_Than_B, 1); Set (B, 3); Set (Greater_Than_B, 6); Set (Equal_To_B, B); -- Rational/Rational comparisons Assert (R = Equal_To_R); Assert (not (R = Greater_Than_R)); Assert (R /= Greater_Than_R); Assert (not (R /= Equal_To_R)); Assert (R < Greater_Than_R); Assert (not (Greater_Than_R < R)); Assert (Greater_Than_R > R); Assert (not (R > Greater_Than_R)); Assert (R >= Equal_To_R); Assert (Equal_To_R >= R); Assert (Greater_Than_R >= R); Assert (not (R >= Greater_Than_R)); Assert (R <= Equal_To_R); Assert (Equal_To_R <= R); Assert (R <= Greater_Than_R); Assert (not (Greater_Than_R <= R)); -- Rational/Big_Integer comparisons Assert (B = Equal_To_B); Assert (Equal_To_B = B); Assert (not (Less_Than_B = Equal_To_B)); Assert (not (Equal_To_B = Less_Than_B)); Assert (Less_Than_B /= Equal_To_B); Assert (Equal_To_B /= Less_Than_B); Assert (not (B /= Equal_To_B)); Assert (not (Equal_To_B /= B)); Assert (Greater_Than_B > Equal_To_B); Assert (Equal_To_B > Less_Than_B); Assert (not (Equal_To_B > Greater_Than_B)); Assert (not (Less_Than_B > Equal_To_B)); Assert (Less_Than_B < Equal_To_B); Assert (Equal_To_B < Greater_Than_B); Assert (not (Equal_To_B < Less_Than_B)); Assert (not (Greater_Than_B < Equal_To_B)); Assert (B >= Equal_To_B); Assert (Equal_To_B >= B); Assert (Greater_Than_B >= Equal_To_B); Assert (Equal_To_B >= Less_Than_B); Assert (not (Equal_To_B >= Greater_Than_B)); Assert (not (Less_Than_B >= Equal_To_B)); Assert (B <= Equal_To_B); Assert (Equal_To_B <= B); Assert (Less_Than_B <= Equal_To_B); Assert (Equal_To_B <= Greater_Than_B); Assert (not (Equal_To_B <= Less_Than_B)); Assert (not (Greater_Than_B <= Equal_To_B)); -- Comparisons raise an exception when operands are not in a canonical -- form. declare type RR_Operator is access function (Left, Right : Rational) return Boolean; type RI_Operator is access function (Left : Rational; Right : Big_Integer) return Boolean; type IR_Operator is access function (Left : Big_Integer; Right : Rational) return Boolean; procedure Test_RR_Operator (Op : RR_Operator; Left, Right : Rational; Expected_Message : String); -- Test an expected failure of a Rational/Rational comparison procedure Test_RI_Operator (Op : RI_Operator; Left : Rational; Right : Big_Integer); -- Test an expected failure of a Rational/Big_Integer comparison procedure Test_IR_Operator (Op : IR_Operator; Left : Big_Integer; Right : Rational); -- Test an expected failure of a Big_Integer/Rational comparison ---------------------- -- Test_RR_Operator -- ---------------------- procedure Test_RR_Operator (Op : RR_Operator; Left, Right : Rational; Expected_Message : String) is Result : Boolean; begin Result := Op (Left, Right); Assert (False, "Should raise a Failure exception"); exception when E : Rational_Numbers.Failure => Assert (Exception_Message (E), Expected_Message); end Test_RR_Operator; ---------------------- -- Test_RI_Operator -- ---------------------- procedure Test_RI_Operator (Op : RI_Operator; Left : Rational; Right : Big_Integer) is Result : Boolean; begin Result := Op (Left, Right); Assert (False, "Should raise a Failure exception"); exception when E : Rational_Numbers.Failure => Assert (Exception_Message (E), "Left operand must be canonicalized"); end Test_RI_Operator; ---------------------- -- Test_IR_Operator -- ---------------------- procedure Test_IR_Operator (Op : IR_Operator; Left : Big_Integer; Right : Rational) is Result : Boolean; begin Result := Op (Left, Right); Assert (False, "Should raise a Failure exception"); exception when E : Rational_Numbers.Failure => Assert (Exception_Message (E), "Right operand must be canonicalized"); end Test_IR_Operator; A, B : Rational; C : Big_Integer := Make ("1"); begin A.Set ("2/2", Canonicalize => False); B.Set ("1/2"); Test_RR_Operator ("="'Access, A, B, "Left operand must be canonicalized"); Test_RR_Operator (">"'Access, A, B, "Left operand must be canonicalized"); Test_RR_Operator ("<"'Access, A, B, "Left operand must be canonicalized"); Test_RR_Operator (">="'Access, A, B, "Left operand must be canonicalized"); Test_RR_Operator ("<="'Access, A, B, "Left operand must be canonicalized"); Test_RR_Operator ("="'Access, B, A, "Right operand must be canonicalized"); Test_RR_Operator (">"'Access, B, A, "Right operand must be canonicalized"); Test_RR_Operator ("<"'Access, B, A, "Right operand must be canonicalized"); Test_RR_Operator (">="'Access, B, A, "Right operand must be canonicalized"); Test_RR_Operator ("<="'Access, B, A, "Right operand must be canonicalized"); Test_RI_Operator ("="'Access, A, C); Test_RI_Operator (">"'Access, A, C); Test_RI_Operator ("<"'Access, A, C); Test_RI_Operator (">="'Access, A, C); Test_RI_Operator ("<="'Access, A, C); Test_IR_Operator ("="'Access, C, A); Test_IR_Operator (">"'Access, C, A); Test_IR_Operator ("<"'Access, C, A); Test_IR_Operator (">="'Access, C, A); Test_IR_Operator ("<="'Access, C, A); end; end Test_Comparisons; ------------------ -- Test_Num_Den -- ------------------ procedure Test_Num_Den is N, D : Big_Integer; R : Rational; begin Set (R, "355/113"); Assert (Is_Canonical (R)); N.Set (Numerator (R)); D.Set (Denominator (R)); Assert (Image (N), "355"); Assert (Image (D), "113"); Set_Num (R, D, Canonicalize => False); Assert (Image (R), "113/113"); Assert (not Is_Canonical (R)); Set_Den (R, N); Assert (Image (R), "113/355"); Assert (Is_Canonical (R)); Set_Num (R, N); Assert (Image (R), "1"); Assert (Is_Canonical (R)); -- Cannot set a denominator to 0 declare Zero : constant Big_Integer := Make ("0"); begin begin Set_Den (R, Zero); Assert (False, "set denominator to 0 is not valid"); exception when E : Rational_Numbers.Failure => Assert (Exception_Message (E), "cannot set denominator to 0"); end; end; end Test_Num_Den; begin Test_Assignments; Test_Conversions; Test_Arithmetics; Test_Comparisons; Test_Num_Den; end Test_Rationals; gnatcoll-bindings-25.0.0/testsuite/tests/gmp/test_rem.adb000066400000000000000000000103541464374334300234620ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2018, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with GNATCOLL.GMP.Integers; use GNATCOLL.GMP, GNATCOLL.GMP.Integers; with Test_Assert; use Test_Assert; procedure Test_Rem is R, A, B : Big_Integer; begin Set (B, "5", 10); Set (A, "10", 10); Get_Rem (R, A, B); Assert (R = 0, "test_rem: Get_Rem 10 rem 5 = 0"); Set (A, "11", 10); Get_Rem (R, A, B); Assert (R = 1, "test_rem: Get_Rem 11 rem 5 = 1"); Set (A, "12", 10); Get_Rem (R, A, B); Assert (R = 2, "test_rem: Get_Rem 12 rem 5 = 2"); Set (A, "13", 10); Get_Rem (R, A, B); Assert (R = 3, "test_rem: Get_Rem 13 rem 5 = 3"); Set (A, "14", 10); Get_Rem (R, A, B); Assert (R = 4, "test_rem: Get_Rem 14 rem 5 = 4"); ---- Set (A, "10", 10); Set (R, A rem B); Assert (R = 0, "test_rem: 10 rem 5 = 0"); Set (A, "11", 10); Set (R, A rem B); Assert (R = 1, "test_rem: 11 rem 5 = 1"); Set (A, "12", 10); Set (R, A rem B); Assert (R = 2, "test_rem: 12 rem 5 = 2"); Set (A, "13", 10); Set (R, A rem B); Assert (R = 3, "test_rem: 13 rem 5 = 3"); Set (A, "14", 10); Set (R, A rem B); Assert (R = 4, "test_rem: 14 rem 5 = 4"); ---- Set (A, "-10", 10); Set (R, A rem B); Assert (R = 0, "test_rem: -10 rem 5 = 0"); Set (A, "-11", 10); Set (R, A rem B); Assert (R = -1, "test_rem: -11 rem 5 = -1"); Set (A, "-12", 10); Set (R, A rem B); Assert (R = -2, "test_rem: -12 rem 5 = -2"); Set (A, "-13", 10); Set (R, A rem B); Assert (R = -3, "test_rem: -13 rem 5 = -3"); Set (A, "-14", 10); Set (R, A rem B); Assert (R = -4, "test_rem: -14 rem 5 = -4"); ---- Set (B, "-5", 10); Set (A, "10", 10); Set (R, A rem B); Assert (R = 0, "test_rem: 10 rem -5 = 0"); Set (A, "11", 10); Set (R, A rem B); Assert (R = 1, "test_rem: 11 rem -5 = 1"); Set (A, "12", 10); Set (R, A rem B); Assert (R = 2, "test_rem: 12 rem -5 = 2"); Set (A, "13", 10); Set (R, A rem B); Assert (R = 3, "test_rem: 13 rem -5 = 3"); Set (A, "14", 10); Set (R, A rem B); Assert (R = 4, "test_rem: 14 rem -5 = 4"); ---- Set (A, "-10", 10); Set (R, A rem B); Assert (R = 0, "test_rem: -10 rem -5 = 0"); Set (A, "-11", 10); Set (R, A rem B); Assert (R = -1, "test_rem: -11 rem -5 = -1"); Set (A, "-12", 10); Set (R, A rem B); Assert (R = -2, "test_rem: -12 rem -5 = -2"); Set (A, "-13", 10); Set (R, A rem B); Assert (R = -3, "test_rem: -13 rem -5 = -3"); Set (A, "-14", 10); Set (R, A rem B); Assert (R = -4, "test_rem: -14 rem -5 = -4"); end Test_Rem; gnatcoll-bindings-25.0.0/testsuite/tests/gmp/test_roots.adb000066400000000000000000000047151464374334300240510ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2018, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with GNATCOLL.GMP.Integers.Root_Extraction; use GNATCOLL.GMP.Integers; use GNATCOLL.GMP.Integers.Root_Extraction; with Test_Assert; use Test_Assert; procedure Test_Roots is A, B : Big_Integer; Root_Value : constant := 99_999; Raised_Value : constant String := "99995000000000000000000000000000"; Was_Exact : Boolean; begin Set (A, "144"); Get_SQRT (A, Into => B); Assert (B = 12, "test_roots: sqrt of 144 = 12"); Set (A, To => Root_Value); Raise_To_N (A, 5); Get_Nth_Root (A, N => 5, Into => B, Exact => Was_Exact); Assert (B = Root_Value, "test_roots: 5th root of " & Raised_Value & " = " & Root_Value'Img); Assert (Was_Exact, "test_roots: 5th root of " & Raised_Value & " is exact"); end Test_Roots; gnatcoll-bindings-25.0.0/testsuite/tests/gmp/test_swap.adb000066400000000000000000000044131464374334300236500ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2009-2018, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with GNATCOLL.GMP.Integers; use GNATCOLL.GMP.Integers; with GNATCOLL.GMP.Integers.Misc; use GNATCOLL.GMP.Integers.Misc; with Test_Assert; use Test_Assert; procedure Test_Swap is A, B, A_Copy, B_Copy : Big_Integer; begin Set (A, "123456789012345678901234567890"); -- arbitrary value Set (A_Copy, To => A); Set (B, "987654321987654321987654321"); -- arbitrary value Set (B_Copy, To => B); Swap (A, B); Assert (A = B_Copy, "test_swap: A = original B"); Assert (B = A_Copy, "test_swap: B = original A"); end Test_Swap; gnatcoll-bindings-25.0.0/testsuite/tests/iconv/000077500000000000000000000000001464374334300215205ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/testsuite/tests/iconv/bad_charset/000077500000000000000000000000001464374334300237575ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/testsuite/tests/iconv/bad_charset/test.adb000066400000000000000000000007151464374334300254110ustar00rootroot00000000000000with GNATCOLL.Iconv; with Test_Assert; function Test return Integer is package Iconv renames GNATCOLL.Iconv; package A renames Test_Assert; St : Iconv.Iconv_T; Success : Boolean := False; begin begin St := Iconv.Iconv_Open ("nonexistent", "nonexistent"); exception when Iconv.Unsupported_Conversion => Success := True; end; A.Assert (Success, Msg => "handling of bad charset"); return A.Report; end Test; gnatcoll-bindings-25.0.0/testsuite/tests/iconv/bad_charset/test.yaml000066400000000000000000000001131464374334300256150ustar00rootroot00000000000000description: Test for GNATCOLL.Iconv (bad charset) components: - iconv gnatcoll-bindings-25.0.0/testsuite/tests/iconv/iconv1/000077500000000000000000000000001464374334300227175ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/testsuite/tests/iconv/iconv1/test.adb000066400000000000000000000133141464374334300243500ustar00rootroot00000000000000with Ada.Exceptions; with Ada.Strings.Unbounded; with Ada.Text_IO; with GNAT.Source_Info; with GNATCOLL.Iconv; with Test_Assert; function Test return Integer is package A renames Test_Assert; package Iconv renames GNATCOLL.Iconv; package IO renames Ada.Text_IO; package SI renames GNAT.Source_Info; function Bytes_Image (Input : String) return String; function Bytes_Image (Input : String) return String is Result : Ada.Strings.Unbounded.Unbounded_String; begin for C in Input'Range loop Ada.Strings.Unbounded.Append (Result, Character'Pos (Input (C))'Img); end loop; return Ada.Strings.Unbounded.To_String (Result); end Bytes_Image; procedure Assert_Iconv (Input : String; Expected : String; From_Code : String; To_Code : String; Transliteration : Boolean := False; Ignore : Boolean := False; Msg : String := ""; Location : String := SI.Source_Location) is -- Transform Input using Iconv and expect Expected as a result -- The other parameters are for GNATCOLL.Iconv.Iconv begin declare Result : constant String := Iconv.Iconv (Input => Input, To_Code => To_Code, From_Code => From_Code, Transliteration => Transliteration, Ignore => Ignore); Success : constant Boolean := Result = Expected; begin A.Assert (Success, Msg, Location); if not Success then IO.Put_Line ("iconv(" & Bytes_Image (Input) & ", to_code => " & To_Code & ", from_code => " & From_code & ", transliteration => " & Transliteration'Img & ", ignore => " & Ignore'Img); IO.Put_Line ("- expect: " & Bytes_Image (Expected)); IO.Put_Line ("- got: " & Bytes_Image (Result)); end if; end; exception when E : others => A.Assert (False, Msg, Location); IO.Put_Line ("got exception: " & ASCII.LF & Ada.Exceptions.Exception_Information (E)); end Assert_Iconv; procedure Assert_Invalid_Sequence (Input : String; From_Code : String; To_Code : String; Transliteration : Boolean := False; Ignore : Boolean := False; Msg : String := ""; Location : String := SI.Source_Location) is -- Assert that input sequence will be considered by Iconv as an invalid -- sequence. begin declare Result : constant String := Iconv.Iconv (Input => Input, To_Code => To_Code, From_Code => From_Code, Transliteration => Transliteration, Ignore => Ignore); begin A.Assert (False, Msg, Location); IO.Put_Line ("iconv(" & Input & ", to_code => " & To_Code & ", from_code => " & From_code & ", transliteration => " & Transliteration'Img & ", ignore => " & Ignore'Img); IO.Put_Line ("- expect: Invalid_Sequence_Error "); IO.Put ("- got: "); for C in Result'Range loop IO.Put (Character'Pos (Result (C))'Img); end loop; IO.New_Line; end; exception when Iconv.Invalid_Sequence_Error => A.Assert (True, Msg, Location); when E : others => A.Assert (False, Msg, Location); IO.Put_Line ("got exception: " & ASCII.LF & Ada.Exceptions.Exception_Information (E)); end Assert_Invalid_Sequence; Eacute : constant Character := Character'Val (16#E9#); -- in Iso_8859-1 R_Koi8 : constant Character := Character'Val (16#D1#); EAcute_Koi8_Trans : constant String := -- a 'e Character'Val (39) & Character'Val (101); -- In KOI8-R Eacute_UTF8 : constant String := Character'Val (195) & Character'Val (169); R_UTF8 : constant String := Character'Val (209) & Character'Val (143); Ellipsis_UTF8 : constant String := Character'Val (16#E2#) & Character'Val (16#80#) & Character'Val (16#A6#); Alveolar_Click : constant String := Character'Val (16#C7#) & Character'Val (16#82#); begin Assert_Iconv ("Simple test", "Simple test", "", "", Msg => "simple test"); Assert_Iconv ("Simple " & Eacute, "Simple " & Eacute_UTF8, Iconv.Iso_8859_1, Iconv.UTF8); Assert_Iconv ("Simple " & R_Koi8, "Simple " & R_UTF8, Iconv.KOI8_R, Iconv.UTF8); Assert_Invalid_Sequence ("Simple " & Eacute, Iconv.Iso_8859_1, Iconv.KOI8_R); -- Test with invalid character both in the middle and at the end Assert_Iconv ("Simple " & Eacute, "Simple ", Iconv.Iso_8859_1, Iconv.KOI8_R, Ignore => True); Assert_Iconv ("T" & Eacute & "Simple", "TSimple", Iconv.Iso_8859_1, Iconv.KOI8_R, Ignore => True); Assert_Iconv (Input => Ellipsis_UTF8, Expected => "...", From_Code => Iconv.UTF8, To_Code => Iconv.ASCII, Transliteration => True, Msg => "Test transliteration on ellipsis"); Assert_Iconv (Input => Ellipsis_UTF8, Expected => "", From_Code => Iconv.UTF8, To_Code => Iconv.ASCII, Transliteration => False, Ignore => True, Msg => "Test UTF-8 to ASCII of ellipsis without transliteration"); Assert_Iconv (Input => Alveolar_Click & "A", Expected => "?" & "A", From_Code => Iconv.UTF8, To_Code => Iconv.ASCII, Transliteration => True, Ignore => True, Msg => "Test character for which there is no transliteration"); return A.Report; end Test; gnatcoll-bindings-25.0.0/testsuite/tests/iconv/iconv1/test.yaml000066400000000000000000000000751464374334300245640ustar00rootroot00000000000000description: Test for GNATCOLL.Iconv components: - iconv gnatcoll-bindings-25.0.0/testsuite/tests/omp/000077500000000000000000000000001464374334300211755ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/testsuite/tests/omp/sort/000077500000000000000000000000001464374334300221645ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/testsuite/tests/omp/sort/test.adb000066400000000000000000000024341464374334300236160ustar00rootroot00000000000000with Ada.Text_IO; use Ada.Text_IO; with Ada.Calendar; use Ada.Calendar; with GNATCOLL.OMP.Generic_Array_Sort; with Ada.Numerics.Discrete_Random; with Test_Assert; use Test_Assert; function Test return Integer is Timing : constant Boolean := False; type Index is range 1 .. 5_000_000; type My_Array is array (Index range <>) of Integer; procedure My_Sort is new GNATCOLL.OMP.Generic_Array_Sort (Index, Integer, My_Array); package Random is new Ada.Numerics.Discrete_Random (Integer); procedure Randomize (Container : in out My_Array) is Seed : Random.Generator; begin for J in Container'Range loop Container (J) := Random.Random (Seed); end loop; end Randomize; procedure Check_Array_Sorted (Container : My_Array) is begin for J in Container'First + 1 .. Container'Last loop if Container (J) < Container (J - 1) then Assert (False); end if; end loop; end Check_Array_Sorted; Arr : access My_Array := new My_Array (Index); Start : Time; Time : Duration; begin Randomize (Arr.all); Start := Clock; My_Sort (Arr.all); Time := Clock - Start; Check_Array_Sorted (Arr.all); if Timing then Put_Line ("time: " & Time'Image); end if; return Report; end Test; gnatcoll-bindings-25.0.0/testsuite/tests/omp/sort/test.gpr000066400000000000000000000006211464374334300236540ustar00rootroot00000000000000with "gnatcoll_omp"; project Test is for Main use ("test.adb"); for Source_Dirs use (".", "../../../support"); for Object_Dir use "obj"; package Compiler is for Switches ("Ada") use ("-g", "-gnateE"); end Compiler; package Linker is for Switches ("Ada") use ("-g"); end Linker; package Binder is for Switches ("Ada") use ("-E"); end Binder; end Test; gnatcoll-bindings-25.0.0/testsuite/tests/omp/sort/test.yaml000066400000000000000000000001101464374334300240170ustar00rootroot00000000000000description: Test for GNATCOLL.OMP parallel sort components: - omp gnatcoll-bindings-25.0.0/testsuite/testsuite.py000077500000000000000000000112311464374334300216440ustar00rootroot00000000000000#!/usr/bin/env python import re import os import logging import sys from e3.fs import mkdir, ls, find from e3.os.process import Run from e3.testsuite import Testsuite from drivers import make_gnatcoll, TESTSUITE_ROOT_DIR from drivers.basic import BasicTestDriver class MyTestsuite(Testsuite): tests_subdir = "tests" test_driver_map = { "default": BasicTestDriver, } default_driver = "default" def add_options(self, parser): parser.add_argument( "--gcov", help="compute testsuite coverage of gnatcoll", default=False, action="store_true", ) parser.add_argument( "--valgrind", help="check memory usage with Valgrind (memcheck tool)", action="store_true", ) parser.add_argument( "--recompile", help="recompile production version of gnatcoll for testing", default=None, action="store_const", const="PROD", ) parser.add_argument( "--debug", help="recompile debug version of gnatcoll for testing", dest="recompile", action="store_const", const="DEBUG", ) def set_up(self): super().set_up() self.env.gcov = self.main.args.gcov self.env.valgrind = self.main.args.valgrind if self.main.args.gcov: work_dir = os.path.join(TESTSUITE_ROOT_DIR, "gcov") gpr_dir, src_dir, obj_dir = make_gnatcoll(work_dir, "DEBUG", gcov=True) self.env.gnatcoll_gpr_dir = gpr_dir self.env.gnatcoll_src_dir = src_dir self.env.gnatcoll_obj_dir = obj_dir else: self.env.gnatcoll_gpr_dir = None recompile_mode = self.main.args.recompile if recompile_mode: work_dir = os.path.join(TESTSUITE_ROOT_DIR, recompile_mode.lower()) gpr_dir, _, _ = make_gnatcoll( work_dir, recompile_mode, gcov=False ) self.env.gnatcoll_prod_gpr_dir = gpr_dir if self.env.gnatcoll_gpr_dir is None: self.env.gnatcoll_gpr_dir = gpr_dir else: self.env.gnatcoll_prod_gpr_dir = None def tear_down(self): if self.main.args.gcov: wd = TESTSUITE_ROOT_DIR # We need to call gcov on gcda present both in gnatcoll itself and # tests (for generics coverage). gcda_files = find( os.path.join(self.env.gnatcoll_obj_dir), "*.gcda" ) + find(os.path.join(self.env.working_dir), "*.gcda") mkdir(os.path.join(wd, "gcov", "results")) gcr = os.path.join(wd, "gcov", "results") Run(["gcov"] + gcda_files, cwd=os.path.join(wd, "gcov", "results")) total_sources = 0 total_covered = 0 for source_file in ls( os.path.join(self.env.gnatcoll_src_dir, "*", "*") ): base_file = os.path.basename(source_file) if not os.path.isfile(os.path.join(gcr, base_file + ".gcov")): total = 1 covered = 0 with open(source_file) as fd: total = len( [ line for line in fd if line.strip() and not re.match(r" *--", line) ] ) else: with open(os.path.join(gcr, base_file + ".gcov")) as fd: total = 0 covered = 0 for line in fd: if re.match(r" *-:", line): pass elif re.match(r" *[#=]{5}:", line): total += 1 else: total += 1 covered += 1 total_sources += total total_covered += covered logging.info( "%6.2f %% %8d/%-8d %s", float(covered) * 100.0 / float(total), covered, total, os.path.basename(source_file), ) logging.info( "%6.2f %% %8d/%-8d %s", float(total_covered) * 100.0 / float(total_sources), total_covered, total_sources, "TOTAL", ) super().tear_down() if __name__ == "__main__": sys.exit(MyTestsuite().testsuite_main()) gnatcoll-bindings-25.0.0/version_information000066400000000000000000000000041464374334300212160ustar00rootroot000000000000000.0 gnatcoll-bindings-25.0.0/zlib/000077500000000000000000000000001464374334300161475ustar00rootroot00000000000000gnatcoll-bindings-25.0.0/zlib/gnatcoll-coders-zlib-thin.adb000066400000000000000000000107001464374334300235730ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2019, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ package body GNATCOLL.Coders.ZLib.Thin is ZLIB_VERSION : constant Chars_Ptr := zlibVersion; -------------- -- Avail_In -- -------------- function Avail_In (Strm : Z_Stream) return UInt is begin return Strm.Avail_In; end Avail_In; --------------- -- Avail_Out -- --------------- function Avail_Out (Strm : Z_Stream) return UInt is begin return Strm.Avail_Out; end Avail_Out; ------------------ -- Deflate_Init -- ------------------ function Deflate_Init (strm : access Z_Stream; level : Int; method : Int; windowBits : Int; memLevel : Int; strategy : Int) return Int is begin return deflateInit2 (strm, level, method, windowBits, memLevel, strategy, ZLIB_VERSION, stream_size => strm.all'Size / System.Storage_Unit); end Deflate_Init; ------------------ -- Inflate_Init -- ------------------ function Inflate_Init (strm : access Z_Stream; windowBits : Int) return Int is begin return inflateInit2 (strm, windowBits, ZLIB_VERSION, stream_size => strm.all'Size / System.Storage_Unit); end Inflate_Init; ------------------------ -- Last_Error_Message -- ------------------------ function Last_Error_Message (Strm : Z_Stream) return String is use Interfaces.C.Strings; begin if Strm.msg = Null_Ptr then return ""; else return Value (Strm.msg); end if; end Last_Error_Message; ------------ -- Set_In -- ------------ procedure Set_In (Strm : in out Z_Stream; Buffer : Voidp; Size : UInt) is begin Strm.Next_In := Buffer; Strm.Avail_In := Size; end Set_In; ------------------ -- Set_Mem_Func -- ------------------ procedure Set_Mem_Func (Strm : in out Z_Stream; Opaque : Voidp; Alloc : alloc_func; Free : free_func) is begin Strm.opaque := Opaque; Strm.zalloc := Alloc; Strm.zfree := Free; end Set_Mem_Func; ------------- -- Set_Out -- ------------- procedure Set_Out (Strm : in out Z_Stream; Buffer : Voidp; Size : UInt) is begin Strm.Next_Out := Buffer; Strm.Avail_Out := Size; end Set_Out; -------------- -- Total_In -- -------------- function Total_In (Strm : Z_Stream) return ULong is begin return Strm.Total_In; end Total_In; --------------- -- Total_Out -- --------------- function Total_Out (Strm : Z_Stream) return ULong is begin return Strm.Total_Out; end Total_Out; end GNATCOLL.Coders.ZLib.Thin; gnatcoll-bindings-25.0.0/zlib/gnatcoll-coders-zlib-thin.ads000066400000000000000000000320601464374334300236170ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2019, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package provides thin binding to ZLib compression/decompression with Interfaces.C.Strings; use Interfaces; with System; package GNATCOLL.Coders.ZLib.Thin is MAX_MEM_LEVEL : constant := 9; MAX_WBITS : constant := 15; -- 32K LZ77 window SEEK_SET : constant := 0; -- Seek from beginning of file SEEK_CUR : constant := 1; -- Seek from current position SEEK_END : constant := 2; -- Set file pointer to EOF plus "offset" type Byte is new Interfaces.C.unsigned_char; -- 8 bits type UInt is new Interfaces.C.unsigned; -- 16 bits or more type Int is new Interfaces.C.int; type ULong is new Interfaces.C.unsigned_long; -- 32 bits or more subtype Chars_Ptr is Interfaces.C.Strings.chars_ptr; type ULong_Access is access ULong; type Int_Access is access Int; subtype Voidp is System.Address; subtype Byte_Access is Voidp; Nul : constant Voidp := System.Null_Address; Z_NO_FLUSH : constant := 0; Z_PARTIAL_FLUSH : constant := 1; Z_SYNC_FLUSH : constant := 2; Z_FULL_FLUSH : constant := 3; Z_FINISH : constant := 4; Z_OK : constant := 0; Z_STREAM_END : constant := 1; Z_NEED_DICT : constant := 2; Z_ERRNO : constant := -1; Z_STREAM_ERROR : constant := -2; Z_DATA_ERROR : constant := -3; Z_MEM_ERROR : constant := -4; Z_BUF_ERROR : constant := -5; Z_VERSION_ERROR : constant := -6; Z_NO_COMPRESSION : constant := 0; Z_BEST_SPEED : constant := 1; Z_BEST_COMPRESSION : constant := 9; Z_DEFAULT_COMPRESSION : constant := -1; Z_FILTERED : constant := 1; Z_HUFFMAN_ONLY : constant := 2; Z_DEFAULT_STRATEGY : constant := 0; Z_BINARY : constant := 0; Z_ASCII : constant := 1; Z_UNKNOWN : constant := 2; Z_DEFLATED : constant := 8; Z_NULL : constant := 0; type gzFile is new Voidp; type Z_Stream is private; type alloc_func is access function (Opaque : Voidp; Items : UInt; Size : UInt) return Voidp; type free_func is access procedure (opaque : Voidp; address : Voidp); function zlibVersion return Chars_Ptr; function Deflate (strm : access Z_Stream; flush : Int) return Int; function DeflateEnd (strm : access Z_Stream) return Int; -- Dealocate internal data procedure DeflateEnd (strm : access Z_Stream); -- Dealocate internal data and ignore error code function Inflate (strm : access Z_Stream; flush : Int) return Int; function InflateEnd (strm : access Z_Stream) return Int; -- Dealocate internal data procedure InflateEnd (strm : access Z_Stream); -- Dealocate internal data and ignore error code function deflateSetDictionary (strm : access Z_Stream; dictionary : Byte_Access; dictLength : UInt) return Int; function deflateCopy (dest : access Z_Stream; source : access Z_Stream) return Int; function deflateReset (strm : access Z_Stream) return Int; function deflateParams (strm : access Z_Stream; level : Int; strategy : Int) return Int; function inflateSetDictionary (strm : access Z_Stream; dictionary : Byte_Access; dictLength : UInt) return Int; function inflateSync (strm : access Z_Stream) return Int; function inflateReset (strm : access Z_Stream) return Int; function compress (dest : Byte_Access; destLen : ULong_Access; source : Byte_Access; sourceLen : ULong) return Int; function compress2 (dest : Byte_Access; destLen : ULong_Access; source : Byte_Access; sourceLen : ULong; level : Int) return Int; function uncompress (dest : Byte_Access; destLen : ULong_Access; source : Byte_Access; sourceLen : ULong) return Int; function gzopen (path : Chars_Ptr; mode : Chars_Ptr) return gzFile; function gzdopen (fd : Int; mode : Chars_Ptr) return gzFile; function gzsetparams (file : gzFile; level : Int; strategy : Int) return Int; function gzread (file : gzFile; buf : Voidp; len : UInt) return Int; function gzwrite (file : gzFile; buf : Voidp; len : UInt) return Int; function gzprintf (file : gzFile; format : Chars_Ptr) return Int; function gzputs (file : gzFile; s : Chars_Ptr) return Int; function gzgets (file : gzFile; buf : Chars_Ptr; len : Int) return Chars_Ptr; function gzputc (file : gzFile; char : Int) return Int; function gzgetc (file : gzFile) return Int; function gzflush (file : gzFile; flush : Int) return Int; function gzseek (file : gzFile; offset : Int; whence : Int) return Int; function gzrewind (file : gzFile) return Int; function gztell (file : gzFile) return Int; function gzeof (file : gzFile) return Int; function gzclose (file : gzFile) return Int; function gzerror (file : gzFile; errnum : Int_Access) return Chars_Ptr; function adler32 (adler : ULong; buf : Byte_Access; len : UInt) return ULong; function crc32 (crc : ULong; buf : Byte_Access; len : UInt) return ULong; function deflateInit (strm : access Z_Stream; level : Int; version : Chars_Ptr; stream_size : Int) return Int; function deflateInit2 (strm : access Z_Stream; level : Int; method : Int; windowBits : Int; memLevel : Int; strategy : Int; version : Chars_Ptr; stream_size : Int) return Int; function Deflate_Init (strm : access Z_Stream; level : Int; method : Int; windowBits : Int; memLevel : Int; strategy : Int) return Int with Inline; function inflateInit (strm : access Z_Stream; version : Chars_Ptr; stream_size : Int) return Int; function inflateInit2 (strm : access Z_Stream; windowBits : Int; version : Chars_Ptr; stream_size : Int) return Int; function inflateBackInit (strm : access Z_Stream; windowBits : Int; window : Byte_Access; version : Chars_Ptr; stream_size : Int) return Int; -- Size of window have to be 2**windowBits function Inflate_Init (strm : access Z_Stream; windowBits : Int) return Int with Inline; function zError (err : Int) return Chars_Ptr; function inflateSyncPoint (z : access Z_Stream) return Int; function get_crc_table return ULong_Access; -- Interface to the available fields of the z_stream structure. -- The application must update next_in and avail_in when avail_in has -- dropped to zero. It must update next_out and avail_out when avail_out -- has dropped to zero. The application must initialize zalloc, zfree and -- opaque before calling the init function. procedure Set_In (Strm : in out Z_Stream; Buffer : Voidp; Size : UInt) with Inline; procedure Set_Out (Strm : in out Z_Stream; Buffer : Voidp; Size : UInt) with Inline; procedure Set_Mem_Func (Strm : in out Z_Stream; Opaque : Voidp; Alloc : alloc_func; Free : free_func) with Inline; function Last_Error_Message (Strm : Z_Stream) return String with Inline; function Avail_Out (Strm : Z_Stream) return UInt with Inline; function Avail_In (Strm : Z_Stream) return UInt with Inline; function Total_In (Strm : Z_Stream) return ULong with Inline; function Total_Out (Strm : Z_Stream) return ULong with Inline; function inflateCopy (dest : access Z_Stream; Source : access Z_Stream) return Int; function compressBound (Source_Len : ULong) return ULong; function deflateBound (Strm : access Z_Stream; Source_Len : ULong) return ULong; function gzungetc (C : Int; File : gzFile) return Int; function zlibCompileFlags return ULong; private type Z_Stream is record -- zlib.h:68 Next_In : Voidp := Nul; -- next input byte Avail_In : UInt := 0; -- number of bytes available at next_in Total_In : ULong := 0; -- total nb of input bytes read so far Next_Out : Voidp := Nul; -- next output byte should be put there Avail_Out : UInt := 0; -- remaining free space at next_out Total_Out : ULong := 0; -- total nb of bytes output so far msg : Chars_Ptr; -- last error message, NULL if no error state : Voidp := Nul; -- not visible by applications zalloc : alloc_func := null; -- used to allocate the internal state zfree : free_func := null; -- used to free the internal state opaque : Voidp := Nul; -- private data object passed to zalloc and zfree data_type : Int := 0; -- best guess about the data type: ascii or binary adler : ULong := 0; -- adler32 value of the uncompressed data reserved : ULong := 0; -- reserved for future use end record with Convention => C; pragma Import (C, zlibVersion, "zlibVersion"); pragma Import (C, Deflate, "deflate"); pragma Import (C, DeflateEnd, "deflateEnd"); pragma Import (C, Inflate, "inflate"); pragma Import (C, InflateEnd, "inflateEnd"); pragma Import (C, deflateSetDictionary, "deflateSetDictionary"); pragma Import (C, deflateCopy, "deflateCopy"); pragma Import (C, deflateReset, "deflateReset"); pragma Import (C, deflateParams, "deflateParams"); pragma Import (C, inflateSetDictionary, "inflateSetDictionary"); pragma Import (C, inflateSync, "inflateSync"); pragma Import (C, inflateReset, "inflateReset"); pragma Import (C, compress, "compress"); pragma Import (C, compress2, "compress2"); pragma Import (C, uncompress, "uncompress"); pragma Import (C, gzopen, "gzopen"); pragma Import (C, gzdopen, "gzdopen"); pragma Import (C, gzsetparams, "gzsetparams"); pragma Import (C, gzread, "gzread"); pragma Import (C, gzwrite, "gzwrite"); pragma Import (C, gzprintf, "gzprintf"); pragma Import (C, gzputs, "gzputs"); pragma Import (C, gzgets, "gzgets"); pragma Import (C, gzputc, "gzputc"); pragma Import (C, gzgetc, "gzgetc"); pragma Import (C, gzflush, "gzflush"); pragma Import (C, gzseek, "gzseek"); pragma Import (C, gzrewind, "gzrewind"); pragma Import (C, gztell, "gztell"); pragma Import (C, gzeof, "gzeof"); pragma Import (C, gzclose, "gzclose"); pragma Import (C, gzerror, "gzerror"); pragma Import (C, adler32, "adler32"); pragma Import (C, crc32, "crc32"); pragma Import (C, deflateInit, "deflateInit_"); pragma Import (C, inflateInit, "inflateInit_"); pragma Import (C, deflateInit2, "deflateInit2_"); pragma Import (C, inflateInit2, "inflateInit2_"); pragma Import (C, zError, "zError"); pragma Import (C, inflateSyncPoint, "inflateSyncPoint"); pragma Import (C, get_crc_table, "get_crc_table"); -- since zlib 1.2.0: pragma Import (C, inflateCopy, "inflateCopy"); pragma Import (C, compressBound, "compressBound"); pragma Import (C, deflateBound, "deflateBound"); pragma Import (C, gzungetc, "gzungetc"); pragma Import (C, zlibCompileFlags, "zlibCompileFlags"); pragma Import (C, inflateBackInit, "inflateBackInit_"); end GNATCOLL.Coders.ZLib.Thin; gnatcoll-bindings-25.0.0/zlib/gnatcoll-coders-zlib.adb000066400000000000000000000402651464374334300226440ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2019-2020, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with Interfaces.C.Strings; use Interfaces; with GNATCOLL.Coders.ZLib.Thin; use GNATCOLL.Coders.ZLib.Thin; package body GNATCOLL.Coders.ZLib is type Return_Code_Enum is (OK, STREAM_END, NEED_DICT, ERRNO, STREAM_ERROR, DATA_ERROR, MEM_ERROR, BUF_ERROR, VERSION_ERROR); type Flate_Step_Function is access function (Strm : access Thin.Z_Stream; Flush : Thin.Int) return Thin.Int with Convention => C; type Flate_End_Procedure is access procedure (Ctrm : access Thin.Z_Stream) with Convention => C; type Flate_Type is record Step : Flate_Step_Function; Done : Flate_End_Procedure; end record; subtype Footer_Array is Stream_Element_Array (1 .. 8); Simple_GZip_Header : constant Stream_Element_Array (1 .. 10) := (16#1f#, 16#8b#, -- Magic header 16#08#, -- Z_DEFLATED 16#00#, -- Flags 16#00#, 16#00#, 16#00#, 16#00#, -- Time 16#00#, -- XFlags 16#03# -- OS code ); -- The simplest gzip header is not for informational, but just for -- gzip format compatibility. -- Note that some code below is using assumption -- Simple_GZip_Header'Last > Footer_Array'Last, so do not make -- Simple_GZip_Header'Last <= Footer_Array'Last. Return_Code : constant array (Thin.Int range <>) of Return_Code_Enum := (Z_OK => OK, Z_STREAM_END => STREAM_END, Z_NEED_DICT => NEED_DICT, Z_ERRNO => ERRNO, Z_STREAM_ERROR => STREAM_ERROR, Z_DATA_ERROR => DATA_ERROR, Z_MEM_ERROR => MEM_ERROR, Z_BUF_ERROR => BUF_ERROR, Z_VERSION_ERROR => VERSION_ERROR); Flate : constant array (Boolean) of Flate_Type := (True => (Step => Thin.Deflate'Access, Done => Thin.DeflateEnd'Access), False => (Step => Thin.Inflate'Access, Done => Thin.InflateEnd'Access)); Flush_To_C : constant array (Flush_Mode) of Thin.Int := (No_Flush => Z_NO_FLUSH, Sync_Flush => Z_SYNC_FLUSH, Full_Flush => Z_FULL_FLUSH, Finish => Z_FINISH); procedure Raise_Error (Stream : Z_Stream) with Inline; function CRC32 (CRC : Unsigned_32; Data : Stream_Element_Array) return Unsigned_32 with Inline; -- Compute CRC32, it could be necessary to make gzip format procedure CRC32 (CRC : in out Unsigned_32; Data : Stream_Element_Array) with Inline; -- Compute CRC32, it could be necessary to make gzip format procedure Transcode_Auto (Coder : in out Coder_Type; In_Data : Stream_Element_Array; In_Last : out Stream_Element_Offset; Out_Data : out Stream_Element_Array; Out_Last : out Stream_Element_Offset; Flush : Flush_Mode); -- Transcode routine without additional headers procedure Transcode_GZip (Coder : in out Coder_Type; In_Data : Stream_Element_Array; In_Last : out Stream_Element_Offset; Out_Data : out Stream_Element_Array; Out_Last : out Stream_Element_Offset; Flush : Flush_Mode); -- Separate transcode routine to make gzip header procedure Cleanup (Coder : in out Coder_Type); -- Deallocate internal data from last processig if was and prepare for -- another compression/decompresion processing initialization. ----------- -- CRC32 -- ----------- function CRC32 (CRC : Unsigned_32; Data : Stream_Element_Array) return Unsigned_32 is begin return Unsigned_32 (crc32 (ULong (CRC), Data'Address, Data'Length)); end CRC32; procedure CRC32 (CRC : in out Unsigned_32; Data : Stream_Element_Array) is begin CRC := CRC32 (CRC, Data); end CRC32; ------------- -- Cleanup -- ------------- procedure Cleanup (Coder : in out Coder_Type) is begin if Coder.Stream = null then Coder.Stream := new Z_Stream; else Flate (Coder.Compression).Done (Coder.Stream); end if; Coder.Stream_End := False; end Cleanup; ------------------ -- Deflate_Init -- ------------------ procedure Deflate_Init (Coder : in out Coder_Type; Level : Compression_Level := Default_Compression; Strategy : Strategy_Type := Default_Strategy; Method : Compression_Method := Deflated; Window_Bits : Window_Bits_Type := Default_Window_Bits; Memory_Level : Memory_Level_Type := Default_Memory_Level; Header : Header_Type := Default) is Win_Bits : Thin.Int := Thin.Int (Window_Bits); begin Cleanup (Coder); -- We allow ZLib to make header only in case of default header type. -- Otherwise we would either do header by ourselfs, or do not do -- header at all. if Header = None or else Header = GZip then Win_Bits := -Win_Bits; end if; -- For the GZip CRC calculation and make headers if Header = GZip then Coder.CRC := 0; Coder.Offset := Simple_GZip_Header'First; else Coder.Offset := Simple_GZip_Header'Last + 1; end if; Coder.Compression := True; Coder.Header := Header; if Thin.Deflate_Init (Coder.Stream, level => Thin.Int (Level), method => Thin.Int (Method), windowBits => Win_Bits, memLevel => Thin.Int (Memory_Level), strategy => Thin.Int (Strategy)) /= Thin.Z_OK then Raise_Error (Coder.Stream.all); end if; end Deflate_Init; ------------------ -- Inflate_Init -- ------------------ procedure Inflate_Init (Coder : in out Coder_Type; Window_Bits : Window_Bits_Type := Default_Window_Bits; Header : Header_Type := Default) is Win_Bits : Thin.Int := Thin.Int (Window_Bits); procedure Check_Version; -- Check the latest header types compatibility ------------------- -- Check_Version -- ------------------- procedure Check_Version is begin if Version <= "1.1.4" then raise ZLib_Error with "Inflate header type " & Header_Type'Image (Header) & " incompatible with ZLib version " & Version; end if; end Check_Version; begin Cleanup (Coder); case Header is when None => Check_Version; -- Inflate data without headers determined -- by negative Win_Bits. Win_Bits := -Win_Bits; when GZip => Check_Version; -- Inflate gzip data defined by flag 16 Win_Bits := Win_Bits + 16; when Auto => Check_Version; -- Inflate with automatic detection -- of gzip or native header defined by flag 32. Win_Bits := Win_Bits + 32; when Default => null; end case; Coder.Compression := False; Coder.Header := Header; if Thin.Inflate_Init (Coder.Stream, Win_Bits) /= Thin.Z_OK then Raise_Error (Coder.Stream.all); end if; end Inflate_Init; --------------- -- Translate -- --------------- overriding procedure Transcode (Coder : in out Coder_Type; In_Data : Stream_Element_Array; In_Last : out Stream_Element_Offset; Out_Data : out Stream_Element_Array; Out_Last : out Stream_Element_Offset; Flush : Flush_Mode := No_Flush) is begin if Coder.Header = GZip and then Coder.Compression then Transcode_GZip (Coder => Coder, In_Data => In_Data, In_Last => In_Last, Out_Data => Out_Data, Out_Last => Out_Last, Flush => Flush); else Transcode_Auto (Coder => Coder, In_Data => In_Data, In_Last => In_Last, Out_Data => Out_Data, Out_Last => Out_Last, Flush => Flush); end if; end Transcode; -------------------- -- Transcode_Auto -- -------------------- procedure Transcode_Auto (Coder : in out Coder_Type; In_Data : Stream_Element_Array; In_Last : out Stream_Element_Offset; Out_Data : out Stream_Element_Array; Out_Last : out Stream_Element_Offset; Flush : Flush_Mode) is Code : Thin.Int; begin if Out_Data'Length = 0 and then In_Data'Length = 0 then raise Constraint_Error; end if; Set_Out (Coder.Stream.all, Out_Data'Address, Out_Data'Length); Set_In (Coder.Stream.all, In_Data'Address, In_Data'Length); Code := Flate (Coder.Compression).Step (Coder.Stream, Flush_To_C (Flush)); if Code = Thin.Z_STREAM_END then Coder.Stream_End := True; elsif Code /= Z_OK and then (Code /= Z_BUF_ERROR or else Flush = No_Flush or else In_Data'Length > 0 or else Total_In (Coder.Stream.all) = 0 or else (In_Data'Length = 0 and then Flush = Finish and then Avail_Out (Coder.Stream.all) = Out_Data'Length)) then raise ZLib_Error with Return_Code_Enum'Image (Return_Code (Code)) & ": " & Last_Error_Message (Coder.Stream.all); end if; In_Last := In_Data'Last - Stream_Element_Offset (Avail_In (Coder.Stream.all)); Out_Last := Out_Data'Last - Stream_Element_Offset (Avail_Out (Coder.Stream.all)); end Transcode_Auto; -------------------- -- Transcode_GZip -- -------------------- procedure Transcode_GZip (Coder : in out Coder_Type; In_Data : Stream_Element_Array; In_Last : out Stream_Element_Offset; Out_Data : out Stream_Element_Array; Out_Last : out Stream_Element_Offset; Flush : Flush_Mode) is Out_First : Stream_Element_Offset; procedure Add_Data (Data : Stream_Element_Array); -- Add data to stream from the Coder.Offset till necessary, -- used for add gzip headr/footer. procedure Put_32 (Item : in out Stream_Element_Array; Data : Unsigned_32) with Inline; -------------- -- Add_Data -- -------------- procedure Add_Data (Data : Stream_Element_Array) is Data_First : Stream_Element_Offset renames Coder.Offset; Data_Last : Stream_Element_Offset; Data_Len : Stream_Element_Offset; -- -1 Out_Len : Stream_Element_Offset; -- -1 begin Out_First := Out_Last + 1; if Data_First > Data'Last then return; end if; Data_Len := Data'Last - Data_First; Out_Len := Out_Data'Last - Out_First; if Data_Len <= Out_Len then Out_Last := Out_First + Data_Len; Data_Last := Data'Last; else Out_Last := Out_Data'Last; Data_Last := Data_First + Out_Len; end if; Out_Data (Out_First .. Out_Last) := Data (Data_First .. Data_Last); Data_First := Data_Last + 1; Out_First := Out_Last + 1; end Add_Data; ------------ -- Put_32 -- ------------ procedure Put_32 (Item : in out Stream_Element_Array; Data : Unsigned_32) is D : Unsigned_32 := Data; begin for J in Item'First .. Item'First + 3 loop Item (J) := Stream_Element (D and 16#FF#); D := Shift_Right (D, 8); end loop; end Put_32; begin Out_Last := Out_Data'First - 1; if not Coder.Stream_End then Add_Data (Simple_GZip_Header); Transcode_Auto (Coder => Coder, In_Data => In_Data, In_Last => In_Last, Out_Data => Out_Data (Out_First .. Out_Data'Last), Out_Last => Out_Last, Flush => Flush); CRC32 (Coder.CRC, In_Data (In_Data'First .. In_Last)); end if; if Coder.Stream_End and then Out_Last <= Out_Data'Last then -- This detection method would work only when -- Simple_GZip_Header'Last > Footer_Array'Last if Coder.Offset = Simple_GZip_Header'Last + 1 then Coder.Offset := Footer_Array'First; end if; declare Footer : Footer_Array; begin Put_32 (Footer, Coder.CRC); Put_32 (Footer (Footer'First + 4 .. Footer'Last), Unsigned_32'Mod (Total_In (Coder))); Add_Data (Footer); end; end if; end Transcode_GZip; ------------- -- Version -- ------------- function Version return String is begin return Interfaces.C.Strings.Value (Thin.zlibVersion); end Version; -------------- -- Total_In -- -------------- overriding function Total_In (Coder : Coder_Type) return Stream_Element_Count is begin return Stream_Element_Count (Thin.Total_In (Coder.Stream.all)); end Total_In; --------------- -- Total_Out -- --------------- overriding function Total_Out (Coder : Coder_Type) return Stream_Element_Count is begin return Stream_Element_Count (Thin.Total_Out (Coder.Stream.all)); end Total_Out; -------------- -- Finished -- -------------- function Finished (Coder : Coder_Type) return Boolean is begin return Coder.Stream_End; end Finished; ------------- -- Is_Open -- ------------- function Is_Open (Coder : Coder_Type) return Boolean is begin return Coder.Stream /= null; end Is_Open; ----------------- -- Raise_Error -- ----------------- procedure Raise_Error (Stream : Z_Stream) is begin raise ZLib_Error with Last_Error_Message (Stream); end Raise_Error; ----------- -- Close -- ----------- overriding procedure Close (Coder : in out Coder_Type) is procedure Unchecked_Free is new Ada.Unchecked_Deallocation (Z_Stream, Z_Stream_Access); begin if Coder.Stream /= null then Flate (Coder.Compression).Done (Coder.Stream); Unchecked_Free (Coder.Stream); end if; end Close; -------------- -- Finalize -- -------------- overriding procedure Finalize (Coder : in out Coder_Type) is begin Close (Coder); end Finalize; end GNATCOLL.Coders.ZLib; gnatcoll-bindings-25.0.0/zlib/gnatcoll-coders-zlib.ads000066400000000000000000000172301464374334300226610ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2019, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ -- This package provides binding to ZLib compression/decompression with Ada.Finalization; with Interfaces; limited with GNATCOLL.Coders.ZLib.Thin; package GNATCOLL.Coders.ZLib is type Coder_Type is new Ada.Finalization.Limited_Controlled and Coder_Interface with private; type Compression_Level is new Integer range -1 .. 9; type Compression_Method is private; type Window_Bits_Type is new Integer range 8 .. 15; type Memory_Level_Type is new Integer range 1 .. 9; type Strategy_Type is private; type Header_Type is (None, Auto, Default, GZip); -- Header type usage have a some limitation for inflate. -- See comment for Inflate_Init. Default_Memory_Level : constant Memory_Level_Type := 8; Default_Window_Bits : constant Window_Bits_Type := 15; ---------------------------------- -- Compression method constants -- ---------------------------------- Deflated : constant Compression_Method; -- Only one method allowed in this ZLib version --------------------------------- -- Compression level constants -- --------------------------------- No_Compression : constant Compression_Level := 0; Best_Speed : constant Compression_Level := 1; Best_Compression : constant Compression_Level := 9; Default_Compression : constant Compression_Level := -1; ------------------------------------ -- Compression strategy constants -- ------------------------------------ -- RLE stategy can be used only in version 1.2.0 and later Filtered : constant Strategy_Type; Huffman_Only : constant Strategy_Type; RLE : constant Strategy_Type; Default_Strategy : constant Strategy_Type; function Version return String with Inline; -- Return string representation of the ZLib version procedure Deflate_Init (Coder : in out Coder_Type; Level : Compression_Level := Default_Compression; Strategy : Strategy_Type := Default_Strategy; Method : Compression_Method := Deflated; Window_Bits : Window_Bits_Type := Default_Window_Bits; Memory_Level : Memory_Level_Type := Default_Memory_Level; Header : Header_Type := Default); -- Compressor initialization. -- When Header parameter is Auto or Default, then default zlib header -- would be provided for compressed data. -- When Header is GZip, then gzip header would be set instead of -- default header. -- When Header is None, no header would be set for compressed data. procedure Inflate_Init (Coder : in out Coder_Type; Window_Bits : Window_Bits_Type := Default_Window_Bits; Header : Header_Type := Default); -- Decompressor initialization. -- Default header type mean that ZLib default header is expecting in the -- input compressed stream. -- Header type None mean that no header is expecting in the input stream. -- GZip header type mean that GZip header is expecting in the -- input compressed stream. -- Auto header type mean that header type (GZip or Native) would be -- detected automatically in the input stream. -- Note that header types parameter values None, GZip and Auto are -- supported for inflate routine only in ZLib versions 1.2.0.2 and later. -- Deflate_Init is supporting all header types. overriding function Is_Open (Coder : Coder_Type) return Boolean; -- Indicates that coder is ready to transcode data, i.e either Easy_Encoder -- or Auto_Decoder called. overriding procedure Transcode (Coder : in out Coder_Type; In_Data : Stream_Element_Array; In_Last : out Stream_Element_Offset; Out_Data : out Stream_Element_Array; Out_Last : out Stream_Element_Offset; Flush : Flush_Mode := No_Flush); -- Transcodes data from In_Data to Out_Data. -- In_Last is the index of last element from In_Data accepted by -- the Coder. -- Out_Last is the index of the last element written to Out_Data. -- To tell the Coder that incoming data is complete pass Finish as the -- Flush parameter and call Transcoder with empty In_Data until Stream_End -- routine indicates end of stream. overriding function Total_In (Coder : Coder_Type) return Stream_Element_Count; -- Returns the total amount of input data sent into the coder overriding function Total_Out (Coder : Coder_Type) return Stream_Element_Count; -- Returns the total amount of output data taken from the coder overriding function Finished (Coder : Coder_Type) return Boolean; -- Indicates that incoming data stream is complete and all internally -- processed data is out of coder. overriding procedure Close (Coder : in out Coder_Type); -- Frees internal coder memory allocations. Note that coder is derived from -- Limited_Controlled and will free all memory automatically on -- finalization. ZLib_Error : exception; private pragma Assert (Stream_Element'Size = 8); pragma Assert (Stream_Element'Modulus = 2**8); type Compression_Method is new Integer range 8 .. 8; type Strategy_Type is new Integer range 0 .. 3; Filtered : constant Strategy_Type := 1; Huffman_Only : constant Strategy_Type := 2; RLE : constant Strategy_Type := 3; Default_Strategy : constant Strategy_Type := 0; Deflated : constant Compression_Method := 8; type Z_Stream_Access is access all Thin.Z_Stream; type Coder_Type is new Ada.Finalization.Limited_Controlled and Coder_Interface with record Stream : Z_Stream_Access; Compression : Boolean; Stream_End : Boolean; Header : Header_Type; CRC : Interfaces.Unsigned_32; Offset : Stream_Element_Offset; -- Offset for gzip header/footer output end record; overriding procedure Finalize (Coder : in out Coder_Type); end GNATCOLL.Coders.ZLib; gnatcoll-bindings-25.0.0/zlib/gnatcoll_zlib.gpr000066400000000000000000000073641464374334300215160ustar00rootroot00000000000000------------------------------------------------------------------------------ -- G N A T C O L L -- -- -- -- Copyright (C) 2019-2020, 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 -- -- . -- -- -- ------------------------------------------------------------------------------ with "gnatcoll_core"; library project GnatColl_ZLib is Version := External ("GNATCOLL_VERSION", "0.0"); Name := "gnatcoll_zlib"; type Build_Type is ("DEBUG", "PROD"); Build : Build_Type := External ("GNATCOLL_BUILD_MODE", External ("BUILD", "PROD")); type Library_Type_Type is ("relocatable", "static", "static-pic"); Library_Type : Library_Type_Type := External ("LIBRARY_TYPE", "static"); for Source_Dirs use ("."); for Library_Kind use Library_Type; for Object_Dir use "obj/" & Project'Library_Kind; for Library_Dir use "lib/" & Project'Library_Kind; for Library_Name use Name; Link_Opt := "-lz"; case Library_Type is when "relocatable" => for Leading_Library_Options use External_As_List ("LDFLAGS", " "); for Library_Version use "lib" & Name & Gnatcoll_Core.So_Ext & "." & Version; for Library_Options use (Link_Opt); when others => null; end case; for Languages use ("Ada"); package Compiler is case Build is when "DEBUG" => for Switches ("Ada") use ("-g", "-O0", "-gnata", "-gnatVa", "-gnatQ", "-gnaty", "-gnateE", "-gnatwaCJe", "-fstack-check"); when "PROD" => -- Do not use -gnatwe for production mode for Switches ("Ada") use ("-O2", "-gnatn", "-gnatwaCJ"); end case; for Switches ("Ada") use Compiler'Switches ("Ada") & External_As_List ("ADAFLAGS", " "); end Compiler; package Binder is case Build is when "DEBUG" => for Switches ("Ada") use ("-E"); when "PROD" => null; end case; end Binder; package Builder is case Build is when "DEBUG" => for Global_Configuration_Pragmas use "../gnat_debug.adc"; when "PROD" => null; end case; end Builder; package Linker is for Linker_Options use (Link_Opt); end Linker; package Ide is for VCS_Kind use "Git"; end Ide; end GnatColl_ZLib; gnatcoll-bindings-25.0.0/zlib/setup.py000077500000000000000000000033671464374334300176750ustar00rootroot00000000000000#!/usr/bin/env python import logging import os import sys sys.path.append(os.path.dirname(os.path.dirname(os.path.abspath(__file__)))) from setup_support import SetupApp class GNATCollZLib(SetupApp): name = 'gnatcoll_zlib' project = 'gnatcoll_zlib.gpr' description = 'GNATColl ZLib bindings' def create(self): super(GNATCollZLib, self).create() self.build_cmd.add_argument( '--debug', help='build project in debug mode', action="store_true", default=False) def update_config(self, config, args): logging.info('%-26s %s', 'Libraries kind', ", ".join(config.data['library_types'])) # Set library version with open(os.path.join(config.source_dir, '..', 'version_information'), 'r') as fd: version = fd.read().strip() config.set_data('GNATCOLL_VERSION', version, sub='gprbuild') # Set build mode config.set_data('BUILD', 'DEBUG' if args.debug else 'PROD', sub='gprbuild') logging.info('%-26s %s', 'Build mode', config.data['gprbuild']['BUILD']) def variants(self, config, cmd): result = [] for library_type in config.data['library_types']: gpr_vars = {'LIBRARY_TYPE': library_type, 'GPR_BUILD': library_type} if cmd == 'install': result.append((['--build-name=%s' % library_type, '--build-var=LIBRARY_TYPE'], gpr_vars)) else: result.append(([], gpr_vars)) return result if __name__ == '__main__': app = GNATCollZLib() sys.exit(app.run())