diff --git a/pkgs/compatibility-pkgs/compatibility-test/COPYING.txt b/pkgs/compatibility-pkgs/compatibility-test/COPYING.txt new file mode 100644 index 0000000000..4432540474 --- /dev/null +++ b/pkgs/compatibility-pkgs/compatibility-test/COPYING.txt @@ -0,0 +1,676 @@ + + 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 +. + diff --git a/pkgs/compatibility-pkgs/compatibility-test/COPYING_LESSER.txt b/pkgs/compatibility-pkgs/compatibility-test/COPYING_LESSER.txt new file mode 100644 index 0000000000..fc8a5de7ed --- /dev/null +++ b/pkgs/compatibility-pkgs/compatibility-test/COPYING_LESSER.txt @@ -0,0 +1,165 @@ + GNU LESSER 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. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser 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 +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/pkgs/compatibility-pkgs/compatibility-test/LICENSE.txt b/pkgs/compatibility-pkgs/compatibility-test/LICENSE.txt new file mode 100644 index 0000000000..3ae2623a38 --- /dev/null +++ b/pkgs/compatibility-pkgs/compatibility-test/LICENSE.txt @@ -0,0 +1,10 @@ +compatibility-lib +Copyright (c) 2010-2013 PLT Design Inc. + +This package is distributed under the GNU Lesser General Public +License (LGPL). This means that you can link Racket into proprietary +applications, provided you follow the rules stated in the LGPL. You +can also modify this package; if you distribute a modified version, +you must distribute it under the terms of the LGPL, which in +particular means that you must release the source code for the +modified software. See COPYING_LESSER.txt for more information. diff --git a/pkgs/compatibility-pkgs/compatibility-test/info.rkt b/pkgs/compatibility-pkgs/compatibility-test/info.rkt new file mode 100644 index 0000000000..cebd00514f --- /dev/null +++ b/pkgs/compatibility-pkgs/compatibility-test/info.rkt @@ -0,0 +1,8 @@ +#lang info +(define collection 'multi) +(define deps '("base" + "racket-test")) + +(define pkg-desc "tests for \"compatibility-lib\"") + +(define pkg-authors '(mflatt)) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/awk.rktl b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/awk.rktl similarity index 87% rename from pkgs/racket-pkgs/racket-test/tests/racket/awk.rktl rename to pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/awk.rktl index 73d00c8873..6b22fcb6a2 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/awk.rktl +++ b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/awk.rktl @@ -8,8 +8,8 @@ (define-syntax (test-awk stx) (syntax-case stx () [(_ val body ...) - (with-syntax ([next (datum->syntax-object stx 'next)] - [result (datum->syntax-object stx 'result)]) + (with-syntax ([next (datum->syntax stx 'next)] + [result (datum->syntax stx 'result)]) (syntax (let* ([p (open-input-string "Hello world.")] [next (lambda () (let ([o (read p)]) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/binc.rktl b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/binc.rktl similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/binc.rktl rename to pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/binc.rktl diff --git a/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/cmdline.rktl b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/cmdline.rktl new file mode 100644 index 0000000000..95b88c3acd --- /dev/null +++ b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/cmdline.rktl @@ -0,0 +1,38 @@ + +(load-relative "loadtest.rktl") + +(Section 'command-line) + +(require mzlib/cmdline) + +(test (void) 'cmdline + (command-line "something" #("-ab") + (once-each + [("-a") "ok" 5] + [("-b" "--more") "Help" 7]))) + +;; test that keywords are compared for the literal symbol +(test "foo" 'cmdline + (let ([once-each 3] [args "args"]) + (command-line "something" #("-ab" "foo") + (once-each + [("-a") "ok" 5] + [("-b" "--more") "Help" 7]) + (args (x) x)))) + +(syntax-test #'(command-line)) +(syntax-test #'(command-line "hello")) +(err/rt-test (command-line 'hello #("ok"))) +(syntax-test #'(command-line "hello" #("ok") (bad))) +(syntax-test #'(command-line "hello" #("ok") (once-any ()))) +(syntax-test #'(command-line "hello" #("ok") (once-any ("-ok")))) +(syntax-test #'(command-line "hello" #("ok") (once-any ("-ok" "the ok flag")))) +(syntax-test #'(command-line "hello" #("ok") (once-any ("-ok" a "the ok flag")))) +(syntax-test #'(command-line "hello" #("ok") (once-any ("-ok" (a) "the ok flag")))) +(syntax-test #'(command-line "hello" #("ok") (once-any ("-ok" a "the ok flag") ()))) +(syntax-test #'(command-line "hello" #("ok") (args 'done) (once-any ("-ok" a "the ok flag" 7)))) +(syntax-test #'(command-line "hello" #("ok") (args (ok) 'done) (once-any ("-ok" a "the ok flag" 7)))) +(syntax-test #'(command-line "hello" #("ok") (=> 'done) (once-any ("-ok" a "the ok flag" 7)))) +(syntax-test #'(command-line "hello" #("ok") (=> 1 2 3 4) (once-any ("-ok" a "the ok flag" 7)))) + +(report-errs) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/compat.rktl b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/compat.rktl similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/compat.rktl rename to pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/compat.rktl diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract-mzlib-test.rktl b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/contract-mzlib-test.rktl similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/contract-mzlib-test.rktl rename to pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/contract-mzlib-test.rktl diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/etc.rktl b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/etc.rktl similarity index 67% rename from pkgs/racket-pkgs/racket-test/tests/racket/etc.rktl rename to pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/etc.rktl index 4b462e947b..41256aeca6 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/etc.rktl +++ b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/etc.rktl @@ -49,5 +49,21 @@ (define goo 10) 12)) +(let () + (test 3 (rec f (λ (x) 3)) 3) + (test 3 (rec f (λ (x) x)) 3) + (test 2 (rec f (λ (x) (if (= x 3) (f 2) x))) 3) + (test 3 (rec (f x) 3) 3) + (test 3 (rec (f x) x) 3) + (test 2 (rec (f x) (if (= x 3) (f 2) x)) 3) + (test 2 (rec (f x . y) (car y)) 1 2 3) + (test 2 'no-duplications + (let ([x 1]) (rec ignored (begin (set! x (+ x 1)) void)) x)) + (test 'f object-name (rec (f x) x)) + (test 'f object-name (rec (f x . y) x)) + (test 'f object-name (rec f (lambda (x) x))) + (test (list 2) (rec (f . x) (if (= (car x) 3) (f 2) x)) 3)) + + (report-errs) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/kw.rktl b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/kw.rktl similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/kw.rktl rename to pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/kw.rktl diff --git a/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/loadtest.rktl b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/loadtest.rktl new file mode 100644 index 0000000000..97a89e74e7 --- /dev/null +++ b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/loadtest.rktl @@ -0,0 +1 @@ +(load (collection-file-path "loadtest.rktl" "tests/racket")) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/macrolib.rktl b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/macrolib.rktl similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/macrolib.rktl rename to pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/macrolib.rktl diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/pconvert.rktl b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/pconvert.rktl similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/pconvert.rktl rename to pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/pconvert.rktl diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/restart.rktl b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/restart.rktl similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/restart.rktl rename to pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/restart.rktl diff --git a/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/serialize.rktl b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/serialize.rktl new file mode 100644 index 0000000000..7b7cc5b3e9 --- /dev/null +++ b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/serialize.rktl @@ -0,0 +1,16 @@ + +(load-relative "loadtest.rktl") + +(Section 'serialization) + +(module ser-mod mzscheme + (require mzlib/serialize) + (provide ser-mod-test) + + (define-serializable-struct foo (a b)) + + (define (ser-mod-test) + (foo-a (deserialize (serialize (make-foo 1 2)))))) + +(require 'ser-mod) +(test 1 ser-mod-test) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/string-mzlib.rktl b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/string-mzlib.rktl similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/string-mzlib.rktl rename to pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/string-mzlib.rktl diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/structlib.rktl b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/structlib.rktl similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/structlib.rktl rename to pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/structlib.rktl diff --git a/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/test.rkt b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/test.rkt new file mode 100644 index 0000000000..3d4b07add8 --- /dev/null +++ b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/test.rkt @@ -0,0 +1,4 @@ +#lang racket/load + +(define quiet-load (collection-file-path "tests.rktl" "tests" "mzlib")) +(load (collection-file-path "quiet.rktl" "tests" "racket")) diff --git a/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/testing.rktl b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/testing.rktl new file mode 100644 index 0000000000..8e3014ed44 --- /dev/null +++ b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/testing.rktl @@ -0,0 +1 @@ +(load (collection-file-path "testing.rktl" "tests/racket")) \ No newline at end of file diff --git a/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/tests.rktl b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/tests.rktl new file mode 100644 index 0000000000..2748e175d6 --- /dev/null +++ b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/tests.rktl @@ -0,0 +1,17 @@ +(load "loadtest.rktl") + +(load-in-sandbox "kw.rktl") +(load-in-sandbox "awk.rktl") +(load-in-sandbox "etc.rktl") +(load-in-sandbox "compat.rktl") +(load-in-sandbox "unit.rktl") +(load-in-sandbox "unitsig.rktl") +(load-in-sandbox "string-mzlib.rktl") +(load-in-sandbox "threadlib.rktl") +(load-in-sandbox "serialize.rktl") +(load-in-sandbox "pconvert.rktl") +(load-in-sandbox "cmdline.rktl") +(load-in-sandbox "restart.rktl") +(load-in-sandbox "macrolib.rktl") +(load-in-sandbox "structlib.rktl") +(load-in-sandbox "contract-mzlib-test.rktl") diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/threadlib.rktl b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/threadlib.rktl similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/threadlib.rktl rename to pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/threadlib.rktl diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/ttt/uinc4.rktl b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/ttt/uinc4.rktl similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/ttt/uinc4.rktl rename to pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/ttt/uinc4.rktl diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/uinc.rktl b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/uinc.rktl similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/uinc.rktl rename to pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/uinc.rktl diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/uinc2.rktl b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/uinc2.rktl similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/uinc2.rktl rename to pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/uinc2.rktl diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/uinc3.rktl b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/uinc3.rktl similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/uinc3.rktl rename to pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/uinc3.rktl diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/unit.rktl b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/unit.rktl similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/unit.rktl rename to pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/unit.rktl diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/unitsig.rktl b/pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/unitsig.rktl similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/unitsig.rktl rename to pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/unitsig.rktl diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/ctool.rkt b/pkgs/compiler-pkgs/compiler-test/tests/compiler/ctool.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/ctool.rkt rename to pkgs/compiler-pkgs/compiler-test/tests/compiler/ctool.rkt diff --git a/pkgs/gui-pkgs/gui-test/info.rkt b/pkgs/gui-pkgs/gui-test/info.rkt index e20fb4dd3a..dffd87c906 100644 --- a/pkgs/gui-pkgs/gui-test/info.rkt +++ b/pkgs/gui-pkgs/gui-test/info.rkt @@ -13,7 +13,8 @@ "rackunit-lib" "scribble-lib" "pconvert-lib" - "compatibility-lib")) + "compatibility-lib" + "sandbox-lib")) (define pkg-desc "tests for \"gui\"") diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/cache-image-snip-test.rktl b/pkgs/gui-pkgs/gui-test/tests/gracket/cache-image-snip-test.rktl similarity index 99% rename from pkgs/racket-pkgs/racket-test/tests/racket/cache-image-snip-test.rktl rename to pkgs/gui-pkgs/gui-test/tests/gracket/cache-image-snip-test.rktl index 169cd19950..089b45d82a 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/cache-image-snip-test.rktl +++ b/pkgs/gui-pkgs/gui-test/tests/gracket/cache-image-snip-test.rktl @@ -1,4 +1,4 @@ -(load-relative "loadtest.rktl") +(load (collection-file-path "loadtest.rktl" "tests/racket")) (require racket/gui/base mrlib/cache-image-snip diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/sandbox-gui.rkt b/pkgs/gui-pkgs/gui-test/tests/gracket/sandbox-gui.rkt similarity index 100% rename from pkgs/racket-pkgs/racket-test/tests/racket/sandbox-gui.rkt rename to pkgs/gui-pkgs/gui-test/tests/gracket/sandbox-gui.rkt diff --git a/pkgs/main-distribution-test/info.rkt b/pkgs/main-distribution-test/info.rkt index e602092e6f..1468edfa2b 100644 --- a/pkgs/main-distribution-test/info.rkt +++ b/pkgs/main-distribution-test/info.rkt @@ -18,6 +18,7 @@ "scribble-test" "unstable-test" "compiler-test" + "compatibility-test" "data-test" "net-test" "planet-test" diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/net.rktl b/pkgs/net-pkgs/net-test/tests/net/base64.rkt similarity index 72% rename from pkgs/racket-pkgs/racket-test/tests/racket/net.rktl rename to pkgs/net-pkgs/net-test/tests/net/base64.rkt index 33e1c297ea..a2a9a78506 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/net.rktl +++ b/pkgs/net-pkgs/net-test/tests/net/base64.rkt @@ -1,16 +1,9 @@ +#lang racket/base +(require net/base64) -(load-relative "loadtest.rktl") - -(Section 'net) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; other net tests -;; - -(require net/base64 - net/qp - mzlib/port) +(define (test expect f . args) + (unless (equal? expect (apply f args)) + (error "fail"))) (test #"" base64-encode #"") (test #"" base64-encode #"" #"<>") @@ -18,5 +11,3 @@ base64-encode #"Why do axe murderers only attack\nWhen you're partially nude\nOr you're taking a bath") (test #"V2h5IGRvIGF4ZSBtdXJkZXJlcnMgb25seSBhdHRhY2sKV2hlbiB5b3UncmUgcGFydGlhbGx5<>IG51ZGUKT3IgeW91J3JlIHRha2luZyBhIGJhdGg=<>" base64-encode #"Why do axe murderers only attack\nWhen you're partially nude\nOr you're taking a bath" #"<>") - -(report-errs) diff --git a/pkgs/net-pkgs/net-test/tests/net/head.rkt b/pkgs/net-pkgs/net-test/tests/net/head.rkt index 2077416c47..f45c0a1aac 100644 --- a/pkgs/net-pkgs/net-test/tests/net/head.rkt +++ b/pkgs/net-pkgs/net-test/tests/net/head.rkt @@ -91,6 +91,32 @@ (append-headers test-header/bytes #"Athird: data\r\n\r\n") => #"From: abc\r\nTo: field is\r\n continued\r\nAnother: zoo\r\n continued\r\nAthird: data\r\n\r\n" - )) + ) + + (let ([test (lambda (expect f . args) + (unless (equal? expect (apply f args)) + (error "failed")))]) + (for-each + (lambda (addr) + (test '("o.gu@racket-lang.com") extract-addresses (car addr) 'address) + (test '("o.gu@racket-lang.com" "o.gu@racket-lang.com") extract-addresses + (format "~a, ~a" (car addr) (car addr)) + 'address) + (test (list (cdr addr)) extract-addresses (car addr) 'name) + (for-each + (lambda (addr2) + (let ([two (format " ~a, \n\t~a" (car addr) (car addr2))]) + (test '("o.gu@racket-lang.com" "s.gu@racket-lang.org") extract-addresses two 'address) + (test (list (cdr addr) (cdr addr2)) extract-addresses two 'name))) + '(("s.gu@racket-lang.org" . "s.gu@racket-lang.org") + ("" . "s.gu@racket-lang.org") + ("s.gu@racket-lang.org (Gu, Sophia)" . "Gu, Sophia") + ("s.gu@racket-lang.org (Sophia Gu)" . "Sophia Gu") + ("s.gu@racket-lang.org (Sophia \"Sophie\" Gu)" . "Sophia \"Sophie\" Gu") + ("Sophia Gu " . "Sophia Gu") + ("\"Gu, Sophia\" " . "\"Gu, Sophia\"") + ("\"Gu, Sophia (Sophie)\" " . "\"Gu, Sophia (Sophie)\"")))) + '(("o.gu@racket-lang.com" . "o.gu@racket-lang.com"))) + (printf "more tests passed\n"))) (module+ test (require (submod ".." main))) ; for raco test & drdr diff --git a/pkgs/net-pkgs/net-test/tests/net/imap.rkt b/pkgs/net-pkgs/net-test/tests/net/imap.rkt new file mode 100644 index 0000000000..d9745535f0 --- /dev/null +++ b/pkgs/net-pkgs/net-test/tests/net/imap.rkt @@ -0,0 +1,182 @@ +#lang racket/base +(require openssl/mzssl + net/imap + mzlib/etc) + +(define (test expect f . args) + (define got (if (procedure? f) + (apply f args) + (car args))) + (unless (equal? expect got) + (error 'test "failed: ~s vs. ~s" expect got))) + +(define imap-config-file + (build-path (find-system-path 'home-dir) ".imap-test-config")) + +(when (file-exists? imap-config-file) + (define config (with-input-from-file imap-config-file + read)) + + (define imap-server (hash-ref config 'imap-server)) + (define imap-port-no (hash-ref config 'imap-port-no)) + (define username (hash-ref config 'username)) + (define pw (hash-ref config 'pw)) + (define mailbox-name (hash-ref config 'mailbox-name "INBOX.tmp")) ;; !!! ALL CONTENT WILL BE DELETED !!! + + (define (test-connect) + (if (zero? (random 2)) + (parameterize ([imap-port-number 993]) + (imap-connect #:tls? #t imap-server username pw mailbox-name)) + (let ([c (ssl-make-client-context)]) + (let-values ([(in out) (ssl-connect imap-server imap-port-no c)]) + (imap-connect* in out username pw mailbox-name))))) + + (define-values (imap cnt recent) (test-connect)) + + (printf "Msgs: ~a; Validity: ~a\n" cnt (imap-uidvalidity imap)) + + (test cnt imap-messages imap) + (test recent imap-recent imap) + (test #t number? (imap-uidvalidity imap)) + (test #f imap-pending-expunges? imap) + (test #f imap-pending-updates? imap) + (test #f imap-new? imap) + + (define (delete-all) + (let ([cnt (imap-messages imap)]) + (unless (zero? cnt) + (let ([all (build-list cnt add1)]) + (test (void) imap-store imap '+ all '|\Deleted|) + (test (void) imap-expunge imap) + (test #t imap-pending-expunges? imap) + (test all imap-get-expunges imap) + (test null imap-get-expunges imap) + (test #f imap-pending-expunges? imap))))) + + (delete-all) + (test #f imap-new? imap) + (test 0 imap-messages imap) + (test '(0 0) 'noop (let-values ([(a b) (imap-noop imap)]) + (list a b))) + (test (void) imap-poll imap) + (test 0 imap-messages imap) + (test 0 imap-recent imap) + + (test #f imap-new? imap) + + (define (add-one content total) + (test (void) imap-append imap mailbox-name content) + (imap-noop imap) + (test total imap-messages imap) + (test #t imap-new? imap) + (let ([uids (imap-get-messages imap (build-list total add1) '(uid))]) + (test #t list? uids) + (test total length uids) + (let ([l (list-ref uids (sub1 total))]) + (test #t list? l) + (test 1 length l) + (test #t number? (car l)) + (car l)))) + + (define sample-head #"Subject: Hello\r\n\r\n") + (define sample-body #"Hi there.\r\n") + + (let ([uid (add-one (bytes-append sample-head sample-body) 1)]) + (test (list (list uid + sample-head + sample-body + '(|\Seen| |\Recent|))) + imap-get-messages imap '(1) '(uid header body flags))) + (test (void) imap-store imap '+ '(1) (list (symbol->imap-flag 'answered))) + (test (list '((|\Answered| |\Seen| |\Recent|))) imap-get-messages imap '(1) '(flags)) + (test (void) imap-store imap '- '(1) (list (symbol->imap-flag 'answered))) + (test (list '((|\Seen| |\Recent|))) imap-get-messages imap '(1) '(flags)) + (test (void) imap-store imap '+ '(1) (list (symbol->imap-flag 'deleted))) + (test (list '((|\Deleted| |\Seen| |\Recent|))) imap-get-messages imap '(1) '(flags)) + (test (void) imap-store imap '! '(1) (list (symbol->imap-flag 'answered))) + (test (list '((|\Answered| |\Recent|))) imap-get-messages imap '(1) '(flags)) + + (test #f imap-pending-updates? imap) + (test null imap-get-updates imap) + + ;; Test multiple-client access: + (let () + (define-values (imap2 cnt2 recent2) (test-connect)) + (test '(1 0) list cnt2 recent2) + + (let ([uid (add-one (bytes-append sample-head sample-body) 2)]) + (let loop ([n 5]) + (when (zero? n) + (imap-noop imap2)) + (imap-poll imap2) + (unless (imap-new? imap2) + (sleep 0.2) + (loop (sub1 n)))) + (test #t imap-new? imap2) + (test 2 imap-messages imap2) + (let ([uids (imap-get-messages imap2 '(2) '(uid))]) + (test uid caar uids))) + + ;; Delete message on imap2, check notifcation to imap + (test (void) imap-store imap2 '+ '(2) (list (symbol->imap-flag 'deleted))) + (test (void) imap-expunge imap2) + (test '(2) imap-get-expunges imap2) + (imap-noop imap) + (test 'exn values (with-handlers ([exn:fail:contract? (lambda (x) 'exn)]) + (imap-store imap '+ '(2) (list (symbol->imap-flag 'answered))))) + (test #t imap-pending-expunges? imap) + (test '(2) imap-get-expunges imap) + + ;; Adjust flags on imap2, check notifcation to imap + (test #f imap-pending-updates? imap) + (test (void) imap-store imap2 '+ '(1) (list (symbol->imap-flag 'deleted))) + (imap-noop imap) + (test #t imap-pending-updates? imap) + (test #t list? (imap-get-updates imap)) + (test #f imap-pending-updates? imap) + + ;; Check that multiple updates are collapsed: + (test (void) imap-store imap2 '- '(1) (list (symbol->imap-flag 'deleted))) + (imap-noop imap) + (test #t imap-pending-updates? imap) + (test (void) imap-store imap2 '+ '(1) (list (symbol->imap-flag 'deleted))) + (test (void) imap-store imap2 '- '(1) (list (symbol->imap-flag 'deleted))) + (imap-noop imap) + (test #t imap-pending-updates? imap) + (test 1 length (imap-get-updates imap)) + + (test (void) imap-reset-new! imap2) + (add-one (bytes-append sample-head sample-body) 2) + (add-one (bytes-append sample-head sample-body) 3) + (add-one (bytes-append sample-head sample-body) 4) + (add-one (bytes-append sample-head sample-body) 5) + (imap-noop imap2) + (test #t imap-new? imap2) + (test 5 imap-messages imap) + (test 5 imap-messages imap2) + + (test #t list? (imap-get-messages imap '(1 2 3 4 5) '(uid))) + (test #t list? (imap-get-messages imap2 '(1 2 3 4 5) '(uid))) + + ;; Test deleteing multiple messages, and shifts in flag updates + (test (void) imap-store imap2 '+ '(2 4) (list (symbol->imap-flag 'deleted))) + (test (void) imap-store imap2 '+ '(3 5) (list (symbol->imap-flag 'answered))) + (test (void) imap-expunge imap2) + (imap-noop imap) + (imap-noop imap2) + (test #t imap-pending-expunges? imap) + (test #t imap-pending-expunges? imap2) + (test '(2 4) imap-get-expunges imap) + (test '(2 4) imap-get-expunges imap2) + (test #t imap-pending-updates? imap) + (test '(2 3) map car (imap-get-updates imap)) + + (imap-disconnect imap2)) + + (imap-disconnect imap) + + (printf "tests passed\n")) + + + + diff --git a/pkgs/plt-services/meta/props b/pkgs/plt-services/meta/props index 3427383555..2d8cd1d3ff 100755 --- a/pkgs/plt-services/meta/props +++ b/pkgs/plt-services/meta/props @@ -651,6 +651,16 @@ path/s is either such a string or a list of them. "pkgs/compatibility-pkgs/compatibility-lib/mzlib/plt-match.rkt" responsible (samth) "pkgs/compatibility-pkgs/compatibility-lib/mzlib/shared.rkt" responsible (robby) "pkgs/compatibility-pkgs/compatibility-lib/mzlib/traceld.rkt" drdr:command-line #f +"pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/awk.rktl" drdr:command-line #f +"pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/binc.rktl" drdr:command-line #f +"pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/contract-mzlib-test.rktl" responsible (robby) drdr:command-line (racket "-r" *) +"pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/pconvert.rktl" drdr:command-line #f +"pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/serialize.rktl" drdr:random #t +"pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/structlib.rktl" drdr:random #t +"pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/tests.rktl" drdr:command-line #f +"pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/threadlib.rktl" drdr:random #t +"pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/ttt/uinc4.rktl" drdr:command-line #f +"pkgs/compatibility-pkgs/compatibility-test/tests/mzlib/uinc3.rktl" drdr:command-line #f "pkgs/compiler-pkgs" responsible (mflatt jay) "pkgs/compiler-pkgs/compiler-lib/compiler/commands/exe-dir.rkt" drdr:command-line #f "pkgs/compiler-pkgs/compiler-lib/compiler/commands/exe.rkt" drdr:command-line #f @@ -1282,47 +1292,35 @@ path/s is either such a string or a list of them. "pkgs/racket-pkgs/racket-test/tests/pkg/test.rkt" drdr:command-line (raco "test" *) "pkgs/racket-pkgs/racket-test/tests/racket" responsible (mflatt) "pkgs/racket-pkgs/racket-test/tests/racket/all.rktl" drdr:command-line #f -"pkgs/racket-pkgs/racket-test/tests/racket/awk.rktl" drdr:command-line #f -"pkgs/racket-pkgs/racket-test/tests/racket/basic.rktl" drdr:random #t -"pkgs/racket-pkgs/racket-test/tests/racket/binc.rktl" drdr:command-line #f +"pkgs/racket-pkgs/racket-test/tests/racket/basic.rktl" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/racket/chaperone.rktl" drdr:command-line #f -"pkgs/racket-pkgs/racket-test/tests/racket/chez-module.rktl" drdr:command-line #f -"pkgs/racket-pkgs/racket-test/tests/racket/cm.rktl" drdr:random #t -"pkgs/racket-pkgs/racket-test/tests/racket/compile.rktl" drdr:command-line #f +"pkgs/racket-pkgs/racket-test/tests/racket/cm.rktl" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/racket/contmark.rktl" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/racket/contract" responsible (robby) "pkgs/racket-pkgs/racket-test/tests/racket/contract/all.rkt" drdr:command-line (raco "make" *) -"pkgs/racket-pkgs/racket-test/tests/racket/contract-mzlib-test.rktl" responsible (robby) drdr:command-line (racket "-r" *) "pkgs/racket-pkgs/racket-test/tests/racket/contract-opt-tests.rkt" responsible (robby) drdr:command-line (racket "-r" *) "pkgs/racket-pkgs/racket-test/tests/racket/contract-stress-argmin.rkt" responsible (robby) drdr:command-line (racket "-r" *) "pkgs/racket-pkgs/racket-test/tests/racket/contract-stress-take-right.rkt" responsible (robby) drdr:command-line (racket "-r" *) -"pkgs/racket-pkgs/racket-test/tests/racket/date.rktl" drdr:random #t +"pkgs/racket-pkgs/racket-test/tests/racket/date.rktl" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/racket/embed-in-c.rkt" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/racket/expand.rktl" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/racket/file.rktl" drdr:command-line #f -"pkgs/racket-pkgs/racket-test/tests/racket/filelib.rktl" drdr:command-line #f drdr:timeout 360 -"pkgs/racket-pkgs/racket-test/tests/racket/fixnum.rktl" drdr:timeout 360 drdr:random #t -"pkgs/racket-pkgs/racket-test/tests/racket/foreign-test.rktl" drdr:random #t +"pkgs/racket-pkgs/racket-test/tests/racket/filelib.rktl" drdr:command-line #f +"pkgs/racket-pkgs/racket-test/tests/racket/fixnum.rktl" drdr:command-line #f +"pkgs/racket-pkgs/racket-test/tests/racket/foreign-test.rktl" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/racket/format.rkt" drdr:random #t -"pkgs/racket-pkgs/racket-test/tests/racket/imap.rktl" drdr:command-line #f -"pkgs/racket-pkgs/racket-test/tests/racket/iostream.rktl" drdr:random #t +"pkgs/racket-pkgs/racket-test/tests/racket/iostream.rktl" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/racket/link.rkt" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/racket/list.rktl" drdr:command-line #f -"pkgs/racket-pkgs/racket-test/tests/racket/module.rktl" drdr:random #t -"pkgs/racket-pkgs/racket-test/tests/racket/mz-tests.rktl" drdr:command-line #f -"pkgs/racket-pkgs/racket-test/tests/racket/mzlib-tests.rktl" drdr:command-line #f -"pkgs/racket-pkgs/racket-test/tests/racket/mzq.rktl" drdr:timeout 200 +"pkgs/racket-pkgs/racket-test/tests/racket/module.rktl" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/racket/number.rktl" drdr:command-line #f -"pkgs/racket-pkgs/racket-test/tests/racket/object-old.rktl" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/racket/object.rktl" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/racket/optimize.rktl" drdr:command-line #f -"pkgs/racket-pkgs/racket-test/tests/racket/pack.rktl" drdr:random #t -"pkgs/racket-pkgs/racket-test/tests/racket/package-gen.rktl" drdr:timeout 600 drdr:random #t +"pkgs/racket-pkgs/racket-test/tests/racket/pack.rktl" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/racket/parallel-build.rkt" drdr:random #t "pkgs/racket-pkgs/racket-test/tests/racket/parallel-plot.rkt" drdr:timeout 400 "pkgs/racket-pkgs/racket-test/tests/racket/parallel.rktl" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/racket/path.rktl" drdr:command-line #f -"pkgs/racket-pkgs/racket-test/tests/racket/pconvert.rktl" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/racket/place-chan-rand-help.rkt" responsible (tewk) "pkgs/racket-pkgs/racket-test/tests/racket/place-chan-rand.rkt" responsible (tewk) "pkgs/racket-pkgs/racket-test/tests/racket/place-channel-fd.rkt" responsible (tewk) drdr:random #t @@ -1339,45 +1337,38 @@ path/s is either such a string or a list of them. "pkgs/racket-pkgs/racket-test/tests/racket/prompt-sfs.rkt" drdr:random #t "pkgs/racket-pkgs/racket-test/tests/racket/prompt-tests.rktl" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/racket/prompt.rktl" drdr:command-line #f -"pkgs/racket-pkgs/racket-test/tests/racket/quiet.rktl" drdr:timeout 600 +"pkgs/racket-pkgs/racket-test/tests/racket/quiet.rktl" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/racket/read.rktl" drdr:command-line #f -"pkgs/racket-pkgs/racket-test/tests/racket/resource.rktl" drdr:random #t +"pkgs/racket-pkgs/racket-test/tests/racket/resource.rktl" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/racket/runaway-place.rkt" drdr:random #t "pkgs/racket-pkgs/racket-test/tests/racket/rx.rktl" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/racket/scheme-tests.rktl" drdr:command-line #f -"pkgs/racket-pkgs/racket-test/tests/racket/sequence.rktl" drdr:random #t -"pkgs/racket-pkgs/racket-test/tests/racket/serialize.rktl" drdr:random #t +"pkgs/racket-pkgs/racket-test/tests/racket/sequence.rktl" drdr:command-line #f +"pkgs/racket-pkgs/racket-test/tests/racket/serialize.rktl" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/racket/set.rktl" drdr:command-line #f -"pkgs/racket-pkgs/racket-test/tests/racket/setup.rktl" drdr:random #t +"pkgs/racket-pkgs/racket-test/tests/racket/setup.rktl" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/racket/shared-tests.rktl" drdr:command-line #f -"pkgs/racket-pkgs/racket-test/tests/racket/sp.rktl" drdr:random #t "pkgs/racket-pkgs/racket-test/tests/racket/srcloc.rktl" responsible (cce) "pkgs/racket-pkgs/racket-test/tests/racket/stress" responsible (jay) drdr:random #t "pkgs/racket-pkgs/racket-test/tests/racket/stress/contract-lifting.rkt" responsible (robby sstrickl) "pkgs/racket-pkgs/racket-test/tests/racket/stress/dict.rkt" drdr:timeout 180 "pkgs/racket-pkgs/racket-test/tests/racket/stress/fuzz.rkt" responsible (samth mflatt) drdr:command-line (racket * "-c") drdr:timeout 600 "pkgs/racket-pkgs/racket-test/tests/racket/stress/module-stack.rkt" drdr:timeout 500 -"pkgs/racket-pkgs/racket-test/tests/racket/structlib.rktl" drdr:random #t -"pkgs/racket-pkgs/racket-test/tests/racket/stx.rktl" drdr:random #t -"pkgs/racket-pkgs/racket-test/tests/racket/submodule.rktl" drdr:random #t -"pkgs/racket-pkgs/racket-test/tests/racket/subprocess.rktl" drdr:random #t +"pkgs/racket-pkgs/racket-test/tests/racket/stx.rktl" drdr:command-line #f +"pkgs/racket-pkgs/racket-test/tests/racket/submodule.rktl" drdr:command-line #f +"pkgs/racket-pkgs/racket-test/tests/racket/subprocess.rktl" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/racket/sync.rktl" drdr:command-line #f -"pkgs/racket-pkgs/racket-test/tests/racket/syntax-tests.rktl" drdr:random #t "pkgs/racket-pkgs/racket-test/tests/racket/syntax.rktl" drdr:command-line #f +"pkgs/racket-pkgs/racket-test/tests/racket/test.rkt" drdr:timeout 600 "pkgs/racket-pkgs/racket-test/tests/racket/thread.rktl" drdr:command-line #f -"pkgs/racket-pkgs/racket-test/tests/racket/threadlib.rktl" drdr:random #t "pkgs/racket-pkgs/racket-test/tests/racket/thrport.rktl" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/racket/trace.rktl" drdr:command-line #f -"pkgs/racket-pkgs/racket-test/tests/racket/ttt/uinc4.rktl" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/racket/udp.rktl" drdr:command-line #f -"pkgs/racket-pkgs/racket-test/tests/racket/uinc3.rktl" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/racket/uni-norm.rktl" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/racket/unicode.rktl" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/racket/unsafe.rktl" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/racket/vector.rktl" drdr:command-line #f -"pkgs/racket-pkgs/racket-test/tests/racket/will.rktl" drdr:random #t -"pkgs/racket-pkgs/racket-test/tests/racket/zo-marshal.rktl" drdr:command-line #f -"pkgs/racket-pkgs/racket-test/tests/racket/ztest.rktl" drdr:command-line #f +"pkgs/racket-pkgs/racket-test/tests/racket/will.rktl" drdr:command-line #f "pkgs/racket-pkgs/racket-test/tests/run-automated-tests.rkt" responsible (eli) drdr:command-line (mzc "-k" *) drdr:timeout 600 "pkgs/racket-pkgs/racket-test/tests/stress.rkt" responsible (jay) "pkgs/racket-pkgs/racket-test/tests/stxparse" responsible (ryanc) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/README b/pkgs/racket-pkgs/racket-test/tests/racket/README deleted file mode 100644 index b6ac5fe575..0000000000 --- a/pkgs/racket-pkgs/racket-test/tests/racket/README +++ /dev/null @@ -1,33 +0,0 @@ - -To run most of the tests, run: - > (load "PATHTOHERE/all.ss") -where PATHTOHERE is the path to this directory. - -Test failures may cause the test to stop before finishing, but most -test failures will let the test continue, and a summary message at the -end will enummerate the failures that occurred. - -Some files and directories are created (in the current directory) -during the run. The files are named "tmp" where is a number. -The directory is named "deep". If the test suite passes, the directory -should be removed, but some "tmp" files will remain. (The "tmp" -files are automatically replaced if the test suite is run again.) - -Additionally, test `expand' by running: - > (load "PATHTOHERE/expand.ss") - -Test compilation and writing/reading compiled code with: - > (load "PATHTOHERE/compile.ss") - -Run the standard tests with no output except for the results with: - > (load "PATHTOHERE/quiet.ss") -(Also get an error code -- use with scripts.) - -Run 3 copies of the test suite concurrently in separate threads: - > (load "PATHTOHERE/parallel.ss") - - -Please report bugs using Help Desk, or - http://bugs.racket-lang.org/ -or (as a last resort) send mail to - racket@racket-lang.org diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/all.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/all.rktl index 19f86f4884..1b7d22cf39 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/all.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/all.rktl @@ -1,9 +1,49 @@ (load-relative "loadtest.rktl") -(load-relative "mz-tests.rktl") -(load-relative "scheme-tests.rktl") -(load-relative "mzlib-tests.rktl") -(load-relative "syntax-tests.rktl") + +(load-relative "core-tests.rktl") + +(load-in-sandbox "setup.rktl") +(load-in-sandbox "for.rktl") +(load-in-sandbox "list.rktl") +(load-in-sandbox "math.rktl") +(load-in-sandbox "vector.rktl") +(load-in-sandbox "function.rktl") +(load-in-sandbox "dict.rktl") +(load-in-sandbox "fixnum.rktl") +(load-in-sandbox "flonum.rktl") + +(load-in-sandbox "mpair.rktl") +(load-in-sandbox "async-channel.rktl") +(load-in-sandbox "pathlib.rktl") +(load-in-sandbox "filelib.rktl") +(load-in-sandbox "portlib.rktl") +(load-in-sandbox "set.rktl") +(load-in-sandbox "date.rktl") +(load-in-sandbox "cmdline.rktl") +(load-in-sandbox "stream.rktl") +(load-in-sandbox "sequence.rktl") +(load-in-sandbox "generator.rktl") +(load-in-sandbox "pretty.rktl") +(load-in-sandbox "control.rktl") +(load-in-sandbox "serialize.rktl") +(load-in-sandbox "package.rktl") +(load-in-sandbox "sandbox.rktl") +(load-in-sandbox "shared.rktl") +(load-in-sandbox "resource.rktl") +(load-in-sandbox "syntaxlibs.rktl") +(load-in-sandbox "subprocess.rktl") +(load-in-sandbox "char-set.rktl") +(load-in-sandbox "bytes.rktl") +(load-in-sandbox "trace.rktl") +(load-in-sandbox "trait.rktl") + +(load-in-sandbox "moddep.rktl") +(load-in-sandbox "boundmap-test.rktl") +(load-in-sandbox "id-table-test.rktl") +(load-in-sandbox "cm.rktl") +(load-in-sandbox "module-reader.rktl") + (load-in-sandbox "version.rktl") (load-in-sandbox "foreign-test.rktl") (load-in-sandbox "cstruct.rktl") diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/chez-module.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/chez-module.rktl deleted file mode 100644 index f702b50a17..0000000000 --- a/pkgs/racket-pkgs/racket-test/tests/racket/chez-module.rktl +++ /dev/null @@ -1,271 +0,0 @@ - -;; Run this file with -r, and inspect the -;; printouts. - -(module helpers mzscheme - (require scheme/package) - - (provide identifier-syntax with-implicit - (rename define-package module) - (rename open-package import)) - - (define-syntax (identifier-syntax stx) - (syntax-case stx () - [(_ id) (if (identifier? #'id) - #'(make-rename-transformer (quote-syntax id)) - ;; Cheating in this case... examples only - ;; use this in a non-applied position - #'(lambda (stx) (quote-syntax id)))])) - - (define-syntax with-implicit - (syntax-rules () - [(_ (orig id ...) body) - (with-syntax ([id (datum->syntax-object #'orig (syntax-e #'id))] - ...) - body)]))) - - -(require 'helpers) -(require (for-syntax 'helpers)) - -;; Make evaluation print the result, for testing -(let ([eh (current-eval)]) - (current-eval (lambda (x) - (let ([v (eh x)]) - (unless (void? v) - (printf "~s~n" v)) - v)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; From "Extending the Scope of Syntactic Abstraction" -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(let ((x 1)) - (module M (x setter) - (define-syntax x (identifier-syntax z)) - (define setter (lambda (x) (set! z x))) - (define z 5)) - (let ((y x) (z 0)) - (import M) - (setter 3) - (list x y z))) -"(3 1 0) is correct" - - -(define-syntax from - (syntax-rules () - ((_ M id) (let () (import M) id)))) -(let ((x 10)) - (module m1 (x) (define x 1)) - (module m2 (x) (define x 2)) - (list (from m1 x) (from m2 x))) -"(1 2) is correct" - -(define-syntax module* - (syntax-rules () - [(_ (id ...) form ...) - (begin - (module tmp (id ...) form ...) - (import tmp))] - [(_ name (id ...) form ...) - (module name (id ...) form ...)])) -(let ([w 88]) - (module* (f) - (define (f) w) - (define w 17)) - (list (f) w)) -"(17 88) is correct" - -(define-syntax define-alias - (syntax-rules () - [(_ x y) - (define-syntax x - (identifier-syntax y))])) - -(define-syntax import* - (syntax-rules () - [(_ M) (begin)] - [(_ M (new old)) - (module* (new) - (define-alias new tmp) - (module* (tmp) - (import M) - (define-alias tmp old)))] - [(_ M id) (module* (id) (import M))] - [(_ M spec0 spec1 ...) - (begin (import* M spec0) - (import* M spec1 ...))])) -(module m (x y z) - (define x 'x) - (define y 'y) - (define z 'z)) -(import* m x (y z) (z y)) -(list x y z) -"(x z y) is correct" - -(module A (x y) - (define x 1) - (define y 2)) -(module B (y z) - (define y 3) - (define z 4)) -(module C (a b c d) - (import* A (a x) (b y)) - (import* B (c y) (d z))) -(module D (a c) - (import C)) -(module E (b d) - (import C)) -(let ([a 'a] - [b 'b] - [c 'c] - [d 'd]) - (import D) - (list a b c d)) -"(1 b 3 d) is correct" -(let ([a 'a] - [b 'b] - [c 'c] - [d 'd]) - (import E) - (list a b c d)) -"(a 2 c 4) is correct" - -(module* (A B) - (module A (x) - (define x (lambda () y))) - (module B (y) - (define y (lambda () x))) - (import A) - (import B)) -(import A) -(import B) -(and (eq? x (y)) (eq? (y) x)) -"#t is correct" - - -(define-syntax rec-modules - (syntax-rules () - ((_ (module N (id ...) form ...) ...) - (module* (N ...) - (module N (id ...) form ...) ... - (import N) ...)))) -(rec-modules - (module O (odd) - (define (odd x) - (if (zero? x) #f (even (sub1 x))))) - (module E (even) - (define (even x) - (if (zero? x) #t (odd (sub1 x)))))) -(import O) -(list (odd 17) (odd 32)) -"(#t #f) is correct" - - -(define-syntax define-interface - (syntax-rules () - [(_ name (export ...)) - (define-syntax name - (lambda (x) - (syntax-case x () - [(_ n defs) - (with-implicit (n export ...) - #'(module n (export ...) . defs))])))])) -(define-syntax define-module - (syntax-rules () - [(_ name interface defn ...) - (interface name (defn ...))])) -(define-interface simple (a b)) -(define-module M simple - (define-syntax a (identifier-syntax 1)) - (define b (lambda () c)) - (define c 2)) -(let () - (import M) - (list a (b))) -"(1 2) is right" - -(define-syntax define-interface - (syntax-rules (compound-interface) - [(_ name (compound-interface i0 i1 ...)) - (d-i-help name (i0 i1 ...) ())] - [(_ name (export ...)) - (define-syntax name - (lambda (x) - (syntax-case x (expand-exports) - [(_ n defs) - (with-implicit (n export ...) - #'(module n (export ...) . defs))] - [(_ (expand-exports i-name mac)) - (with-implicit (i-name export ...) - #'(mac i-name export ...))])))])) -(define-syntax d-i-help - (syntax-rules () - [(_ name () (export ...)) - (define-interface name (export ...))] - [(_ name (i0 i1 ...) (e ...)) - (begin - (define-syntax tmp - (syntax-rules () - [(_ name expt (... ...)) - (d-i-help name (i1 ...) - (e ... expt (... ...)))])) - (i0 (expand-exports name tmp)))])) -(define-syntax define-module - (syntax-rules (compound-interface) - [(_ name (compound-interface i ...) defn ...) - (begin - (define-interface tmp(compound-interface i ...)) - (define-module name tmp defn ...))] - [(_ name interface defn ...) (interface name (defn ...))])) -(define-interface one (a b)) -(define-interface two (c d)) -(define-interface both - (compound-interface one two)) -(define-module M (compound-interface one two) - (define a 1) - (define b 2) - (define c 3) - (define d 4)) -(let () - (import M) - (list a b c d)) -"(1 2 3 4) is correct" - -(define-syntax declare - (syntax-rules () - [(_ id) (define id (void))])) -(define-syntax satisfy - (syntax-rules () - [(_ id val) (set! id val)])) - -(define-syntax abstract-module - (syntax-rules () - ((_ name (ex ...) (mac ...) defn ...) - (module name (ex ... mac ...) - (declare ex) - ... defn ...)))) -(define-syntax implement - (syntax-rules () - ((_ name form ...) - (module* () - (import name) - form ...)))) -(abstract-module E (even?) ()) -(abstract-module - O (odd?) (pred) - (define-syntax pred - (syntax-rules () ((_ exp) (- exp 1))))) -(implement E - (import O) - (satisfy even? - (lambda (x) (or (zero? x) (odd? (pred x)))))) -(implement O - (import E) - (satisfy - odd? - (lambda (x) (not (even? x))))) -(import O) -(list (odd? 10) (odd? 13)) -"(#f #t) is correct" - diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/cmdline.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/cmdline.rktl index 677bbef4b4..c57e890b3f 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/cmdline.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/cmdline.rktl @@ -3,7 +3,7 @@ (Section 'command-line) -(require mzlib/cmdline) +(require racket/cmdline) (define (r-append opt . rest) (append opt (list (list->vector rest)))) @@ -170,34 +170,39 @@ (err/rt-test (parse-command-line "test" #() null (lambda (x y) null) null) exn:fail?) (test (void) 'cmdline - (command-line "something" #("-ab") - (once-each - [("-a") "ok" 5] - [("-b" "--more") "Help" 7]))) + (command-line + #:program "something" + #:argv #("-ab") + #:once-each + [("-a") "ok" 5] + [("-b" "--more") "Help" 7])) ;; test that keywords are compared for the literal symbol (test "foo" 'cmdline (let ([once-each 3] [args "args"]) - (command-line "something" #("-ab" "foo") - (once-each - [("-a") "ok" 5] - [("-b" "--more") "Help" 7]) - (args (x) x)))) + (command-line + #:program "something" + #:argv #("-ab" "foo") + #:once-each + [("-a") "ok" 5] + [("-b" "--more") "Help" 7] + #:args + (x) + x))) -(syntax-test #'(command-line)) +(syntax-test #'(command-line . x)) (syntax-test #'(command-line "hello")) -(err/rt-test (command-line 'hello #("ok"))) -(syntax-test #'(command-line "hello" #("ok") (bad))) -(syntax-test #'(command-line "hello" #("ok") (once-any ()))) -(syntax-test #'(command-line "hello" #("ok") (once-any ("-ok")))) -(syntax-test #'(command-line "hello" #("ok") (once-any ("-ok" "the ok flag")))) -(syntax-test #'(command-line "hello" #("ok") (once-any ("-ok" a "the ok flag")))) -(syntax-test #'(command-line "hello" #("ok") (once-any ("-ok" (a) "the ok flag")))) -(syntax-test #'(command-line "hello" #("ok") (once-any ("-ok" a "the ok flag") ()))) -(syntax-test #'(command-line "hello" #("ok") (args 'done) (once-any ("-ok" a "the ok flag" 7)))) -(syntax-test #'(command-line "hello" #("ok") (args (ok) 'done) (once-any ("-ok" a "the ok flag" 7)))) -(syntax-test #'(command-line "hello" #("ok") (=> 'done) (once-any ("-ok" a "the ok flag" 7)))) -(syntax-test #'(command-line "hello" #("ok") (=> 1 2 3 4) (once-any ("-ok" a "the ok flag" 7)))) +(err/rt-test (command-line #:program 'hello #:argv #("ok"))) +(syntax-test #'(command-line #:program "hello" #:argv #("ok") #:bad)) +(syntax-test #'(command-line #:program "hello" #:argv #("ok") (bad))) +(syntax-test #'(command-line #:program "hello" #:argv #("ok") #:once-any ())) +(syntax-test #'(command-line #:program "hello" #:argv #("ok") #:once-any [("-ok")])) +(syntax-test #'(command-line #:program "hello" #:argv #("ok") #:once-any ["-ok" "the ok flag"])) +(syntax-test #'(command-line #:program "hello" #:argv #("ok") #:once-any ["-ok" a "the ok flag"])) +(syntax-test #'(command-line #:program "hello" #:argv #("ok") #:once-any [("-ok") #() "the ok flag"])) +(syntax-test #'(command-line #:program "hello" #:argv #("ok") #:once-any [("-ok") a "the ok flag"] ())) +(syntax-test #'(command-line #:program "hello" #:argv #("ok") #:args 'done #:once-any [("-ok") a 7])) +(syntax-test #'(command-line #:program "hello" #:argv #("ok") #:args (ok) 'done #:once-any [("-ok") a "the ok flag" 7])) (err/rt-test (parse-command-line "test" #("x") null (lambda () 'too-few) '("arg"))) (err/rt-test (parse-command-line "test" #("x") null (lambda (x) 'still-too-few) '("arg"))) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/compile.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/compile.rktl deleted file mode 100644 index dbb1065cba..0000000000 --- a/pkgs/racket-pkgs/racket-test/tests/racket/compile.rktl +++ /dev/null @@ -1,117 +0,0 @@ - -; Tests compilation and writing/reading compiled code -; by setting the eval handler and running all tests - -(load-relative "loadtest.rktl") - -(namespace-variable-value - 'compile-load - #f - (lambda () - (namespace-set-variable-value! 'compile-load "mzq.rktl"))) - -(define file - (if #f - (open-output-file "x" 'replace) - (make-output-port 'nowhere - always-evt - (lambda (s start end non-block? breakable?) (- end start)) - void - (lambda (special non-block? breakable?) #t) - (lambda (s start end) (wrap-evt - always-evt - (lambda (x) - (- end start)))) - (lambda (special) (wrap-evt always-evt (lambda (x) #t)))))) - -(define try-one - (lambda (e) - (let ([c (compile-syntax e)] - [ec (compile-syntax (expand e))] - [p (open-output-bytes)] - [ep (open-output-bytes)]) - (write c p) - (write ec ep) - (let ([s (get-output-bytes p)] - [es (get-output-bytes ep)]) - (unless (equal? s es) - (error 'try "bad expand ~e\n" e)) - ; (write (string->list s)) (newline) - (let ([e (parameterize ([read-accept-compiled #t]) - (read (open-input-bytes s)))]) - (eval e)))))) - -(letrec ([orig (current-eval)] - [orig-load (current-load)] - [my-load - (lambda (filename expected-module) - (let ([f (open-input-file filename)]) - (dynamic-wind - void - (lambda () - (let loop ([results (list (void))]) - (let ([v (parameterize ([read-accept-compiled #t]) - (read f))]) - (if (eof-object? v) - (apply values results) - (loop (call-with-values - (lambda () (my-eval v orig)) - list)))))) - (lambda () - (close-input-port f)))))] - [my-eval - (case-lambda - [(x next-eval) - (if (or (compiled-expression? x) - (and (syntax? x) (compiled-expression? (syntax-e x))) - (current-module-declare-name)) - (next-eval x) - (begin - ;; (fprintf file ": ~a\n" +) - ;; (write x file) (newline file) - (let ([p (open-output-bytes)] - [ep (open-output-bytes)] - [c ((if (syntax? x) compile-syntax compile) x)] - [ec (compile-syntax ((if (syntax? x) expand-syntax expand) x))]) - (write c p) - (write ec ep) - (let ([s (get-output-bytes p)] - [es (get-output-bytes ep)]) - (unless (equal? s es) - '(fprintf (current-error-port) "bad expand (~a,~a) ~e\n" - (bytes-length s) (bytes-length es) x)) - ; (display s file) (newline file) - (let ([e (parameterize ([read-accept-compiled #t]) - (read (open-input-bytes s)))]) - ; (write e file) (newline file) - (parameterize ([current-eval next-eval]) - (orig e)))))))] - [(x) (my-eval x orig)])]) - (dynamic-wind - (lambda () - (set! teval (lambda (x) (my-eval x my-eval))) - ; (read-accept-compiled #t) - (current-eval my-eval) - (current-load my-load)) - (lambda () - (load-relative compile-load)) - (lambda () - (set! teval eval) - (close-output-port file) - ; (read-accept-compiled #f) - (current-eval orig) - (current-load orig-load)))) - -; Check compiled number I/O: -(let ([l (let loop ([n -512][l null]) - (if (= n 513) - l - (loop (add1 n) (cons n l))))] - [p (open-output-bytes)]) - (write (compile `(quote ,l)) p) - (let ([s (open-input-bytes (get-output-bytes p))]) - (let ([l2 (parameterize ([read-accept-compiled #t]) - (eval (read s)))]) - (test #t equal? l l2)))) - -(report-errs) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/control.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/control.rktl index a0618595f4..ef5ca4d9c5 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/control.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/control.rktl @@ -8,119 +8,118 @@ (Section 'control) -(require mzlib/control - (only-in mzlib/etc rec)) +(require racket/control) -;----------------------------------------------------------------------- +;;----------------------------------------------------------------------- (define-syntax ctest (syntax-rules () [(_ expr expect) (test expect 'expr expr)])) -;----------------------------------------------------------------------- -; Shift tests +;;----------------------------------------------------------------------- +;; Shift tests (ctest (+ 10 (reset (+ 2 (shift k (+ 100 (k (k 3))))))) - 117) + 117) (ctest (* 10 (reset (* 2 (shift g (reset (* 5 (shift f (+ (f 1) 1)))))))) - 60) + 60) (ctest (let ((f (lambda (x) (shift k (k (k x)))))) (+ 1 (reset (+ 10 (f 100))))) - 121) + 121) (ctest (reset - (let ((x (shift f (cons 'a (f '()))))) - (shift g x))) - '(a)) + (let ((x (shift f (cons 'a (f '()))))) + (shift g x))) + '(a)) (define (shift* p) (shift f (p f))) (ctest (reset (let ((x 'abcde)) (eq? x ((shift* shift*) x)))) - #t) + #t) (define traverse (lambda (xs) (letrec ((visit - (lambda (xs) - (if (null? xs) - '() - (visit (shift k - (cons (car xs) - (k (cdr xs))))))))) + (lambda (xs) + (if (null? xs) + '() + (visit (shift k + (cons (car xs) + (k (cdr xs))))))))) (reset (visit xs))))) (ctest (traverse '(1 2 3 4 5)) - '(1 2 3 4 5)) + '(1 2 3 4 5)) -;----------------------------------------------------------------------- -; Control tests -; Example from Sitaram, Felleisen +;;----------------------------------------------------------------------- +;; Control tests +;; Example from Sitaram, Felleisen (define (abort v) (control k v)) (ctest (let ((g (prompt (* 2 (control k k))))) - (* 3 (prompt (* 5 (abort (g 7)))))) - 42) + (* 3 (prompt (* 5 (abort (g 7)))))) + 42) -; Olivier Danvy's puzzle +;; Olivier Danvy's puzzle (define traverse (lambda (xs) (letrec ((visit - (lambda (xs) - (if (null? xs) - '() - (visit (control k - (cons (car xs) - (k (cdr xs))))))))) + (lambda (xs) + (if (null? xs) + '() + (visit (control k + (cons (car xs) + (k (cdr xs))))))))) (prompt (visit xs))))) (ctest (traverse '(1 2 3 4 5)) - '(5 4 3 2 1)) + '(5 4 3 2 1)) (ctest (+ 10 (prompt (+ 2 (control k (+ 100 (k (k 3))))))) - 117) + 117) (ctest (prompt (let ((x (control f (cons 'a (f '()))))) (control g x))) - '()) + '()) (ctest (prompt ((lambda (x) (control l 2)) - (control l (+ 1 (l 0))))) - 2) + (control l (+ 1 (l 0))))) + 2) (ctest (prompt (control f (cons 'a (f '())))) - '(a)) + '(a)) (ctest (prompt (let ((x (control f (cons 'a (f '()))))) - (control g (g x)))) - '(a)) + (control g (g x)))) + '(a)) (define (control* f) (control k (f k))) (ctest (prompt (let ((x 'abcde)) (eq? x ((control* control*) x)))) - #t) + #t) -;------------------------------------------------------------------------ -; shift0/control0 tests +;;------------------------------------------------------------------------ +;; shift0/control0 tests (ctest (+ 10 (prompt0 (+ 2 (control k (+ 100 (k (k 3))))))) - 117) + 117) (ctest (prompt0 (prompt0 - (let ((x (control f (cons 'a (f '()))))) - (control g x)))) - '()) + (let ((x (control f (cons 'a (f '()))))) + (control g x)))) + '()) (ctest (+ 10 (prompt0 (+ 2 (shift0 k (+ 100 (k (k 3))))))) - 117) + 117) (ctest (prompt0 (cons 'a (prompt0 (shift0 f (shift0 g '()))))) - '()) + '()) (ctest (prompt (cons 'a (prompt (shift0 f (shift0 g '()))))) - '(a)) + '(a)) ;; ---------------------------------------- @@ -154,11 +153,11 @@ [else #f])))))))) (ctest (same-fringe? '(1 . (2 . (3 . 4))) - '(1 . ((2 . 3) . 4))) - #t) + '(1 . ((2 . 3) . 4))) + #t) (ctest (same-fringe? '(1 . (2 . (3 . 4))) - '(1 . ((2 . 5) . 4))) - #f) + '(1 . ((2 . 5) . 4))) + #f) (define all-prefixes (lambda (l) @@ -168,12 +167,12 @@ (cons (car l) (fcontrol (cdr l)))))]) (% (loop l) - (rec h - (lambda (r k) - (if (eq? r 'done) - '() - (cons (k '()) - (% (k (loop r)) h))))))))) + (letrec ([h (lambda (r k) + (if (eq? r 'done) + '() + (cons (k '()) + (% (k (loop r)) h))))]) + h))))) (ctest (all-prefixes '(1 2 3 4)) '((1) (1 2) (1 2 3) (1 2 3 4))) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/mz-tests.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/core-tests.rktl similarity index 88% rename from pkgs/racket-pkgs/racket-test/tests/racket/mz-tests.rktl rename to pkgs/racket-pkgs/racket-test/tests/racket/core-tests.rktl index d1f8b2213a..0c90174268 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/mz-tests.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/core-tests.rktl @@ -17,8 +17,6 @@ (load-relative "unsafe.rktl") (load-relative "object.rktl") (load-relative "struct.rktl") -(load-relative "unit.rktl") -(load-relative "unitsig.rktl") (load-relative "thread.rktl") (load-relative "logger.rktl") (load-relative "sync.rktl") @@ -40,8 +38,3 @@ (unless building-flat-tests? (load-relative "name.rktl")) (load-relative "srcloc.rktl") - -;; Ok, so this isn't really all of them. Here are more: -; thrport.rktl - -; See also README diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/fact.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/fact.rktl deleted file mode 100644 index d991f2fc16..0000000000 --- a/pkgs/racket-pkgs/racket-test/tests/racket/fact.rktl +++ /dev/null @@ -1,6 +0,0 @@ -(define fact - (lambda (n) - (let loop ([n n][res 1]) - (if (zero? n) - res - (loop (sub1 n) (* n res)))))) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/file.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/file.rktl index 73a0186fd5..35a4946a40 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/file.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/file.rktl @@ -1,4 +1,4 @@ -(require mzlib/os) + (load-relative "loadtest.rktl") (Section 'file) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/filelib.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/filelib.rktl index a98cd1d17b..13c337682f 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/filelib.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/filelib.rktl @@ -3,9 +3,9 @@ (Section 'filelib) -(require scheme/file - mzlib/process - mzlib/list) +(require racket/file + racket/system + racket/list) (define tmp-name "tmp0-filelib") (when (file-exists? tmp-name) (delete-file tmp-name)) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/function.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/function.rktl index a77844a458..ba2be7ccd0 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/function.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/function.rktl @@ -2,7 +2,7 @@ (Section 'function) -(require racket/function mzlib/etc) +(require racket/function) ;; stuff from racket/base @@ -106,22 +106,6 @@ (arity-test compose1 0 -1) (arity-test compose 0 -1)) -;; ---------- rec (from mzlib/etc) ---------- -(let () - (test 3 (rec f (λ (x) 3)) 3) - (test 3 (rec f (λ (x) x)) 3) - (test 2 (rec f (λ (x) (if (= x 3) (f 2) x))) 3) - (test 3 (rec (f x) 3) 3) - (test 3 (rec (f x) x) 3) - (test 2 (rec (f x) (if (= x 3) (f 2) x)) 3) - (test 2 (rec (f x . y) (car y)) 1 2 3) - (test 2 'no-duplications - (let ([x 1]) (rec ignored (begin (set! x (+ x 1)) void)) x)) - (test 'f object-name (rec (f x) x)) - (test 'f object-name (rec (f x . y) x)) - (test 'f object-name (rec f (lambda (x) x))) - (test (list 2) (rec (f . x) (if (= (car x) 3) (f 2) x)) 3)) - ;; ---------- identity ---------- (let () (test 'foo identity 'foo) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/head.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/head.rktl deleted file mode 100644 index d14790465e..0000000000 --- a/pkgs/racket-pkgs/racket-test/tests/racket/head.rktl +++ /dev/null @@ -1,44 +0,0 @@ - -(load-relative "loadtest.rktl") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; net/head tests -;; - -(require net/head) - -(for-each - (lambda (addr) - (test '("o.gu@racket-lang.com") extract-addresses (car addr) 'address) - (test '("o.gu@racket-lang.com" "o.gu@racket-lang.com") extract-addresses - (format "~a, ~a" (car addr) (car addr)) - 'address) - (test (list (cdr addr)) extract-addresses (car addr) 'name) - (for-each - (lambda (addr2) - (let ([two (format " ~a, \n\t~a" (car addr) (car addr2))]) - (test '("o.gu@racket-lang.com" "s.gu@racket-lang.org") extract-addresses two 'address) - (test (list (cdr addr) (cdr addr2)) extract-addresses two 'name))) - '(("s.gu@racket-lang.org" . "s.gu@racket-lang.org") - ("" . "s.gu@racket-lang.org") - ("s.gu@racket-lang.org (Gu, Sophia)" . "Gu, Sophia") - ("s.gu@racket-lang.org (Sophia Gu)" . "Sophia Gu") - ("s.gu@racket-lang.org (Sophia \"Sophie\" Gu)" . "Sophia \"Sophie\" Gu") - ("Sophia Gu " . "Sophia Gu") - ("\"Gu, Sophia\" " . "\"Gu, Sophia\"") - ("\"Gu, Sophia (Sophie)\" " . "\"Gu, Sophia (Sophie)\"")))) - '(("o.gu@racket-lang.com" . "o.gu@racket-lang.com") - ("" . "o.gu@racket-lang.com") - ("o.gu@racket-lang.com (Gu, Oliver)" . "Gu, Oliver") - ("o.gu@racket-lang.com (Oliver Gu)" . "Oliver Gu") - ("o.gu@racket-lang.com (Oliver \"Ollie\" Gu)" . "Oliver \"Ollie\" Gu") - ("o.gu@racket-lang.com (Oliver \"Ollie Gu)" . "Oliver \"Ollie Gu") - ("Oliver Gu " . "Oliver Gu") - ("\"Gu, Oliver\" " . "\"Gu, Oliver\"") - ("\"Gu, Oliver (Ollie)\" " . "\"Gu, Oliver (Ollie)\"") - ("\"Gu, Oliver (Ollie\" " . "\"Gu, Oliver (Ollie\"") - ("\"Gu, Oliver (Ollie, himself)\" " . "\"Gu, Oliver (Ollie, himself)\""))) - - -(report-errs) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/imap.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/imap.rktl deleted file mode 100644 index 8187f07b98..0000000000 --- a/pkgs/racket-pkgs/racket-test/tests/racket/imap.rktl +++ /dev/null @@ -1,172 +0,0 @@ - -(define imap-server "imap.cs.utah.edu") -(define imap-port-no 993) -(define username "mflatt") -(define pw (with-input-from-file (build-path (current-load-relative-directory) "pw") - read)) -(define mailbox-name "INBOX.tmp") ;; !!! ALL CONTENT WILL BE DELETED !!! - -(load-relative "loadtest.rktl") - -(Section 'imap) - -(require openssl/mzssl - net/imap - mzlib/etc) - -(define (test-connect) - (if (zero? (random 2)) - (parameterize ([imap-port-number 993]) - (imap-connect #:tls? #t imap-server username pw mailbox-name)) - (let ([c (ssl-make-client-context)]) - (let-values ([(in out) (ssl-connect imap-server imap-port-no c)]) - (imap-connect* in out username pw mailbox-name))))) - -(define-values (imap cnt recent) (test-connect)) - -(printf "Msgs: ~a; Validity: ~a\n" cnt (imap-uidvalidity imap)) - -(test cnt imap-messages imap) -(test recent imap-recent imap) -(test #t number? (imap-uidvalidity imap)) -(test #f imap-pending-expunges? imap) -(test #f imap-pending-updates? imap) -(test #f imap-new? imap) - -(imap-disconnect imap) -(error "comment out these two lines to finish...") - -(define (delete-all) - (let ([cnt (imap-messages imap)]) - (unless (zero? cnt) - (let ([all (build-list cnt add1)]) - (test (void) imap-store imap '+ all '|\Deleted|) - (test (void) imap-expunge imap) - (test #t imap-pending-expunges? imap) - (test all imap-get-expunges imap) - (test null imap-get-expunges imap) - (test #f imap-pending-expunges? imap))))) - -(delete-all) -(test #f imap-new? imap) -(test 0 imap-messages imap) -(test '(0 0) 'noop (let-values ([(a b) (imap-noop imap)]) - (list a b))) -(test (void) imap-poll imap) -(test 0 imap-messages imap) -(test 0 imap-recent imap) - -(test #f imap-new? imap) - -(define (add-one content total) - (test (void) imap-append imap mailbox-name content) - (imap-noop imap) - (test total imap-messages imap) - (test #t imap-new? imap) - (let ([uids (imap-get-messages imap (build-list total add1) '(uid))]) - (test #t list? uids) - (test total length uids) - (let ([l (list-ref uids (sub1 total))]) - (test #t list? l) - (test 1 length l) - (test #t number? (car l)) - (car l)))) - - -(define sample-head #"Subject: Hello\r\n\r\n") -(define sample-body #"Hi there.\r\n") - -(let ([uid (add-one (bytes-append sample-head sample-body) 1)]) - (test (list (list uid - sample-head - sample-body - '(|\Seen|))) - imap-get-messages imap '(1) '(uid header body flags))) -(test (void) imap-store imap '+ '(1) (list (symbol->imap-flag 'answered))) -(test (list '((|\Answered| |\Seen|))) imap-get-messages imap '(1) '(flags)) -(test (void) imap-store imap '- '(1) (list (symbol->imap-flag 'answered))) -(test (list '((|\Seen|))) imap-get-messages imap '(1) '(flags)) -(test (void) imap-store imap '+ '(1) (list (symbol->imap-flag 'deleted))) -(test (list '((|\Seen| |\Deleted|))) imap-get-messages imap '(1) '(flags)) -(test (void) imap-store imap '! '(1) (list (symbol->imap-flag 'answered))) -(test (list '((|\Answered|))) imap-get-messages imap '(1) '(flags)) - -(test #f imap-pending-updates? imap) -(test null imap-get-updates imap) - -;; Test multiple-client access: -(let () - (define-values (imap2 cnt2 recent2) (test-connect)) - (test '(1 0) list cnt2 recent2) - - (let ([uid (add-one (bytes-append sample-head sample-body) 2)]) - (let loop ([n 5]) - (when (zero? n) - (imap-noop imap2)) - (imap-poll imap2) - (unless (imap-new? imap2) - (sleep 0.2) - (loop (sub1 n)))) - (test #t imap-new? imap2) - (test 2 imap-messages imap2) - (let ([uids (imap-get-messages imap2 '(2) '(uid))]) - (test uid caar uids))) - - ;; Delete message on imap2, check notifcation to imap - (test (void) imap-store imap2 '+ '(2) (list (symbol->imap-flag 'deleted))) - (test (void) imap-expunge imap2) - (test '(2) imap-get-expunges imap2) - (imap-noop imap) - (err/rt-test (imap-store imap '+ '(2) (list (symbol->imap-flag 'answered)))) - (test #t imap-pending-expunges? imap) - (test '(2) imap-get-expunges imap) - - ;; Adjust flags on imap2, check notifcation to imap - (test #f imap-pending-updates? imap) - (test (void) imap-store imap2 '+ '(1) (list (symbol->imap-flag 'deleted))) - (imap-noop imap) - (test #t imap-pending-updates? imap) - (test #t list? (imap-get-updates imap)) - (test #f imap-pending-updates? imap) - - ;; Check that multiple updates are collapsed: - (test (void) imap-store imap2 '- '(1) (list (symbol->imap-flag 'deleted))) - (imap-noop imap) - (test #t imap-pending-updates? imap) - (test (void) imap-store imap2 '+ '(1) (list (symbol->imap-flag 'deleted))) - (test (void) imap-store imap2 '- '(1) (list (symbol->imap-flag 'deleted))) - (imap-noop imap) - (test #t imap-pending-updates? imap) - (test 1 length (imap-get-updates imap)) - - (test (void) imap-reset-new! imap2) - (add-one (bytes-append sample-head sample-body) 2) - (add-one (bytes-append sample-head sample-body) 3) - (add-one (bytes-append sample-head sample-body) 4) - (add-one (bytes-append sample-head sample-body) 5) - (imap-noop imap2) - (test #t imap-new? imap2) - (test 5 imap-messages imap) - (test 5 imap-messages imap2) - - (test #t list? (imap-get-messages imap '(1 2 3 4 5) '(uid))) - (test #t list? (imap-get-messages imap2 '(1 2 3 4 5) '(uid))) - - ;; Test deleteing multiple messages, and shifts in flag updates - (test (void) imap-store imap2 '+ '(2 4) (list (symbol->imap-flag 'deleted))) - (test (void) imap-store imap2 '+ '(3 5) (list (symbol->imap-flag 'answered))) - (test (void) imap-expunge imap2) - (imap-noop imap) - (imap-noop imap2) - (test #t imap-pending-expunges? imap) - (test #t imap-pending-expunges? imap2) - (test '(2 4) imap-get-expunges imap) - (test '(2 4) imap-get-expunges imap2) - (test #t imap-pending-updates? imap) - (test '(2 3) map car (imap-get-updates imap)) - - (imap-disconnect imap2)) - -(imap-disconnect imap) - -(report-errs) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/ktest.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/ktest.rktl deleted file mode 100644 index 86d2d0ddba..0000000000 --- a/pkgs/racket-pkgs/racket-test/tests/racket/ktest.rktl +++ /dev/null @@ -1,11 +0,0 @@ -(define k - (call-with-current-continuation - (lambda (exit) - (let loop ((n 60000)) - (if (zero? n) - (let ((v (call-with-current-continuation (lambda (k) k)))) - (if (number? v) - v - (exit v))) - (- (loop (- n 1)) 1)))))) - diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/list.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/list.rktl index 6faf8dd3f2..0ca4b02d9d 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/list.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/list.rktl @@ -3,7 +3,7 @@ (Section 'list) -(require scheme/list) +(require racket/list) (test (list 1 2 3 4) foldl cons '() (list 4 3 2 1)) (test (list 1 2 3 4) foldr cons '() (list 1 2 3 4)) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/load-handler.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/load-handler.rkt index 4b22d87f8a..471c4da683 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/load-handler.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/racket/load-handler.rkt @@ -1,6 +1,6 @@ #lang racket/base (require racket/file - mzlib/compile) + compiler/compile-file) (provide try-load-handler-now) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/ltest.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/ltest.rktl deleted file mode 100644 index 33cd8f5531..0000000000 --- a/pkgs/racket-pkgs/racket-test/tests/racket/ltest.rktl +++ /dev/null @@ -1,88 +0,0 @@ -(printf "nested loop\n") -(time - (let loop ([n 10000]) - (unless (zero? n) - (let loop2 ([m 10]) - (if (zero? m) - (loop (sub1 n)) - (loop2 (sub1 m))))))) - -(printf "single loop\n") -(time - (let loop ([n 100000]) - (unless (zero? n) - (loop (sub1 n))))) - -(printf "Y loop\n") -(time - ((lambda (f n) (f f n)) - (lambda (loop n) - (unless (zero? n) - (loop loop (sub1 n)))) - 100000)) - - -(printf "let closure recur\n") -(time - (let ([f (lambda (x) (sub1 x))]) - (let loop ([n 100000]) - (unless (zero? n) - (loop (f n)))))) - -(printf "direct closure recur\n") -(time - (let loop ([n 100000]) - (unless (zero? n) - (loop ((lambda (x) (sub1 x)) n))))) - -(printf "direct closure recur if\n") -(time - (let loop ([n 100000]) - (if (zero? n) - (void) - (loop ((lambda (x) (sub1 x)) n))))) - -(printf "let closure top-level\n") -(define loop - (let ([f (lambda (x) (sub1 x))]) - (lambda (n) - (unless (zero? n) - (loop (f n)))))) -(time (loop 100000)) - -(printf "direct closure top-level\n") -(define loop - (lambda (n) - (unless (zero? n) - (loop ((lambda (x) (sub1 x)) n))))) -(time (loop 100000)) - - -; > (load "ltest.rkt") -; cpu time: 1820 real time: 1826 -; cpu time: 1420 real time: 1422 -; cpu time: 1960 real time: 1957 -; cpu time: 2630 real time: 2626 -; > (load "ltest.rkt") -; cpu time: 1790 real time: 1803 -; cpu time: 1430 real time: 1468 -; cpu time: 2150 real time: 2159 -; cpu time: 2820 real time: 2824 - -; > (load "ltest.rkt") -; nested loop -; cpu time: 1750 real time: 1817 -; single loop -; cpu time: 1430 real time: 1425 -; Y loop -; cpu time: 1500 real time: 1500 -; let closure recur -; cpu time: 1830 real time: 1835 -; direct closure recur -; cpu time: 1790 real time: 1791 -; direct closure recur if -; cpu time: 1800 real time: 1793 -; let closure top-level -; cpu time: 1810 real time: 1804 -; direct closure top-level -; cpu time: 1760 real time: 1758 diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/mzlib-tests.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/mzlib-tests.rktl deleted file mode 100644 index 78f46d3118..0000000000 --- a/pkgs/racket-pkgs/racket-test/tests/racket/mzlib-tests.rktl +++ /dev/null @@ -1,37 +0,0 @@ - -; Test MzLib -; See also pptest.rkt and ztest.rkt - -(load-relative "loadtest.rktl") -(load-in-sandbox "mpair.rktl") -(load-in-sandbox "etc.rktl") -(load-in-sandbox "structlib.rktl") -(load-in-sandbox "async-channel.rktl") -(load-in-sandbox "restart.rktl") -(load-in-sandbox "string-mzlib.rktl") -(load-in-sandbox "pathlib.rktl") -(load-in-sandbox "filelib.rktl") -(load-in-sandbox "portlib.rktl") -(load-in-sandbox "threadlib.rktl") -(load-in-sandbox "set.rktl") -(load-in-sandbox "date.rktl") -(load-in-sandbox "compat.rktl") -(load-in-sandbox "cmdline.rktl") -(load-in-sandbox "stream.rktl") -(load-in-sandbox "sequence.rktl") -(load-in-sandbox "generator.rktl") -(load-in-sandbox "pconvert.rktl") -(load-in-sandbox "pretty.rktl") -(load-in-sandbox "control.rktl") -(load-in-sandbox "serialize.rktl") -(load-in-sandbox "package.rktl") -(load-in-sandbox "contract-mzlib-test.rktl") -(load-in-sandbox "sandbox.rktl") -(load-in-sandbox "shared.rktl") -(load-in-sandbox "kw.rktl") -(load-in-sandbox "macrolib.rktl") -(load-in-sandbox "resource.rktl") -(load-in-sandbox "syntaxlibs.rktl") -(load-in-sandbox "subprocess.rktl") - -(report-errs) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/mzlonglong.c b/pkgs/racket-pkgs/racket-test/tests/racket/mzlonglong.c deleted file mode 100644 index 230bbc4bbd..0000000000 --- a/pkgs/racket-pkgs/racket-test/tests/racket/mzlonglong.c +++ /dev/null @@ -1,96 +0,0 @@ - -#include "escheme.h" - -static Scheme_Object *llsize(int argc, Scheme_Object **argv) -{ - return scheme_make_integer(sizeof(mzlonglong)); -} - -static Scheme_Object *toll(int argc, Scheme_Object **argv) -{ - mzlonglong l; - - if (scheme_get_long_long_val(argv[0], &l)) - return scheme_make_sized_byte_string((char *)&l, sizeof(mzlonglong), 1); - else - return scheme_false; -} - -static Scheme_Object *toull(int argc, Scheme_Object **argv) -{ - umzlonglong l; - - if (scheme_get_unsigned_long_long_val(argv[0], &l)) - return scheme_make_sized_byte_string((char *)&l, sizeof(umzlonglong), 1); - else - return scheme_false; -} - -static Scheme_Object *fromll(int argc, Scheme_Object **argv) -{ - mzlonglong l; - - if (!SCHEME_BYTE_STRINGP(argv[0]) - || (SCHEME_BYTE_STRTAG_VAL(argv[0]) != sizeof(mzlonglong))) - scheme_wrong_type("long-long-bytes->integer", - "byte string of mzlonglong size", - 0, argc, argv); - - - l = *(mzlonglong *)SCHEME_BYTE_STR_VAL(argv[0]); - - return scheme_make_integer_value_from_long_long(l); -} - -static Scheme_Object *fromull(int argc, Scheme_Object **argv) -{ - umzlonglong l; - - if (!SCHEME_BYTE_STRINGP(argv[0]) - || (SCHEME_BYTE_STRTAG_VAL(argv[0]) != sizeof(umzlonglong))) - scheme_wrong_type("unsigned-long-long-bytes->integer", - "byte string of mzlonglong size", - 0, argc, argv); - - - l = *(umzlonglong *)SCHEME_BYTE_STR_VAL(argv[0]); - - return scheme_make_integer_value_from_unsigned_long_long(l); -} - - - -Scheme_Object *scheme_reload(Scheme_Env *env) -{ - scheme_add_global("long-long-size", - scheme_make_prim_w_arity(llsize, "long-long-size", 0, 0), - env); - - scheme_add_global("integer->long-long-bytes", - scheme_make_prim_w_arity(toll, "integer->long-long-bytes", 1, 1), - env); - scheme_add_global("integer->unsigned-long-long-bytes", - scheme_make_prim_w_arity(toull, "integer->unsigned-long-long-bytes", 1, 1), - env); - - scheme_add_global("long-long-bytes->integer", - scheme_make_prim_w_arity(fromll, "long-long-bytes->integer", 1, 1), - env); - scheme_add_global("unsigned-long-long-bytes->integer", - scheme_make_prim_w_arity(fromull, "unsigned-long-long-bytes->integer", 1, 1), - env); - - return scheme_void; -} - -Scheme_Object *scheme_initialize(Scheme_Env *env) -{ - /* First load is same as every load: */ - return scheme_reload(env); -} - -Scheme_Object *scheme_module_name() -{ - /* This extension doesn't define a module: */ - return scheme_false; -} diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/mzq.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/mzq.rktl deleted file mode 100644 index 284599b775..0000000000 --- a/pkgs/racket-pkgs/racket-test/tests/racket/mzq.rktl +++ /dev/null @@ -1,3 +0,0 @@ - -(define quiet-load "mz-tests.rktl") -(load-relative "quiet.rktl") diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/nch.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/nch.rktl deleted file mode 100644 index 45398e6fb7..0000000000 --- a/pkgs/racket-pkgs/racket-test/tests/racket/nch.rktl +++ /dev/null @@ -1,30 +0,0 @@ - -(define (fact n) - (if (zero? n) - 1 - (* n (fact (- n 1))))) - -(define f1000 (fact 1000)) - -(define (divall n d) - (if (<= n 1) - d - (divall (/ n d) (+ 1 d)))) - -(define (nch n c) - (/ (fact n) (fact (- n c)) (fact c))) - -(define (snch n) - (letrec ((loop - (lambda (i) - (if (> i n) - 0 - (+ (nch n i) (loop (+ i 1))))))) - (loop 0))) - -(define (fsum n) - (if (zero? n) - 1 - (+ (fact n) (fsum (- n 1))))) - - diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/object-old.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/object-old.rktl deleted file mode 100644 index 80d000417d..0000000000 --- a/pkgs/racket-pkgs/racket-test/tests/racket/object-old.rktl +++ /dev/null @@ -1,657 +0,0 @@ - -; Test Racket's object system - -(load-relative "loadtest.rktl") - -(require mzlib/class) - -(Section 'object) - -(define (stx-test e) - (syntax-test (datum->syntax-object #f e #f))) -(define (err-test e exn) - (error-test (datum->syntax-object #f e #f) exn)) - -(define (test-class* cl* renames) - (stx-test `(,cl*)) - (stx-test `(,cl* ,@renames . x)) - (stx-test `(,cl* ,@renames 0)) - (stx-test `(,cl* ,@renames object% . x)) - (stx-test `(,cl* ,@renames object% 0)) - (stx-test `(,cl* ,@renames object% x)) - (stx-test `(,cl* ,@renames object% ())) - (stx-test `(,cl* ,@renames object% () (0) x)) - (stx-test `(,cl* ,@renames object% () 0)) - (stx-test `(,cl* ,@renames object% () . x)) - (stx-test `(,cl* ,@renames object% () () . x)) - (stx-test `(,cl* ,@renames object% () () x)) - (stx-test `(,cl* ,@renames object% () () public)) - (stx-test `(,cl* ,@renames object% () () (x))) - (stx-test `(,cl* ,@renames object% () (x) ())) - - (let () - (define (try-dotted cl) - (stx-test `(,cl* ,@renames object% () () (,cl . x)))) - - (map try-dotted '(public override private inherit rename - inherit-from rename-from - sequence))) - - (let () - (define (try-defn-kind cl) - (stx-test `(,cl* ,@renames object% () () (,cl 8))) - (stx-test `(,cl* ,@renames object% () () (,cl [8 9]))) - (stx-test `(,cl* ,@renames object% () () (,cl [(x) 9]))) - (stx-test `(,cl* ,@renames object% () () (,cl [(x y x) 9]))) - (stx-test `(,cl* ,@renames object% () () (,cl [x . 1]))) - (stx-test `(,cl* ,@renames object% () () (,cl [x 1 . 3]))) - (stx-test `(,cl* ,@renames object% () () (,cl [x 1 3])))) - - (try-defn-kind 'public) - (try-defn-kind 'override) - (try-defn-kind 'private)) - - (let () - (define (try-defn-rename-kind cl) - (stx-test `(,cl* ,@renames object% () () (,cl [((x) y) 9]))) - (stx-test `(,cl* ,@renames object% () () (,cl [(x (y)) 9]))) - (stx-test `(,cl* ,@renames object% () () (,cl [(x . y) 9]))) - (stx-test `(,cl* ,@renames object% () () (,cl [(x 1) 9]))) - (stx-test `(,cl* ,@renames object% () () (,cl [(1 x) 9])))) - (try-defn-rename-kind 'public) - (try-defn-rename-kind 'override)) - - (let () - (define (try-ref-kind cl) - (stx-test `(,cl* ,@renames object% () () (,cl 8))) - (stx-test `(,cl* ,@renames object% () () (,cl x 8))) - (stx-test `(,cl* ,@renames object% () () (,cl (x . y)))) - (stx-test `(,cl* ,@renames object% () () (,cl (x y z))))) - - (map try-ref-kind '(inherit rename share))) - (err-test `(,cl* ,@renames object% () () (inherit x)) exn:object?) - (err-test `(,cl* ,@renames object% () () (inherit (x y))) exn:object?) - (err-test `(,cl* ,@renames object% () () (override [x void])) exn:object?) - (err-test `(,cl* ,@renames object% () () (override [(x y) void])) exn:object?) - (stx-test `(,cl* ,@renames object% () () (inherit (x y z)))) - (stx-test `(,cl* ,@renames object% () () (inherit (x 5)))) - (stx-test `(,cl* ,@renames object% () () (inherit (x)))) - (stx-test `(,cl* ,@renames object% () () (rename x))) - (stx-test `(,cl* ,@renames object% () () (rename (x)))) - (stx-test `(,cl* ,@renames object% () () (rename ((x) y)))) - (stx-test `(,cl* ,@renames object% () () (rename ((x y) y)))) - (stx-test `(,cl* ,@renames object% () () (rename ((1) y)))) - - (stx-test `(,cl* ,@renames object% () () (inherit x) (sequence (set! x 5)))) - (stx-test `(,cl* ,@renames object% () () (rename [x y]) (sequence (set! x 5)))) - - (stx-test `(,cl* ,@renames object% () () (sequence 1 . 2))) - - (stx-test `(,cl* ,@renames object% () () (public [x 7] [x 9]))) - (stx-test `(,cl* ,@renames object% () (x) (public [x 7]))) - (stx-test `(,cl* ,@renames object% () (x) (public [(x w) 7]))) - (stx-test `(,cl* ,@renames object% () () (public [(x y) 7] [(z y) 9]))) - (stx-test `(,cl* ,@renames object% () () (public [(x y) 7] [(x z) 9]))) - - (stx-test `(,cl* ,@renames object% a ())) - (stx-test `(,cl* ,@renames object% (1 . a) ()))) - -(test-class* 'class* ()) -(test-class* 'class*/names '((this super))) - -(stx-test #'(class*/names 8 object% () () ())) -(stx-test #'(class*/names () object% () ())) -(stx-test #'(class*/names (8) object% () ())) -(stx-test #'(class*/names (this . 8) object% () ())) -(stx-test #'(class*/names (this 8) object% () ())) -(stx-test #'(class*/names (this super-init . 8) object% () ())) -(stx-test #'(class*/names (this super-init 8) object% () ())) - -(test #t class? (class* object% () ())) -(test #t class? (class* object% () ())) -(test #t class? (class* object% () x)) -(test #t class? (class* object% () () (public))) -(test #t class? (class* object% () () (public sequence))) -(test #t class? (class* object% () (x) (public [(y x) 9]))) -(test #t class? (class*/names (this super-init) object% () () (public))) - -(define c (class object% () (public x))) -(err/rt-test (class c () (public x)) exn:object?) -(err/rt-test (class c () (public ([y x] 5))) exn:object?) -(err/rt-test (class c () (override ([x y] 5))) exn:object?) - -(stx-test #'(interface)) -(stx-test #'(interface . x)) -(stx-test #'(interface 8)) -(stx-test #'(interface () 8)) -(stx-test #'(interface () x . y)) -(stx-test #'(interface () x 8)) -(stx-test #'(interface () x x)) -(err/rt-test (interface (8) x) exn:object?) - -(err/rt-test (interface ((class->interface (class object% ())) - (class->interface (class object% ())))) - exn:object?) - -(err/rt-test (interface ((interface () x)) x) exn:object?) -(err/rt-test (interface ((interface ((interface () x)) y)) x) exn:object?) -(test #t interface? (let ([i (interface () x)] - [j (interface () x)]) - (interface (i j) y))) -(err/rt-test (let ([i (interface () x)] - [j (interface () x)]) - (interface (i j) x)) - exn:object?) -(err/rt-test (interface ((class->interface (class object% () (public w)))) w) - exn:object?) - -(test #t interface? (interface ())) -(test #t interface? (interface () x)) -(test #f interface? (class* object% () ())) - -(define i0.1 (interface () x y)) -(define i0.2 (interface () y c d)) -(define i1 (interface (i0.1 i0.2) e)) -(define ix (interface () x y)) - -(test #t interface-extension? i1 i0.1) -(test #t interface-extension? i1 i0.2) -(test #f interface-extension? i0.1 i1) -(test #f interface-extension? i0.2 i1) -(test #f interface-extension? i0.2 i0.1) -(test #f interface-extension? i0.1 i0.2) - -(err/rt-test (let [(bad (class* object% (i0.1) ()))] bad) exn:object?) -(test #t class? (class* object% (i0.1) () (public x y))) -(err/rt-test (let ([cl (class* object% (i0.1 i0.2) () (public x y c))]) cl) exn:object?) -(err/rt-test (class* object% (i1) () (public x y c)) exn:object?) -(test #t class? (class* object% (i0.1 i0.1) () (public x y c d))) -(err/rt-test (class* object% (i1) () (public x y c d)) exn:object?) -(test #t class? (class* object% (i1) () (public x y c d e))) - -; No initialization: -(define no-init-c% (class* object% () ())) -(err/rt-test (make-object no-init-c%) exn:object?) - -(define c1 - (let ((v 10)) - (class* object% (i1) (in [in-2 'banana] . in-rest) - (public (x 1) (y 2)) - (private (a in) (b3 3)) - (public (b1 2) (b2 2) (e 0)) - (public (c 3) (d 7) - (f-1-a (lambda () a)) - (f-1-b1 (lambda () b1)) - (f-1-b2 (lambda () b2)) - (f-1-c (lambda () c)) - (f-1-v (lambda () v)) - (f-1-x (lambda () x)) - (f-1-top-a (lambda () (ivar this a))) - (f-1-other-e (lambda (o) (ivar o e))) - (f-1-set-b2 (lambda (v) (set! b2 v) b2)) - (f-1-in-2 (lambda () in-2)) - (f-1-in-rest (lambda () in-rest))) - (sequence - (set! e in) - (super-init))))) - -(test #t implementation? c1 i0.1) -(test #t implementation? c1 i0.2) -(test #t implementation? c1 (class->interface c1)) -(test #t implementation? c1 i1) -(test #f implementation? c1 ix) - -(test #t implementation? object% (class->interface object%)) -(test #t implementation? c1 (class->interface c1)) -(test #t implementation? (class c1 ()) (class->interface c1)) -(let ([i (interface ((class->interface c1)))]) - (test #f implementation? c1 i) - (test #t implementation? (class* c1 (i) ()) i)) - -(define o1 (make-object c1 0 'apple "first" "last")) - -(define c2 - (let ((v 20)) - (class c1 () - (inherit b2 (sup-set-b2 f-1-set-b2)) - (rename (also-e e) - (also-b2 b2)) - (override (b1 5) (c 6)) - (public (a 4) - (f-2-a (lambda () a)) - (f-2-b1 (lambda () b1)) - (f-2-b2 (lambda () b2)) - (f-2-also-b2 (lambda () also-b2)) - (f-2-c (lambda () c)) - ((i-f-2-v f-2-v) (lambda () v)) - (f-2-v-copy (lambda () (i-f-2-v))) - (f-2-set-b2 (lambda (v) (sup-set-b2 v)))) - (private (y 3)) - (sequence - (super-init 1))))) - -(test #t implementation? c2 i0.1) -(test #t implementation? c2 i0.2) -(test #t implementation? c2 i1) -(test #f implementation? c2 ix) -(test #t implementation? c2 (class->interface c2)) -(test #t implementation? c2 (class->interface c1)) -(test #f implementation? c1 (class->interface c2)) - -(test #t interface-extension? (class->interface c2) (class->interface object%)) -(test #t interface-extension? (class->interface c2) (class->interface c1)) -(test #t interface-extension? (class->interface c2) (class->interface c2)) -(test #f interface-extension? (class->interface c1) (class->interface c2)) -(test #t interface-extension? (class->interface c2) i0.1) -(test #f interface-extension? i0.1 (class->interface c2)) - -(define o2 (make-object c2)) - -(define c2.1 - (class*/names (this c2-init) c2 () () - (sequence - (c2-init)))) - -(define o2.1 (make-object c2.1)) - -(test #t interface? (interface ((class->interface c2) - (class->interface c2.1)))) - -(define c3 - (class* object% () () - (public (x 6) (z 7) (b2 8) - (f-3-b2 (lambda () b2))) - (sequence (super-init)))) - -(define o3 (make-object c3)) - -(define c6 - (class object% (x-x) - (public - [(i-a x-a) (lambda () 'x-a)] - [(x-a i-a) (lambda () 'i-a)] - [(i-x x-x) (lambda () 'x-x)] - [x-a-copy (lambda () (i-a))] - [i-a-copy (lambda () (x-a))]) - (sequence (super-init)))) - -(define o6 (make-object c6 'bad)) - -(define c7 - (class*/names (self super-init) object% () () - (public - [get-self (lambda () self)]) - (sequence (super-init)))) - -(define o7 (make-object c7)) - -(define display-test - (lambda (p v) - (printf "Should be ~s: ~s ~a\n" - p v (if (equal? p v) - "" - "ERROR")))) - -(define ivar? exn:object?) - -(test #t is-a? o1 c1) -(test #t is-a? o1 i1) -(test #t is-a? o1 (class->interface c1)) -(test #f is-a? o1 (interface ((class->interface c1)))) -(test #t is-a? o2 c1) -(test #t is-a? o2 i1) -(test #f is-a? o1 c2) -(test #f is-a? o1 (class->interface c2)) -(test #t is-a? o2 c2) -(test #t is-a? o2.1 c1) -(test #f is-a? o1 c3) -(test #f is-a? o2 c3) -(test #f is-a? o1 ix) -(test #f is-a? o2 ix) -(test #f is-a? o3 i1) -(test #f is-a? i1 i1) -(test #t subclass? c2 c1) -(test #t subclass? c2.1 c1) -(test #f subclass? c1 c2) -(test #f subclass? c1 c3) -(test #f subclass? i1 c3) -(test #t ivar-in-interface? 'f-1-a (class->interface c1)) -(test #t ivar-in-interface? 'f-1-a (class->interface c2)) -(test #f ivar-in-interface? 'f-2-a (class->interface c1)) -(test #t ivar-in-interface? 'f-2-a (class->interface c2)) -(test #t ivar-in-interface? 'x i0.1) -(test #t ivar-in-interface? 'x i1) -(test #f ivar-in-interface? 'x i0.2) -(test #f ivar-in-interface? 'c i0.1) -(test #t ivar-in-interface? 'c i0.2) -(test #t ivar-in-interface? 'c i1) -(test #f ivar-in-interface? 'zzz i1) -(test #t ivar-in-interface? 'f-1-a (class->interface c2)) -(test #t ivar-in-interface? 'f-1-a (interface ((class->interface c2)) one-more-method)) -(test #f ivar-in-interface? 'f-2-a (class->interface c1)) - -(err/rt-test (is-a? o1 o1)) -(err/rt-test (subclass? o1 o1)) -(err/rt-test (subclass? o1 i1)) -(err/rt-test (implementation? o1 o1)) -(err/rt-test (implementation? o1 c1)) -(err/rt-test (ivar-in-interface? 0 i1)) -(err/rt-test (ivar-in-interface? 'a o1)) -(err/rt-test (ivar-in-interface? 'a c1)) -(err/rt-test (ivar-in-interface? 'a o1)) - -(define (test/list l1 l2) - (test #t 'ivar-list (and (= (length l1) - (length l2)) - (andmap (lambda (i) (member i l2)) - l1) - #t))) - -(test/list '(hi there) - (interface->ivar-names - (interface () hi there))) -(test/list '(hi too mee there) - (interface->ivar-names - (interface ((interface () hi there)) mee too))) -(test/list '(hi too mee z y there) - (interface->ivar-names - (interface ((interface ((class->interface - (class object% () - (public y z) - (private nono)))) - hi there)) - mee too))) - - -(test 0 class-initialization-arity object%) -(test #t arity-at-least? (class-initialization-arity c1)) -(test 1 arity-at-least-value (class-initialization-arity c1)) -(test 0 class-initialization-arity c2) - -(test '(1 2) class-initialization-arity (class object% (a [b 2]))) - -(arity-test object? 1 1) -(arity-test class? 1 1) -(arity-test interface? 1 1) -(arity-test is-a? 2 2) -(arity-test subclass? 2 2) -(arity-test interface-extension? 2 2) -(arity-test ivar-in-interface? 2 2) -(arity-test class-initialization-arity 1 1) - -(arity-test ivar/proc 2 2) -(arity-test make-generic/proc 2 2) - -(err/rt-test (ivar o1 a) ivar?) -(test 4 ivar/proc o2 'a) - -(define (ivar-tests -ivar xtra-ok?) - (stx-test `(,-ivar)) - (stx-test `(,-ivar 7)) - (stx-test `(,-ivar 7 8)) - (stx-test `(,-ivar 7 (x))) - (stx-test `(,-ivar 7 8 9)) - (unless xtra-ok? - (stx-test `(,-ivar 7 x 9)))) -(ivar-tests 'ivar #f) -(ivar-tests 'send #t) -(ivar-tests 'make-generic #f) - -(test 0 'send (send o1 f-1-a)) -(test 1 'send (send o2 f-1-a)) -(test 4 'send (send o2 f-2-a)) - -(test 'apple 'send (send o1 f-1-in-2)) -(test 'banana 'send (send o2 f-1-in-2)) -(test '("first" "last") 'send (send o1 f-1-in-rest)) -(test '() 'send (send o2 f-1-in-rest)) - -(err/rt-test (send o1 f-1-top-a) ivar?) -(test 4 'send (send o2 f-1-top-a)) - -(test 5 ivar/proc o2 'b1) - -(test 2 'send (send o1 f-1-b1)) -(test 2 'send (send o1 f-1-b2)) -(test 5 'send (send o2 f-1-b1)) -(test 2 'send (send o2 f-1-b2)) -(test 5 'send (send o2 f-2-b1)) -(test 2 'send (send o2 f-2-b2)) -(test 2 'send (send o2 f-2-also-b2)) - -(test 3 ivar/proc o1 'c) -(test 6 ivar/proc o2 'c) - -(test 3 'send (send o1 f-1-c)) -(test 6 'send (send o2 f-1-c)) -(test 6 'send (send o2 f-2-c)) - -(test 7 ivar/proc o1 'd) -(test 7 ivar/proc o2 'd) - -(test 10 'send (send o1 f-1-v)) -(test 10 'send (send o2 f-1-v)) -(test 20 'send (send o2 f-2-v)) -(test 20 'send (send o2 f-2-v-copy)) - -(err/rt-test (ivar o2 i-f-2-v) ivar?) - -(test 0 'send (send o1 f-1-other-e o1)) -(test 1 'send (send o1 f-1-other-e o2)) - -(test 2 ivar/proc o2 'y) - -(test 3 'send (send o2 f-2-set-b2 3)) -(test 3 'send (send o2 f-2-also-b2)) - -(test 'i-a 'send (send o6 i-a)) -(test 'x-a 'send (send o6 x-a)) -(test 'i-a 'send (send o6 i-a-copy)) -(test 'x-a 'send (send o6 x-a-copy)) -(test 'x-x 'send (send o6 x-x)) - -(test #t eq? o7 (send o7 get-self)) - -(define g1 (make-generic c1 x)) -(test 1 g1 o1) -(test 1 g1 o2) -(arity-test g1 1 1) - -(err/rt-test (make-generic c1 www) exn:object?) - -(define g2 (make-generic c2 x)) -(test 1 g2 o2) - -(define g0 (make-generic i0.1 x)) -(test 1 g0 o1) -(test 1 g0 o2) -(arity-test g0 1 1) -(test 'hi g0 (make-object (class* object% (i0.1) () - (public [x 'hi][y 'bye]) - (sequence (super-init))))) - -(err/rt-test (make-generic i0.1 www) exn:object?) - -(err/rt-test (g2 o1) exn:object?) -(err/rt-test (g0 o3) exn:object?) - -(err/rt-test (class* 7 () ()) exn:object?) -(err/rt-test (class* null () ()) exn:object?) -(err/rt-test (let ([c (class* 7 () ())]) c) exn:object?) -(err/rt-test (class* object% (i1 7) ()) exn:object?) -(err/rt-test (let ([c (class* object% (i1 7) ())]) c) exn:object?) -(err/rt-test (interface (8) x) exn:object?) -(err/rt-test (let ([i (interface (8) x)]) i) exn:object?) -(err/rt-test (interface (i1 8) x) exn:object?) -(err/rt-test (make-generic c2 not-there) exn:object?) - -(err/rt-test (make-object (class* c1 () ())) exn:object?) -(err/rt-test (make-object (let ([c (class* c1 () ())]) c)) exn:object?) - -(err/rt-test (make-object - (class* c2 () () (sequence (super-init) (super-init)))) - exn:object?) -(err/rt-test (make-object - (let ([c (class* c2 () () (sequence (super-init) (super-init)))]) c)) - exn:object?) - -(err/rt-test (make-object (class object% (x))) exn:application:arity?) -(err/rt-test (make-object (let ([c (class object% (x))]) c)) exn:application:arity?) - - -(define c100 - (let loop ([n 99][c (class c1 args (public [z -1]) (sequence (apply super-init args)))]) - (if (zero? n) - c - (loop (sub1 n) (class c args - (override (z n)) - (sequence - (apply super-init args))))))) - -(define o100 (make-object c100 100)) -(test 100 'send (send o100 f-1-a)) -(test 1 'ivar (ivar o100 z)) - -(test 5 'init (let ([g-x 8]) (make-object (class* object% () ([x (set! g-x 5)]) (sequence (super-init)))) g-x)) -(test 8 'init (let ([g-x 8]) (make-object (class* object% () ([x (set! g-x 5)]) (sequence (super-init))) 0) g-x)) - -(test (letrec ([x x]) x) 'init (send (make-object - (class* object% () ([x y] [y x]) - (public (f (lambda () x))) - (sequence (super-init)))) - f)) - -(define inh-test-expr - (lambda (super derive-pre? rename? override? override-pre?) - (let* ([order - (lambda (pre? a b) - (if pre? - (list a b) - (list b a)))] - [base-class - `(class ,(if super - super - '(class object% (n) - (public [name (lambda () n)]) - (sequence (super-init)))) - () - ,(if (not rename?) - '(inherit name) - '(rename [super-name name])) - ,@(order - derive-pre? - `(public [w ,(if rename? 'super-name 'name)]) - '(sequence (super-init 'tester))))]) - `(ivar - (make-object - ,(if override? - `(class ,base-class () - ,@(order - override-pre? - '(sequence (super-init)) - '(override [name (lambda () 'o-tester)]))) - base-class)) - w)))) - -(define (do-override-tests super) - (define (eval-test v e) - (teval `(test ,v (quote, e) - (let ([v ,e]) - (if (procedure? v) - (v) - v))))) - - (eval-test '(letrec ([x x]) x) (inh-test-expr super #t #f #f #f)) - (eval-test '(letrec ([x x]) x) (inh-test-expr super #t #f #t #t)) - (eval-test '(letrec ([x x]) x) (inh-test-expr super #f #f #t #t)) - - (eval-test '(letrec ([x x]) x) (inh-test-expr super #t #t #f #f)) - (eval-test '(letrec ([x x]) x) (inh-test-expr super #t #t #t #f)) - (eval-test '(letrec ([x x]) x) (inh-test-expr super #t #t #t #t)) - - (eval-test ''tester (inh-test-expr super #f #f #f #f)) - (eval-test ''o-tester (inh-test-expr super #t #f #t #f)) - (eval-test ''o-tester (inh-test-expr super #f #f #t #f)) - - (eval-test ''tester (inh-test-expr super #f #t #f #f)) - (eval-test ''tester (inh-test-expr super #f #t #t #t)) - (eval-test ''tester (inh-test-expr super #f #t #t #f))) - -(do-override-tests #f) - -'(when (defined? 'primclass%) - (err/rt-test (make-object primclass%) exn:application:arity?) - (err/rt-test (make-object primsubclass%) exn:application:arity?) - - (let () - (define o (make-object primclass% 'tester)) - (arity-test (ivar o name) 0 0) - (test 'tester (ivar o name)) - (test "primclass%" (ivar o class-name)) - - (let () - (define o2 (make-object primsubclass% 'tester)) - (arity-test (ivar o2 name) 0 0) - (arity-test (ivar o2 detail) 0 0) - (test 'tester (ivar o2 name)) - (test #f (ivar o2 detail)) - (test "primsubclass%" (ivar o2 class-name)) - - (do-override-tests 'primclass%) - (do-override-tests 'primsubclass%) - - (let () - (define name-g (make-generic primclass% name)) - (define class-name-g (make-generic primclass% class-name)) - - (define sub-name-g (make-generic primsubclass% name)) - (define sub-class-name-g (make-generic primsubclass% class-name)) - (define sub-detail-g (make-generic primsubclass% detail)) - - (test 'tester (name-g o)) - (test "primclass%" (class-name-g o)) - - (test 'tester (name-g o2)) - (test "primsubclass%" (class-name-g o2)) - (test 'tester (sub-name-g o2)) - (test "primsubclass%" (sub-class-name-g o2)) - (test #f (sub-detail-g o2)) - - (let () - (define c% - (class primsubclass% () - (inherit name detail class-name) - (sequence (super-init 'example)) - (public - [n name] - [d detail] - [c class-name]))) - - (define o3 (make-object c%)) - (test 'example (ivar o3 n)) - (test #f (ivar o3 d)) - (test "primsubclass%" (ivar o3 c)) - (test 'example (ivar o3 name)) - (test #f (ivar o3 detail)) - (test "primsubclass%" (ivar o3 class-name)) - - (test 'example (name-g o3)) - (test "primsubclass%" (class-name-g o3)) - (test 'example (sub-name-g o3)) - (test "primsubclass%" (sub-class-name-g o3)) - (test #f (sub-detail-g o3))))))) - - -; Test for override/rename order -(define bsc (class object% () - (public [x (lambda () 10)]) - (sequence (super-init)))) -(define orc (class bsc () - (public [y (lambda () (super-x))]) - (override [x (lambda () 20)]) - (rename [super-x x]) - (sequence (super-init)))) -(test 10 (ivar (make-object orc) y)) - -(report-errs) - diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/object.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/object.rktl index 35f2047d01..e725dc8fc6 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/object.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/object.rktl @@ -1,7 +1,7 @@ (load-relative "loadtest.rktl") -(require scheme/class) +(require racket/class) (Section 'object) @@ -1361,8 +1361,9 @@ (define class-taint-%%-init (gensym 'class-taint-%%-init)) (define class-taint-%%-client (gensym 'class-taint-%%-client)) (teval - `(module ,class-taint-%%-init mzscheme - (require mzlib/class) + `(module ,class-taint-%%-init racket/base + (require racket/class + (for-syntax racket/base)) (define-syntax (init-private stx) (syntax-case stx () [(_ name value) @@ -1372,11 +1373,11 @@ (,form (,(if rename? '(internal-name name) 'internal-name) value)) (define name internal-name)))])) - (provide (all-defined)))) + (provide (all-defined-out)))) ;; Shouldn't fail with a taint erorr: (teval - `(module ,class-taint-%%-client mzscheme - (require mzlib/class + `(module ,class-taint-%%-client racket/base + (require racket/class ',class-taint-%%-init) (define taint-error% (class object% @@ -1639,6 +1640,10 @@ (if d-cycle? (display this p) (display "HI" p))) + (define/public (custom-print p) + (if d-cycle? + (print this p) + (display "HI" p))) (super-new))) (let ([p (open-output-bytes)]) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/oe.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/oe.rktl deleted file mode 100644 index b2b1740699..0000000000 --- a/pkgs/racket-pkgs/racket-test/tests/racket/oe.rktl +++ /dev/null @@ -1,42 +0,0 @@ -(define-values (odd) (lambda (x) (if (zero? x) #f (even (- x 1))))) -(define-values (even) (lambda (x) (if (zero? x) #t (odd (- x 1))))) - -(define-values (odd2) - (letrec ([even (lambda (x) (if (zero? x) #t (odd (- x 1))))] - [odd (lambda (x) (if (zero? x) #f (even (- x 1))))]) - odd)) - -(define-values (odd3) - (let ([test (lambda (base other) - (lambda (x) (if (zero? x) base ((other) (- x 1)))))]) - (letrec ([odd (test #f (lambda () even))] - [even (test #t (lambda () odd))]) - odd))) - -(define-values (fib) - (lambda (n) - (if (<= n 1) - 1 - (+ (fib (- n 1)) (fib (- n 2)))))) - -(define-values (mutate) - (lambda (n) - (let loop () - (unless (zero? n) - (set! n (sub1 n)) - (loop))))) - -(define-values (mutate-evil) - (lambda (n) - (let loop ([n n]) - (unless (zero? n) - (set! n (sub1 n)) - (loop n))))) - -(define-values (c-loop) - (let-values ([(a b c d e f g) (values 1 2 3 4 5 6 7)]) - (lambda (n) - (let loop ([n n]) - (if (zero? n) - (+ a b c d e f g) - (loop (sub1 n))))))) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/pack.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/pack.rktl index 1a405f611d..04b4c9e175 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/pack.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/pack.rktl @@ -8,9 +8,9 @@ (require setup/pack setup/unpack - mzlib/process + racket/system setup/dirs - mzlib/file) + racket/file) ;; Test via mzc interface diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/package-gen.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/package-gen.rktl deleted file mode 100644 index 8fc9f88952..0000000000 --- a/pkgs/racket-pkgs/racket-test/tests/racket/package-gen.rktl +++ /dev/null @@ -1,130 +0,0 @@ - -(require scheme/package - mzlib/pretty - syntax/toplevel) - -(define (check x) - (unless (equal? x 'this-is-right) - (error "check" "nopde: ~e" x))) - -(define open-context-forms - (list (lambda (l) `(begin ,@l)) - (lambda (l) `(let () ,@l)) - (lambda (l) `(define-package other () ,@l)))) - -(define open-forms - (apply - append - (map - (lambda (open-form) - (map (lambda (ctx) - (ctx `((,open-form pk-to-open) (check var-to-use)))) - open-context-forms)) - (list 'open-package 'open*-package)))) - -(define (mk-package-shell-forms name) - (list (lambda (body) `(define-package ,name #:all-defined ,@body)) - (lambda (body) `(define-package ,name (var-to-use) ,@body)))) - -(define package-shell-forms - (mk-package-shell-forms 'pk-to-open)) - -(define defn-forms - (list '(define var-to-use 'this-is-right) - '(define* var-to-use 'this-is-right) - '(begin - (define* var-to-use 'this-is-wrong) - (define* var-to-use 'this-is-right)))) - -(define body-forms - (apply - append - (map (lambda (body-ctx) - (map body-ctx defn-forms)) - (list - (lambda (d) `(,d)) - (lambda (d) `((begin ,d))) - (lambda (d) `((define y 'no-this-one) ,d)) - (lambda (d) `(,d (define y 'no-this-one))))))) - - -(define package-forms - (apply - append - (map - (lambda (ps) - (map ps body-forms)) - package-shell-forms))) - -(define combo-context-forms - (list (lambda (p o) `(begin ,p ,o)) - (lambda (p o) `(let () ,p ,o 10)) - (lambda (p o) `(define-package out1 #:all-defined ,p ,o)) - (lambda (p o) `(define-package out2 #:all-defined (define-package out1 #:all-defined ,p ,o))))) - -(define all-forms - (apply - append - (map (lambda (cc) - (apply - append - (map (lambda (p) - (map (lambda (o) - (cc p o)) - open-forms)) - package-forms))) - combo-context-forms))) - -(define do-threshold 3) - -(let ([ns (current-namespace)] - [total (length all-forms)] - [cnt 0]) - (for-each (lambda (form) - (set! cnt (add1 cnt)) - (when (zero? (modulo cnt 100)) - (printf "~a/~a\n" cnt total)) - (when ((add1 (random 10)) . >= . do-threshold) - ;; (pretty-print form) - (parameterize ([current-namespace (make-base-namespace)]) - (namespace-attach-module ns 'scheme/package) - (let ([done? #f] - [mode "top-level"]) - (with-handlers ([exn:fail? - (lambda (x) - (printf "At ~a:\n" mode) - (pretty-print form) - (raise x))]) - (eval `(require scheme/package)) - (eval `(define check ,(lambda (x) - (check x) - (set! done? #t)))) - (eval form) - (unless done? - (error "check" "didn't execute")) - (set! done? #f) - (set! mode "top-level expand") - (eval-syntax (expand-top-level-with-compile-time-evals - (datum->syntax #f form))) - (unless done? - (error "check" "didn't execute after expand")) - (let ([mod (lambda (name) - `(module ,name scheme/base - (require scheme/package) - (define check ,(lambda (x) - (check x) - (set! done? #t))) - ,form))]) - (set! done? #f) - (set! mode "module") - (eval (mod 'm)) - (eval `(require 'm)) - (unless done? - (error "check" "module didn't execute")) - (set! done? #f) - (set! mode "module expand") - (eval-syntax (expand (mod 'n))) - (eval `(require 'n)) - (unless done? - (error "check" "module didn't execute after expand")))))))) - all-forms)) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/runflats.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/runflats.rktl deleted file mode 100644 index a7143cbf32..0000000000 --- a/pkgs/racket-pkgs/racket-test/tests/racket/runflats.rktl +++ /dev/null @@ -1,12 +0,0 @@ -(for-each (lambda (f) - (when (regexp-match "^flat-[0-9]+[.]ss$" (path->string f)) - (let ([ns (current-namespace)]) - (parameterize ([current-namespace (make-base-namespace)] - [exit-handler void]) - (namespace-attach-module ns 'scheme) - (namespace-require 'scheme) - (eval - `(begin - (define quiet-load ,(path->string f)) - (load-relative "quiet.rktl"))))))) - (directory-list)) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/serialize.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/serialize.rktl index d9cead9f50..42928565b0 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/serialize.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/serialize.rktl @@ -298,7 +298,7 @@ ;; ---------------------------------------- (module ser-mod mzscheme - (require mzlib/serialize) + (require racket/serialize) (provide ser-mod-test) (define-serializable-struct foo (a b)) @@ -312,7 +312,7 @@ ;; ---------------------------------------- ;; Classes -(require mzlib/class) +(require racket/class) (define-serializable-class s:c% object% (init-field [one 0]) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/sp.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/sp.rktl deleted file mode 100644 index 6d4d9065bf..0000000000 --- a/pkgs/racket-pkgs/racket-test/tests/racket/sp.rktl +++ /dev/null @@ -1,44 +0,0 @@ - -(load-relative "testing.rktl") - -(require mzlib/process) - -(Section 'subprocess) - -(define self - (parameterize ([current-directory (find-system-path 'orig-dir)]) - (find-executable-path (find-system-path 'exec-file) #f))) - -(unless (eq? 'windows (system-type)) - (let ([try - (lambda (post-shutdown?) - (let ([l (parameterize ([subprocess-group-enabled (not post-shutdown?)]) - (process* self - "-e" - (format "(define l (process* \"~a\" \"-e\" \"(let loop () (loop))\"))" self) - "-e" - "(displayln (list-ref l 2))" - "-e" - "(flush-output)" - "-e" - "(let loop () (loop))"))] - [running? (lambda (sub-pid) - (regexp-match? - (format "(?m:^ *~a(?=[^0-9]))" sub-pid) - (let ([s (open-output-string)]) - (parameterize ([current-output-port s] - [current-input-port (open-input-string "")]) - (system (format "ps x"))) - (get-output-string s))))]) - (let ([sub-pid (read (car l))]) - (test 'running (list-ref l 4) 'status) - (test #t running? sub-pid) - ((list-ref l 4) 'kill) - ((list-ref l 4) 'wait) - (test 'done-error (list-ref l 4) 'status) - (test post-shutdown? running? sub-pid) - (when post-shutdown? - (parameterize ([current-input-port (open-input-string "")]) - (system (format "kill ~a" sub-pid)))))))]) - (try #t) - (try #f))) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/srfi.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/srfi.rktl deleted file mode 100644 index f0d7fbc2d5..0000000000 --- a/pkgs/racket-pkgs/racket-test/tests/racket/srfi.rktl +++ /dev/null @@ -1,61 +0,0 @@ -;; SRFI Tests - -(load-relative "loadtest.rktl") - -;; Test that all SRFIs load. Run this in both DrRacket and -;; Racket for maximum coverage. - -;; We just require all the SRFIs and hope nothing bombs. -;; Keep an eye out for error messages! - -(require srfi/1) -(require srfi/1/list) -(require srfi/2/and-let) -(require srfi/4) -(require srfi/5/let) -(require srfi/6) -(require srfi/7/program) -(require srfi/8/receive) -(require srfi/9/record) -(require srfi/11) -(require srfi/13/string) -(require srfi/14/char-set) -(require srfi/16) -(require srfi/17/set) -(require srfi/18) -(require srfi/19/time) -(require srfi/23) -(require srfi/25/array) -(require srfi/26/cut) -(require srfi/27/random-bits) -(require srfi/28) -(require srfi/29/localization) -(require srfi/30) -(require srfi/31/rec) -(require srfi/32/sort) -(require srfi/34/exception) -(require srfi/35) -(require srfi/35/condition) -(require srfi/38) -(require srfi/39) -(require srfi/40/stream) -(require (lib "srfi/42/comprehensions.scm")) -(require srfi/43/vector-lib) -(require srfi/45/lazy) -(require srfi/48/format) -(require srfi/54/cat) -(require srfi/57/records) -(require srfi/59/vicinity) -(require srfi/60/60) -(require srfi/61) -(require srfi/63) -(require srfi/64) -(require srfi/64/testing) -(require srfi/66) -(require srfi/67/compare) -(require srfi/69/hash) -(require srfi/71/letvalues) -(require srfi/74/74) -(require srfi/78/check) -(require srfi/86) -(require srfi/87/case) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/stx.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/stx.rktl index bcd22aaebd..8dcab5e6d3 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/stx.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/stx.rktl @@ -483,11 +483,13 @@ (cdddr b)) b))) -(test '('#%kernel case-lambda (lib "racket/init") case-lambda 0 0 0) +(define base-lib (caddr (identifier-binding* #'lambda))) + +(test `('#%kernel case-lambda ,base-lib case-lambda 0 0 0) identifier-binding* #'case-lambda) -(test '("private/promise.rkt" delay* (lib "racket/init") delay 0 0 0) +(test `("private/promise.rkt" delay* ,base-lib delay 0 0 0) identifier-binding* #'delay) -(test '('#%kernel #%module-begin (lib "racket/init") #%plain-module-begin 0 0 0) +(test `('#%kernel #%module-begin ,base-lib #%plain-module-begin 0 0 0) identifier-binding* #'#%plain-module-begin) (require (only-in racket/base [#%plain-module-begin #%pmb])) (test '('#%kernel #%module-begin racket/base #%plain-module-begin 0 0 0) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/syntax-tests.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/syntax-tests.rktl deleted file mode 100644 index 111c3d7cb9..0000000000 --- a/pkgs/racket-pkgs/racket-test/tests/racket/syntax-tests.rktl +++ /dev/null @@ -1,9 +0,0 @@ -(load-relative "loadtest.rktl") - -(load-in-sandbox "moddep.rktl") -(load-in-sandbox "boundmap-test.rktl") -(load-in-sandbox "id-table-test.rktl") -(load-in-sandbox "cm.rktl") -(load-in-sandbox "module-reader.rktl") - -(report-errs) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/test.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/test.rkt new file mode 100644 index 0000000000..35ae09a796 --- /dev/null +++ b/pkgs/racket-pkgs/racket-test/tests/racket/test.rkt @@ -0,0 +1,3 @@ +#lang racket/load + +(load "quiet.rktl") diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/trace.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/trace.rktl index f14e10926a..df04cf41ff 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/trace.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/trace.rktl @@ -2,7 +2,7 @@ (Section 'trace) -(require scheme/trace) +(require racket/trace) (define-syntax-rule (trace-output expr ...) (let ([out '()]) @@ -68,3 +68,5 @@ 'trace-quotes (list ">(f (1 2 3) #:q #&18)" "<((1 2 3) 1)"))) + +(report-errs) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/trait.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/trait.rktl index 9a7b0de277..a120fc38eb 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/trait.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/trait.rktl @@ -1,8 +1,8 @@ (load-relative "loadtest.rktl") -(require mzlib/class - mzlib/trait) +(require racket/class + racket/trait) (Section 'trait) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/ttt/listlib.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/ttt/listlib.rktl deleted file mode 100644 index 9b9427f7a8..0000000000 --- a/pkgs/racket-pkgs/racket-test/tests/racket/ttt/listlib.rktl +++ /dev/null @@ -1,42 +0,0 @@ -;; -------------------------------------------------------------------------- -;; list-library.rkt -;; export: -;; collect: -;; (A ((cons B (listof B)) (listof B) (union A C) -> (union A C)) -;; -> -;; ((listof B) -> (union A C))) - -; #| -; (unit/sig -; (collect filter set-minus subset?) -; (import plt:userspace^) -; |# - - (define collect - (lambda (base combine) - (letrec ([C - (lambda (l) - (cond - ((null? l) base) - (else (combine l (car l) (C (cdr l))))))]) - C))) - - (define filter - (lambda (p? l) - [(collect null (lambda (_ x rest) (if (p? x) (cons x rest) rest))) l])) - - ;; set library - (define set-minus - (lambda (set1 set2) - [(collect null (lambda (_ e1 rest) (if (member e1 set2) rest (cons e1 rest)))) - set1])) - - (define subset? - (lambda (state1 state2) - (cond - ((null? state1) #t) - (else (and (member (car state1) state2) - (subset? (cdr state1) state2)))))) -; #| -; ) -; |# diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/ttt/tic-bang.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/ttt/tic-bang.rktl deleted file mode 100644 index 190c23d166..0000000000 --- a/pkgs/racket-pkgs/racket-test/tests/racket/ttt/tic-bang.rktl +++ /dev/null @@ -1,125 +0,0 @@ -;; -------------------------------------------------------------------------- -;; tic-bang.rkt -;; This is an imperative version. - -;; This program plays through all possibilities of a tic-tac-toe -;; game, given the first move of a player. It only prints how many -;; states are being processed and how many states are terminal at -;; each stage of the game. - -;; This program lacks the capability to print how a situation arose. - -;; It relies on list-library.rkt. - -(load-relative "listlib.rktl") - -;; representations of fields, states, and collections of states -(define BLANK 0) - -(define new-state - (lambda () - (make-2vec 3 BLANK))) - -(define update-state - (lambda (state x y token) - (2vec-set! state x y token) - state)) - -(define blank? - (lambda (astate i j) - (eq? (2vec-ref astate i j) BLANK))) - -(define clone-state - (lambda (state) - (let ((s (new-state))) - (let loop ((i 0) (j 0)) - (cond - ((and (= i 3) (= j 0)) (void)) - ((< j 3) (update-state s i j (2vec-ref state i j)) (loop i (+ j 1))) - ((< i 3) (loop (+ i 1) 0)) - (else 'bad))) - s))) - -;(define-type state (2vector (union 'x 'o '_))) -;(define-type states (listof state)) - -(define PLAYER 1) -(define OPPONENT 2) - -(define tic-tac-toe - (lambda (x y) - (tic (list (update-state (new-state) (- x 1) (- y 1) PLAYER))))) - -(define make-move - (lambda (other-move p/o tag) - (lambda (states) - (printf "~s: processing ~s states \n" tag (length states)) - (let ((t (print&remove-terminals states))) - (printf "terminal states removed: ~s\n" - (- (length states) (length t))) - (if (null? t) - (void) - (other-move (apply append (map p/o t)))))))) - -(define tic (make-move (lambda (x) (tac x)) (lambda (x) (opponent x)) 'tic)) - -(define tac (make-move (lambda (x) (tic x)) (lambda (x) (player x)) 'tac)) - -(define make-players - (lambda (p/o) - (lambda (astate) - (let loop ((i 0) (j 0)) - (cond - ((and (= i 3) (= j 0)) null) - ((< j 3) (if (blank? astate i j) - (cons (update-state (clone-state astate) i j p/o) - (loop i (+ j 1))) - (loop i (+ j 1)))) - ((< i 3) (loop (+ i 1) 0)) - (else (error 'make-player "ouch"))))))) - -(define player (make-players PLAYER)) - -(define opponent (make-players OPPONENT)) - -(define print&remove-terminals - (local ((define print-state - (lambda (x) - ;(display ".") - (void)))) - - (collect null (lambda (_ astate rest) - (if (terminal? astate) - (begin (print-state astate) rest) - (cons astate rest)))))) - -(define terminal? - (lambda (astate) - (or (terminal-row 0 astate) - (terminal-row 1 astate) - (terminal-row 2 astate) - (terminal-col 0 astate) - (terminal-col 1 astate) - (terminal-col 2 astate) - (terminal-posdg astate) - (terminal-negdg astate)))) - -(define terminal-row - (lambda (n state) - (and (not (blank? state n 0)) - (= (2vec-ref state n 0) (2vec-ref state n 1) (2vec-ref state n 2))))) - -(define terminal-col - (lambda (n state) - (and (not (blank? state 0 n)) - (= (2vec-ref state 0 n) (2vec-ref state 1 n) (2vec-ref state 2 n))))) - -(define terminal-posdg - (lambda (state) - (and (not (blank? state 0 0)) - (= (2vec-ref state 0 0) (2vec-ref state 1 1) (2vec-ref state 2 2))))) - -(define terminal-negdg - (lambda (state) - (and (not (blank? state 0 2)) - (= (2vec-ref state 0 2) (2vec-ref state 1 1) (2vec-ref state 2 0))))) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/ttt/tic-func.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/ttt/tic-func.rktl deleted file mode 100644 index e3563188b6..0000000000 --- a/pkgs/racket-pkgs/racket-test/tests/racket/ttt/tic-func.rktl +++ /dev/null @@ -1,122 +0,0 @@ -;; -------------------------------------------------------------------------- -;; tic-func.rkt -;; This program plays through all possibilities of a tic-tac-toe -;; game, given the first move of a player. It only prints how many -;; states are being processed and how many states are terminal at -;; each stage of the game. But it is constructed so that it can -;; print how to get to a winning terminal state. - -;; It relies on list-library.rkt. - -(load-relative "listlib.rktl") - -;; representations of fields, states, and collections of states -(define null '()) -(define-struct entry ( x y who)) -(define entry-field - (lambda (an-entry) - (list (entry-x an-entry) (entry-y an-entry)))) -;(define-type state (listof (structure:entry num num (union 'x 'o))) -;(define-type states (listof state)) - -(define PLAYER 'x) -(define OPPONENT 'o) - -(define tic-tac-toe - (lambda (x y) - (tic (list (list (make-entry x y PLAYER)))))) - -(define make-move - (lambda (other-move p/o tag) - (lambda (states) - (printf "~s: processing ~s states of length ~s \n" - tag (length states) (length (car states))) - (let ((t (print&remove-terminals states))) - (printf "terminal states removed: ~s\n" - (- (length states) (length t))) - (if (null? t) - (void) - (other-move (apply append (map p/o t)))))))) - -(define tic (make-move (lambda (x) (tac x)) (lambda (x) (opponent x)) 'tic)) - -(define tac (make-move (lambda (x) (tic x)) (lambda (x) (player x)) 'tac)) - -(define make-players - (let () - (define rest-of-fields - (lambda (used-fields) - (set-minus ALL-FIELDS used-fields))) - (lambda (player/opponent) - (lambda (astate) - (map (lambda (counter-move) - (let ((counter-x (car counter-move)) - (counter-y (cadr counter-move))) - (cons (make-entry counter-x counter-y player/opponent) - astate))) - (rest-of-fields (map entry-field astate))))))) - -(define player (make-players PLAYER)) - -(define opponent (make-players OPPONENT)) - -(define terminal? - (let () (define filter-p/o - (lambda (p/o astate) - (map entry-field - (filter (lambda (x) (eq? (entry-who x) p/o)) astate)))) - (lambda (astate) - (and (>= (length astate) 5) - (let ((PLAYERf (filter-p/o PLAYER astate)) - (OPPONENTf (filter-p/o OPPONENT astate))) - (or - (= (length astate) 9) - (ormap (lambda (ts) (subset? ts PLAYERf)) TERMINAL-STATES) - (ormap (lambda (ts) (subset? ts OPPONENTf)) TERMINAL-STATES))))))) - -(define print&remove-terminals - (let () - - (define print-state1 - (lambda (x) - (display x) - (newline))) - - (define print-state2 - (lambda (astate) - (cond - ((null? astate) (printf "------------\n")) - (else (print-state (cdr astate)) - (let ((x (car astate))) - (printf " ~s @ (~s,~s) \n" - (entry-who x) (entry-x x) (entry-y x))))))) - - (define print-state - (lambda (x) - ;(display ".") - (void))) - - (collect null (lambda (_ astate rest) - (if (terminal? astate) - (begin (print-state astate) rest) - (cons astate rest)))))) -;; fields -(define T - (lambda (alof) - (cond - ((null? alof) null) - (else (cons (list (cadr (car alof)) (car (car alof))) - (T (cdr alof))))))) - -(define row1 (list (list 1 1) (list 1 2) (list 1 3))) -(define row2 (list (list 2 1) (list 2 2) (list 2 3))) -(define row3 (list (list 3 1) (list 3 2) (list 3 3))) -(define col1 (list (list 1 1) (list 2 1) (list 3 1))) -(define col2 (list (list 1 2) (list 2 2) (list 3 2))) -(define col3 (list (list 1 3) (list 2 3) (list 3 3))) -(define posd (list (list 1 1) (list 2 2) (list 3 3))) -(define negd (list (list 1 3) (list 2 2) (list 3 1))) - -(define TERMINAL-STATES (list row1 row2 row3 col1 col2 col3 posd negd)) - -(define ALL-FIELDS (append row1 row2 row3)) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/ttt/ttt.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/ttt/ttt.rktl deleted file mode 100644 index 4c1b080596..0000000000 --- a/pkgs/racket-pkgs/racket-test/tests/racket/ttt/ttt.rktl +++ /dev/null @@ -1,13 +0,0 @@ - -(require mzlib/etc mzlib/compat) -(load-relative "listlib.rktl") -(load-relative "veclib.rktl") -(load-relative "tic-func.rktl") - -(let loop () - (collect-garbage) - (collect-garbage) - (collect-garbage) - ; (dump-memory-stats) - (time (tic-tac-toe 1 1)) - '(loop)) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/ttt/veclib.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/ttt/veclib.rktl deleted file mode 100644 index 0f5cb7ba48..0000000000 --- a/pkgs/racket-pkgs/racket-test/tests/racket/ttt/veclib.rktl +++ /dev/null @@ -1,57 +0,0 @@ -;; -------------------------------------------------------------------------- -;; 2vec-library.rkt - -; #| -; (unit/sig -; (make-2vec 2vec-ref 2vec-set! collect) -; (import plt:userspace^) -; |# - - ;; 2 dimensional, square vectors - - (define collect - (lambda (base combine) - (define C - (lambda (l) - (cond - ((null? l) base) - (else (combine l (car l) (C (cdr l))))))) - C)) - - (define (make-2vec N element) - (make-vector (* N N) element)) - - (define (2vec-ref 2vec i j) - (let ((L (sqrt (vector-length 2vec)))) - (vector-ref 2vec (+ (* i L) j)))) - - (define (2vec-set! 2vec i j element) - (let ((L (sqrt (vector-length 2vec)))) - (if (and (< i L) (< j L)) - (vector-set! 2vec (+ (* i L) j) element) - (error '2vec-set! "~s ~s" i j)))) - - (define (I N) - (let ((2vec (make-2vec N 0))) - (let loop ((i 0) (j 0)) - (if (= i N) - (void) - (begin - (2vec-set! 2vec i j 1) - (loop (add1 i) (add1 j))))) - 2vec)) - - (define (P N) - (let ((2vec (make-2vec N 0))) - (let loop ((i 0) (j 0)) - (cond - [(and (= i N) (= j 0)) (void)] - [(< j N) (2vec-set! 2vec i j (list i j)) (loop i (add1 j))] - [(< i N) (loop (add1 i) 0)] - [else (error 'P "impossible ~s ~s" i j)])) - 2vec)) - -; #| -; ) -; |# - diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/uni-norm.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/uni-norm.rktl index 09f204a8f6..fa4dd3c66c 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/uni-norm.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/uni-norm.rktl @@ -1,7 +1,7 @@ -(require mzlib/string +(require racket/string (only-in net/url get-pure-port string->url) - (only-in mzlib/port copy-port)) + (only-in racket/port copy-port)) (load-relative "loadtest.rktl") diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/zo-marshal.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/zo-marshal.rktl deleted file mode 100644 index f829ae8272..0000000000 --- a/pkgs/racket-pkgs/racket-test/tests/racket/zo-marshal.rktl +++ /dev/null @@ -1,407 +0,0 @@ - -(load-relative "loadtest.rktl") - -(Section 'zo-marshal) - -(require compiler/zo-parse - compiler/zo-marshal) - -(define-struct mpi (n b) #:transparent) - -;; Exposes content of module-path indices, strip away -;; closure ids, and normalize `indirects' so we can compare them -;; with `equal?': -(define mpx - (case-lambda - [(v) (let ([it (make-hash)]) - (let loop ([v v]) - (cond - [(pair? v) (cons (loop (car v)) (loop (cdr v)))] - [(indirect? v) - (or (hash-ref it v #f) - (let ([i (make-indirect #f)]) - (hash-set! it v i) - (set-indirect-v! i - (make-closure - (loop (closure-code (indirect-v v))) - 'closure)) - i))] - [(closure? v) (make-indirect - (make-closure (loop (closure-code v)) 'closure))] - [(struct? v) (let-values ([(st ?) (struct-info v)]) - (if st - (let ([c (struct-type-make-constructor st)]) - (apply c - (map loop - (cdr - (vector->list - (struct->vector v)))))) - v))] - [(module-path-index? v) - (let-values ([(name base) (module-path-index-split v)]) - (make-mpi name base))] - [else v])))] - [(f v) (mpx (f v))])) - -(define (check expr val #:wrap [wrap values]) - (let ([s (zo-marshal expr)]) - (test (mpx expr) mpx zo-parse (open-input-bytes s)) - (test val wrap (eval (parameterize ([read-accept-compiled #t]) - (read (open-input-bytes s))))))) - -(define (get-id id) - (primval-id - (compilation-top-code - (zo-parse (let ([s (open-output-bytes)]) - (write (compile id) s) - (open-input-bytes (get-output-bytes s))))))) - -(define values-id (get-id #'values)) -(define list-id (get-id #'list)) -(define object-name-id (get-id #'object-name)) - -(define GLOBALV 78) -(module zo-m scheme/base - (provide x) - (define x 88)) -(require 'zo-m) - -;; ---------------------------------------- - -(define (make-simple e) - (make-compilation-top - 10 - (make-prefix 0 null null) - e)) - -(define (make-global e) - (make-compilation-top - 10 - (make-prefix 0 (list (make-global-bucket 'GLOBALV) - (make-module-variable (module-path-index-join ''zo-m #f) - 'x - -1 - 0)) - null) - e)) - -;; ---------------------------------------- - -(check (make-simple 5) - 5) - -(let ([ck (lambda (cl? o-cls?) - (check (make-simple (make-let-one - 51 - (make-localref #f 0 cl? o-cls?))) - 51))]) - (ck #f #f) - (ck #t #f) - (ck #f #t)) - - -(check (make-simple (make-let-one - 15 - (make-boxenv - 0 - (make-localref #t 0 #f #f)))) - 15) - -(check (make-simple (make-let-void - 3 - #f - (make-install-value - 1 - 0 - #f - 503 - (make-boxenv - 0 - (make-localref #t 0 #f #f))))) - 503) - -(check (make-simple (make-let-void - 3 - #f - (make-install-value - 2 - 1 - #f - (make-application - (make-primval values-id) - (list 503 - 507)) - (make-localref #f 2 #f #f)))) - 507) - -(check (make-simple (make-branch - #t - 50 - -50)) - 50) - -(check (make-simple (make-branch - #f - 50 - -50)) - -50) - -;; ---------------------------------------- - -(define (make-ab body) - (make-simple (make-let-void - 2 - #f - (make-let-rec - (list - (make-lam 'a - null - 1 - '(val) - #f - #(1) - 10 - (make-branch - (make-localref #f 1 #f #f) - (make-localref #f 0 #f #f) - 59)) - (make-lam 'b - null - 1 - '(val) - #f - #(0) - 10 - (make-localref #f 0 #f #f))) - body)))) - -(check (make-ab 517) - 517) - -(check (make-ab (make-application - (make-primval object-name-id) - (list (make-localref #f 1 #f #f)))) - 'a) -(check (make-ab (make-application - (make-primval object-name-id) - (list (make-localref #f 2 #f #f)))) - 'b) - -(check (make-ab (make-application - (make-localref #f 1 #f #f) - (list #f))) - 59) -(check (make-ab (make-application - (make-primval object-name-id) - (list - (make-application - (make-localref #f 2 #f #f) - (list #t))))) - 'b) -(check (make-ab (make-application - (make-primval object-name-id) - (list - (make-application - (make-application - (make-localref #f 3 #f #f) - (list #t)) - (list -5))))) - 'a) - -;; ---------------------------------------- - -(check (make-simple - (make-let-one - 'v1 - (make-let-one - 'v0 - (make-let-one - (make-lam 'proc - null - 1 - '(val) - #f - #(1 2) - 20 - (make-application - (make-primval list-id) - (list - (make-localref #f 2 #f #f) - (make-localref #f 3 #f #f)))) - (make-application - (make-localref #f 1 #f #f) - (list 5)))))) - '(v0 v1)) - -;; ---------------------------------------- - -(check (make-global - (make-toplevel 0 0 #f #f)) - 78) -(check (make-global - (make-toplevel 0 1 #f #f)) - 88) - -;; ---------------------------------------- - -(check (make-simple - (make-seq (list 1 56))) - 56) -(check (make-simple - (make-splice (list 1 57))) - 57) -(check (make-global - (make-splice (list (make-toplevel 0 0 #f #f) 57))) - 57) -(check (make-simple - (make-beg0 (list 1 56))) - 1) -(check (make-global - (make-beg0 (list 57 (make-toplevel 0 0 #f #f)))) - 57) - -;; ---------------------------------------- - -(check (make-simple - (make-closure - (make-lam 'proc - null - 1 - '(val) - #f - #() - 10 - (make-localref #f 0 #f #f)) - 'proc)) - 8 - #:wrap (lambda (f) (f 8))) - -(define rec-proc - (let ([self (make-indirect #f)]) - (set-indirect-v! self - (make-closure - (make-lam 'proc - null - 1 - '(val) - #f - #() - 10 - (make-branch - (make-localref #f 0 #f #f) - self - 17)) - 'proc)) - self)) - -(check (make-simple - rec-proc) - 17 - #:wrap (lambda (f) (f #f))) -(check (make-simple - rec-proc) - 'proc - #:wrap (lambda (f) (object-name (f #t)))) - -;; ---------------------------------------- - -(define cl-proc - (make-case-lam - 'cl-proc - (list - (make-lam 'proc - null - 1 - '(val) - #f - #() - 10 - (make-localref #f 0 #f #f)) - (make-lam 'proc - null - 2 - '(val val) - #f - #() - 10 - (make-application - (make-primval list-id) - (list - (make-localref #f 2 #f #f) - (make-localref #f 3 #f #f))))))) - -(check (make-simple cl-proc) - #:wrap (lambda (f) (f 3)) - 3) -(check (make-simple cl-proc) - #:wrap (lambda (f) (f 1 2)) - '(1 2)) -(check (make-simple cl-proc) - #:wrap object-name - 'cl-proc) - -(define cl-proc2 - (make-let-one - 'cl1 - (make-let-one - 'cl2 - (make-case-lam - 'cl-proc - (list - (make-lam 'proc - null - 0 - '() - #f - #(0) - 10 - (make-localref #f 0 #f #f)) - (make-lam 'proc - null - 1 - '(val) - #f - #(1) - 10 - (make-application - (make-primval list-id) - (list - (make-localref #f 2 #f #f) - (make-localref #f 3 #f #f))))))))) -(check (make-simple cl-proc2) - #:wrap (lambda (f) (f)) - 'cl2) -(check (make-simple cl-proc2) - #:wrap (lambda (f) (f 2)) - '(cl1 2)) - -;; ---------------------------------------- - -(check (make-global - (make-varref (make-toplevel 0 0 #f #f))) - #:wrap variable-reference? - #t) - -;; ---------------------------------------- - -(check (make-global - (make-assign (make-toplevel 0 0 #f #f) - 99 - #f)) - (void)) -(test 99 values GLOBALV) - -;; ---------------------------------------- - -(check (make-global - (make-apply-values - (make-primval list-id) - (make-application - (make-primval values-id) - (list 503 - 507)))) - '(503 507)) - -;; ---------------------------------------- - -(report-errs) diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/ztest.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/ztest.rktl deleted file mode 100644 index 676e795d79..0000000000 --- a/pkgs/racket-pkgs/racket-test/tests/racket/ztest.rktl +++ /dev/null @@ -1,20 +0,0 @@ -;; rudimentary test harness for complex math routines in -;; zmath.rkt - -(require mzlib/zmath) - -(define ztest - (lambda (z) - (printf "z = ~a\n" z) - (printf " zabs(z) = ~a\n" (zabs z)) - (printf " zlog(z) = ~a\n" (zlog z)) - (printf " zexp(z) = ~a\n" (zexp z)) - (printf " zsqrt(z) = ~a\n" (zsqrt z)) - (printf " zsin(z) = ~a\n" (zsin z)) - (printf " zcos(z) = ~a\n" (zcos z)) - (printf " ztan(z) = ~a\n" (ztan z)) - (printf " zasin(z) = ~a\n" (zasin z)) - (printf " zacos(z) = ~a\n" (zacos z)) - (printf " zatan(z) = ~a\n" (zatan z)))) - -(ztest 0.5)